This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
RE: Fwd: DEC Extension Patches: Structure, Union, and Map
- From: Fritz Reese <fritzoreese at gmail dot com>
- To: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Tue, 1 Mar 2016 16:16:55 -0500
- Subject: RE: Fwd: DEC Extension Patches: Structure, Union, and Map
- Authentication-results: sourceware.org; auth=none
Please see the original thread
https://gcc.gnu.org/ml/fortran/2016-03/msg00002.html.
I have to send the patches separately, as together they cause me to be
blocked for spamming. This is patch 2:
---
Fritz Reese
From 2f7077c45fdcf2d05554d9d2e22fc5261bd95661 Mon Sep 17 00:00:00 2001
From: Fritz O. Reese <fritzoreese@gmail.com>
Date: Mon, 10 Nov 2014 13:34:06 -0500
Subject: [PATCH 2/4] 2014-11-10 Fritz Reese <fritzoreese@gmail.com>
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