From 2f7077c45fdcf2d05554d9d2e22fc5261bd95661 Mon Sep 17 00:00:00 2001 From: Fritz O. Reese Date: Mon, 10 Nov 2014 13:34:06 -0500 Subject: [PATCH 2/4] 2014-11-10 Fritz Reese gcc/fortran/ * resolve.c (resolve_component): New function. (resolve_fl_derived0): Move component loop code to resolve_component. --- gcc/fortran/resolve.c | 742 ++++++++++++++++++++++++------------------------- 1 files changed, 365 insertions(+), 377 deletions(-) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 556c846..1c3b814 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12899,438 +12899,426 @@ check_defined_assignments (gfc_symbol *derived) } -/* Resolve the components of a derived type. This does not have to wait until - resolution stage, but can be done as soon as the dt declaration has been - parsed. */ +/* Resolve a single component of a derived type. */ static bool -resolve_fl_derived0 (gfc_symbol *sym) +resolve_component (gfc_component *c, gfc_symbol *sym) { - gfc_symbol* super_type; - gfc_component *c; + gfc_symbol *super_type; - if (sym->attr.unlimited_polymorphic) + if (c->attr.artificial) return true; - super_type = gfc_get_derived_super_type (sym); + /* F2008, C442. */ + if ((!sym->attr.is_class || c != sym->components) + && c->attr.codimension + && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) + { + gfc_error ("Coarray component %qs at %L must be allocatable with " + "deferred shape", c->name, &c->loc); + return false; + } - /* F2008, C432. */ - if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + /* F2008, C443. */ + if (c->attr.codimension && c->ts.type == BT_DERIVED + && c->ts.u.derived->ts.is_iso_c) { - gfc_error ("As extending type %qs at %L has a coarray component, " - "parent type %qs shall also have one", sym->name, - &sym->declared_at, super_type->name); + gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", c->name, &c->loc); return false; } - /* Ensure the extended type gets resolved before we do. */ - if (super_type && !resolve_fl_derived0 (super_type)) - return false; + /* F2008, C444. */ + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp + && (c->attr.codimension || c->attr.pointer || c->attr.dimension + || c->attr.allocatable)) + { + gfc_error ("Component %qs at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + c->name, &c->loc); + return false; + } - /* An ABSTRACT type must be extensible. */ - if (sym->attr.abstract && !gfc_type_is_extensible (sym)) + /* F2008, C448. */ + if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) { - gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", - sym->name, &sym->declared_at); + gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); return false; } - c = (sym->attr.is_class) ? sym->components->ts.u.derived->components - : sym->components; + if (c->attr.proc_pointer && c->ts.interface) + { + gfc_symbol *ifc = c->ts.interface; - bool success = true; + if (!sym->attr.vtype + && !check_proc_interface (ifc, &c->loc)) + return false; - for ( ; c != NULL; c = c->next) + if (ifc->attr.if_source || ifc->attr.intrinsic) + { + /* Resolve interface and copy attributes. */ + if (ifc->formal && !ifc->formal_ns) + resolve_symbol (ifc); + if (ifc->attr.intrinsic) + gfc_resolve_intrinsic (ifc, &ifc->declared_at); + + if (ifc->result) + { + c->ts = ifc->result->ts; + c->attr.allocatable = ifc->result->attr.allocatable; + c->attr.pointer = ifc->result->attr.pointer; + c->attr.dimension = ifc->result->attr.dimension; + c->as = gfc_copy_array_spec (ifc->result->as); + c->attr.class_ok = ifc->result->attr.class_ok; + } + else + { + c->ts = ifc->ts; + c->attr.allocatable = ifc->attr.allocatable; + c->attr.pointer = ifc->attr.pointer; + c->attr.dimension = ifc->attr.dimension; + c->as = gfc_copy_array_spec (ifc->as); + c->attr.class_ok = ifc->attr.class_ok; + } + c->ts.interface = ifc; + c->attr.function = ifc->attr.function; + c->attr.subroutine = ifc->attr.subroutine; + + c->attr.pure = ifc->attr.pure; + c->attr.elemental = ifc->attr.elemental; + c->attr.recursive = ifc->attr.recursive; + c->attr.always_explicit = ifc->attr.always_explicit; + c->attr.ext_attr |= ifc->attr.ext_attr; + /* Copy char length. */ + if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) + { + gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); + if (cl->length && !cl->resolved + && !gfc_resolve_expr (cl->length)) + return false; + c->ts.u.cl = cl; + } + } + } + else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) { - if (c->attr.artificial) - continue; + /* Since PPCs are not implicitly typed, a PPC without an explicit + interface must be a subroutine. */ + gfc_add_subroutine (&c->attr, c->name, &c->loc); + } - /* F2008, C442. */ - if ((!sym->attr.is_class || c != sym->components) - && c->attr.codimension - && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) - { - gfc_error ("Coarray component %qs at %L must be allocatable with " - "deferred shape", c->name, &c->loc); - success = false; - continue; - } + /* Procedure pointer components: Check PASS arg. */ + if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 + && !sym->attr.vtype) + { + gfc_symbol* me_arg; - /* F2008, C443. */ - if (c->attr.codimension && c->ts.type == BT_DERIVED - && c->ts.u.derived->ts.is_iso_c) - { - gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " - "shall not be a coarray", c->name, &c->loc); - success = false; - continue; - } + if (c->tb->pass_arg) + { + gfc_formal_arglist* i; - /* F2008, C444. */ - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp - && (c->attr.codimension || c->attr.pointer || c->attr.dimension - || c->attr.allocatable)) - { - gfc_error ("Component %qs at %L with coarray component " - "shall be a nonpointer, nonallocatable scalar", - c->name, &c->loc); - success = false; - continue; - } + /* If an explicit passing argument name is given, walk the arg-list + and look for it. */ - /* F2008, C448. */ - if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) - { - gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " - "is not an array pointer", c->name, &c->loc); - success = false; - continue; - } + me_arg = NULL; + c->tb->pass_arg_num = 1; + for (i = c->ts.interface->formal; i; i = i->next) + { + if (!strcmp (i->sym->name, c->tb->pass_arg)) + { + me_arg = i->sym; + break; + } + c->tb->pass_arg_num++; + } - if (c->attr.proc_pointer && c->ts.interface) - { - gfc_symbol *ifc = c->ts.interface; + if (!me_arg) + { + gfc_error ("Procedure pointer component %qs with PASS(%s) " + "at %L has no argument %qs", c->name, + c->tb->pass_arg, &c->loc, c->tb->pass_arg); + c->tb->error = 1; + return false; + } + } + else + { + /* Otherwise, take the first one; there should in fact be at least + one. */ + c->tb->pass_arg_num = 1; + if (!c->ts.interface->formal) + { + gfc_error ("Procedure pointer component %qs with PASS at %L " + "must have at least one argument", + c->name, &c->loc); + c->tb->error = 1; + return false; + } + me_arg = c->ts.interface->formal->sym; + } - if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc)) - { - c->tb->error = 1; - success = false; - continue; - } + /* Now check that the argument-type matches. */ + gcc_assert (me_arg); + if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) + || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) + || (me_arg->ts.type == BT_CLASS + && CLASS_DATA (me_arg)->ts.u.derived != sym)) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the derived type %qs", me_arg->name, c->name, + me_arg->name, &c->loc, sym->name); + c->tb->error = 1; + return false; + } - if (ifc->attr.if_source || ifc->attr.intrinsic) - { - /* Resolve interface and copy attributes. */ - if (ifc->formal && !ifc->formal_ns) - resolve_symbol (ifc); - if (ifc->attr.intrinsic) - gfc_resolve_intrinsic (ifc, &ifc->declared_at); + /* Check for C453. */ + if (me_arg->attr.dimension) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "must be scalar", me_arg->name, c->name, me_arg->name, + &c->loc); + c->tb->error = 1; + return false; + } - if (ifc->result) - { - c->ts = ifc->result->ts; - c->attr.allocatable = ifc->result->attr.allocatable; - c->attr.pointer = ifc->result->attr.pointer; - c->attr.dimension = ifc->result->attr.dimension; - c->as = gfc_copy_array_spec (ifc->result->as); - c->attr.class_ok = ifc->result->attr.class_ok; - } - else - { - c->ts = ifc->ts; - c->attr.allocatable = ifc->attr.allocatable; - c->attr.pointer = ifc->attr.pointer; - c->attr.dimension = ifc->attr.dimension; - c->as = gfc_copy_array_spec (ifc->as); - c->attr.class_ok = ifc->attr.class_ok; - } - c->ts.interface = ifc; - c->attr.function = ifc->attr.function; - c->attr.subroutine = ifc->attr.subroutine; - - c->attr.pure = ifc->attr.pure; - c->attr.elemental = ifc->attr.elemental; - c->attr.recursive = ifc->attr.recursive; - c->attr.always_explicit = ifc->attr.always_explicit; - c->attr.ext_attr |= ifc->attr.ext_attr; - /* Copy char length. */ - if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) - { - gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - if (cl->length && !cl->resolved - && !gfc_resolve_expr (cl->length)) - { - c->tb->error = 1; - success = false; - continue; - } - c->ts.u.cl = cl; - } - } - } - else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) - { - /* Since PPCs are not implicitly typed, a PPC without an explicit - interface must be a subroutine. */ - gfc_add_subroutine (&c->attr, c->name, &c->loc); - } + if (me_arg->attr.pointer) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "may not have the POINTER attribute", me_arg->name, + c->name, me_arg->name, &c->loc); + c->tb->error = 1; + return false; + } - /* Procedure pointer components: Check PASS arg. */ - if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 - && !sym->attr.vtype) - { - gfc_symbol* me_arg; + if (me_arg->attr.allocatable) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "may not be ALLOCATABLE", me_arg->name, c->name, + me_arg->name, &c->loc); + c->tb->error = 1; + return false; + } - if (c->tb->pass_arg) - { - gfc_formal_arglist* i; + if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) + gfc_error ("Non-polymorphic passed-object dummy argument of %qs" + " at %L", c->name, &c->loc); - /* If an explicit passing argument name is given, walk the arg-list - and look for it. */ + } - me_arg = NULL; - c->tb->pass_arg_num = 1; - for (i = c->ts.interface->formal; i; i = i->next) - { - if (!strcmp (i->sym->name, c->tb->pass_arg)) - { - me_arg = i->sym; - break; - } - c->tb->pass_arg_num++; - } + /* Check type-spec if this is not the parent-type component. */ + if (((sym->attr.is_class + && (!sym->components->ts.u.derived->attr.extension + || c != sym->components->ts.u.derived->components)) + || (!sym->attr.is_class + && (!sym->attr.extension || c != sym->components))) + && !sym->attr.vtype + && !resolve_typespec_used (&c->ts, &c->loc, c->name)) + return false; - if (!me_arg) - { - gfc_error ("Procedure pointer component %qs with PASS(%s) " - "at %L has no argument %qs", c->name, - c->tb->pass_arg, &c->loc, c->tb->pass_arg); - c->tb->error = 1; - success = false; - continue; - } - } - else - { - /* Otherwise, take the first one; there should in fact be at least - one. */ - c->tb->pass_arg_num = 1; - if (!c->ts.interface->formal) - { - gfc_error ("Procedure pointer component %qs with PASS at %L " - "must have at least one argument", - c->name, &c->loc); - c->tb->error = 1; - success = false; - continue; - } - me_arg = c->ts.interface->formal->sym; - } + super_type = gfc_get_derived_super_type (sym); - /* Now check that the argument-type matches. */ - gcc_assert (me_arg); - if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) - || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) - || (me_arg->ts.type == BT_CLASS - && CLASS_DATA (me_arg)->ts.u.derived != sym)) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" - " the derived type %qs", me_arg->name, c->name, - me_arg->name, &c->loc, sym->name); - c->tb->error = 1; - success = false; - continue; - } + /* If this type is an extension, set the accessibility of the parent + component. */ + if (super_type + && ((sym->attr.is_class + && c == sym->components->ts.u.derived->components) + || (!sym->attr.is_class && c == sym->components)) + && strcmp (super_type->name, c->name) == 0) + c->attr.access = super_type->attr.access; + + /* If this type is an extension, see if this component has the same name + as an inherited type-bound procedure. */ + if (super_type && !sym->attr.is_class + && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) + { + gfc_error ("Component %qs of %qs at %L has the same name as an" + " inherited type-bound procedure", + c->name, sym->name, &c->loc); + return false; + } - /* Check for C453. */ - if (me_arg->attr.dimension) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "must be scalar", me_arg->name, c->name, me_arg->name, - &c->loc); - c->tb->error = 1; - success = false; - continue; - } + if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer + && !c->ts.deferred) + { + if (c->ts.u.cl->length == NULL + || (!resolve_charlen(c->ts.u.cl)) + || !gfc_is_constant_expr (c->ts.u.cl->length)) + { + gfc_error ("Character length of component %qs needs to " + "be a constant specification expression at %L", + c->name, + c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); + return false; + } + } - if (me_arg->attr.pointer) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "may not have the POINTER attribute", me_arg->name, - c->name, me_arg->name, &c->loc); - c->tb->error = 1; - success = false; - continue; - } + if (c->ts.type == BT_CHARACTER && c->ts.deferred + && !c->attr.pointer && !c->attr.allocatable) + { + gfc_error ("Character component %qs of %qs at %L with deferred " + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); + return false; + } - if (me_arg->attr.allocatable) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "may not be ALLOCATABLE", me_arg->name, c->name, - me_arg->name, &c->loc); - c->tb->error = 1; - success = false; - continue; - } + /* Add the hidden deferred length field. */ + if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function + && !sym->attr.is_class) + { + char name[GFC_MAX_SYMBOL_LEN+9]; + gfc_component *strlen; + sprintf (name, "_%s_length", c->name); + strlen = gfc_find_component (sym, name, true, true); + if (strlen == NULL) + { + if (!gfc_add_component (sym, name, &strlen)) + return false; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.artificial = 1; + } + } - if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) - { - gfc_error ("Non-polymorphic passed-object dummy argument of %qs" - " at %L", c->name, &c->loc); - success = false; - continue; - } + if (c->ts.type == BT_DERIVED + && sym->component_access != ACCESS_PRIVATE + && gfc_check_symbol_access (sym) + && !is_sym_host_assoc (c->ts.u.derived, sym->ns) + && !c->ts.u.derived->attr.use_assoc + && !gfc_check_symbol_access (c->ts.u.derived) + && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " + "PRIVATE type and cannot be a component of " + "%qs, which is PUBLIC at %L", c->name, + sym->name, &sym->declared_at)) + return false; - } + if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " + "type %s", c->name, &c->loc, sym->name); + return false; + } - /* Check type-spec if this is not the parent-type component. */ - if (((sym->attr.is_class - && (!sym->components->ts.u.derived->attr.extension - || c != sym->components->ts.u.derived->components)) - || (!sym->attr.is_class - && (!sym->attr.extension || c != sym->components))) - && !sym->attr.vtype - && !resolve_typespec_used (&c->ts, &c->loc, c->name)) - return false; + if (sym->attr.sequence) + { + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) + { + gfc_error ("Component %s of SEQUENCE type declared at %L does " + "not have the SEQUENCE attribute", + c->ts.u.derived->name, &sym->declared_at); + return false; + } + } - /* If this type is an extension, set the accessibility of the parent - component. */ - if (super_type - && ((sym->attr.is_class - && c == sym->components->ts.u.derived->components) - || (!sym->attr.is_class && c == sym->components)) - && strcmp (super_type->name, c->name) == 0) - c->attr.access = super_type->attr.access; - - /* If this type is an extension, see if this component has the same name - as an inherited type-bound procedure. */ - if (super_type && !sym->attr.is_class - && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) - { - gfc_error ("Component %qs of %qs at %L has the same name as an" - " inherited type-bound procedure", - c->name, sym->name, &c->loc); - return false; - } + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) + c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); + else if (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->ts.u.derived->attr.generic) + CLASS_DATA (c)->ts.u.derived + = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); - if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer - && !c->ts.deferred) - { - if (c->ts.u.cl->length == NULL - || (!resolve_charlen(c->ts.u.cl)) - || !gfc_is_constant_expr (c->ts.u.cl->length)) - { - gfc_error ("Character length of component %qs needs to " - "be a constant specification expression at %L", - c->name, - c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); - return false; - } - } + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype + && c->attr.pointer && c->ts.u.derived->components == NULL + && !c->ts.u.derived->attr.zero_comp) + { + gfc_error ("The pointer component %qs of %qs at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return false; + } - if (c->ts.type == BT_CHARACTER && c->ts.deferred - && !c->attr.pointer && !c->attr.allocatable) - { - gfc_error ("Character component %qs of %qs at %L with deferred " - "length must be a POINTER or ALLOCATABLE", - c->name, sym->name, &c->loc); - return false; - } + if (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.class_pointer + && CLASS_DATA (c)->ts.u.derived->components == NULL + && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp + && !UNLIMITED_POLY (c)) + { + gfc_error ("The pointer component %qs of %qs at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return false; + } - /* Add the hidden deferred length field. */ - if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function - && !sym->attr.is_class) - { - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *strlen; - sprintf (name, "_%s_length", c->name); - strlen = gfc_find_component (sym, name, true, true); - if (strlen == NULL) - { - if (!gfc_add_component (sym, name, &strlen)) - return false; - strlen->ts.type = BT_INTEGER; - strlen->ts.kind = gfc_charlen_int_kind; - strlen->attr.access = ACCESS_PRIVATE; - strlen->attr.artificial = 1; - } - } + /* C437. */ + if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE + && (!c->attr.class_ok + || !(CLASS_DATA (c)->attr.class_pointer + || CLASS_DATA (c)->attr.allocatable))) + { + gfc_error ("Component %qs with CLASS at %L must be allocatable " + "or pointer", c->name, &c->loc); + /* Prevent a recurrence of the error. */ + c->ts.type = BT_UNKNOWN; + return false; + } - if (c->ts.type == BT_DERIVED - && sym->component_access != ACCESS_PRIVATE - && gfc_check_symbol_access (sym) - && !is_sym_host_assoc (c->ts.u.derived, sym->ns) - && !c->ts.u.derived->attr.use_assoc - && !gfc_check_symbol_access (c->ts.u.derived) - && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " - "PRIVATE type and cannot be a component of " - "%qs, which is PUBLIC at %L", c->name, - sym->name, &sym->declared_at)) - return false; + /* Ensure that all the derived type components are put on the + derived type list; even in formal namespaces, where derived type + pointer components might not have been declared. */ + if (c->ts.type == BT_DERIVED + && c->ts.u.derived + && c->ts.u.derived->components + && c->attr.pointer + && sym != c->ts.u.derived) + add_dt_to_dt_list (c->ts.u.derived); - if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) - { - gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " - "type %s", c->name, &c->loc, sym->name); - return false; - } + if (!gfc_resolve_array_spec (c->as, + !(c->attr.pointer || c->attr.proc_pointer + || c->attr.allocatable))) + return false; - if (sym->attr.sequence) - { - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) - { - gfc_error ("Component %s of SEQUENCE type declared at %L does " - "not have the SEQUENCE attribute", - c->ts.u.derived->name, &sym->declared_at); - return false; - } - } + if (c->initializer && !sym->attr.vtype + && !gfc_check_assign_symbol (sym, c, c->initializer)) + return false; - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) - c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); - else if (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->ts.u.derived->attr.generic) - CLASS_DATA (c)->ts.u.derived - = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); + return true; +} - if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype - && c->attr.pointer && c->ts.u.derived->components == NULL - && !c->ts.u.derived->attr.zero_comp) - { - gfc_error ("The pointer component %qs of %qs at %L is a type " - "that has not been declared", c->name, sym->name, - &c->loc); - return false; - } - if (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.class_pointer - && CLASS_DATA (c)->ts.u.derived->components == NULL - && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp - && !UNLIMITED_POLY (c)) - { - gfc_error ("The pointer component %qs of %qs at %L is a type " - "that has not been declared", c->name, sym->name, - &c->loc); - return false; - } +/* Resolve the components of a derived type. This does not have to wait until + resolution stage, but can be done as soon as the dt declaration has been + parsed. */ - /* C437. */ - if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE - && (!c->attr.class_ok - || !(CLASS_DATA (c)->attr.class_pointer - || CLASS_DATA (c)->attr.allocatable))) - { - gfc_error ("Component %qs with CLASS at %L must be allocatable " - "or pointer", c->name, &c->loc); - /* Prevent a recurrence of the error. */ - c->ts.type = BT_UNKNOWN; - return false; - } +static bool +resolve_fl_derived0 (gfc_symbol *sym) +{ + gfc_symbol* super_type; + gfc_component *c; - /* Ensure that all the derived type components are put on the - derived type list; even in formal namespaces, where derived type - pointer components might not have been declared. */ - if (c->ts.type == BT_DERIVED - && c->ts.u.derived - && c->ts.u.derived->components - && c->attr.pointer - && sym != c->ts.u.derived) - add_dt_to_dt_list (c->ts.u.derived); - - if (!gfc_resolve_array_spec (c->as, - !(c->attr.pointer || c->attr.proc_pointer - || c->attr.allocatable))) - return false; + if (sym->attr.unlimited_polymorphic) + return true; - if (c->initializer && !sym->attr.vtype - && !gfc_check_assign_symbol (sym, c, c->initializer)) - return false; + super_type = gfc_get_derived_super_type (sym); + + /* F2008, C432. */ + if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + { + gfc_error ("As extending type %qs at %L has a coarray component, " + "parent type %qs shall also have one", sym->name, + &sym->declared_at, super_type->name); + return false; } - if (!success) + /* Ensure the extended type gets resolved before we do. */ + if (super_type && !resolve_fl_derived0 (super_type)) return false; + /* An ABSTRACT type must be extensible. */ + if (sym->attr.abstract && !gfc_type_is_extensible (sym)) + { + gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", + sym->name, &sym->declared_at); + return false; + } + + c = (sym->attr.is_class) ? sym->components->ts.u.derived->components + : sym->components; + + for ( ; c != NULL; c = c->next) + if (!resolve_component (c, sym)) + return false; + check_defined_assignments (sym); if (!sym->attr.defined_assign_comp && super_type) -- 1.7.1