This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] Derived type extension
- From: "Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>
- To: "Fortran List" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 27 Jul 2008 22:30:43 +0200
- Subject: [Patch, fortran] Derived type extension
- Dkim-signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma; h=domainkey-signature:received:received:message-id:date:from:to :subject:mime-version:content-type; bh=7zV0HIqZaHFxIe0/GBF+KQw7Ppi8hQDE9jLd8JsxK4U=; b=u9XanaJkdPU9mk6XdtzFnRPMbP8i+r4Qi+Rp3SBSWvi+iWPDzALUXZj56xhXSXwv3K /2YgwXuVV/El4VKAEO+xTTwF5R/pCvCmI05ybq0fkMyTkcYBi4dpJgz5Ic1pfe43XwfY LKemHwavPylbHPO/lH7lXM2HBl+B2SZuIzrZY=
- Domainkey-signature: a=rsa-sha1; c=nofws; d=gmail.com; s=gamma; h=message-id:date:from:to:subject:mime-version:content-type; b=bEhRAY+J6cR50Zh+mR8/Yt77RbzbjOjldAZyv9MVIH8yDTuXGF2wTFZQIPXlhKmCk8 6SrX0VMQ9C2qPJ9YX6KKczybdO7kpwLAUjIqc5xINh3BwDysu/Nysp4H9I/6aEEF9nhF oyIwZ/LyyIrBzdMxc2e04RhtNdfad6fnnkYBE=
The attached patch to implement derived type extension is complete, as
far as I can tell, apart from the need for some testcases to check
errors. I will write these before committing the patch. It will be
seen from the attached testcases that the functionality is complete:
(i) Extended derived types are built with the parent type as the first
component;
(ii) References can be complete or partial, to the extent that the
ultimate component name can be used;
(iii) F95 style constructors do the right thing, either in ultimate
component order or with explicit constructors for the parent types;
and
(iv) F2K style constructors work with ultimate component names.
I have cleaned up the wrinkles that Tobias found and have fixed
renamed parents, as per the thread on clf. I realise in writing this
that this latter is not tested. I feel an extends_4.f03 coming on:-)
The code to build structure constructors has been cleaned up some and
the error messages associated with private access have been cleaned
up.
Even without the addition of OOP, this patch is not only usable but is
also useful. Equally important is that putting it in place opens up
all the trimmings associated with F2K classes and forms the right
framework for type bound procedures and finalization. Talking of the
latter, I now must get on with Daniel's patch!
Bootstrapped and regtested on ia86_x64/Fedora 8 - OK for trunk with
the additional testcases?
Paul
PS It was a miracle that the first version worked at all - see the
code in trans-expr.c.
2008-07-27 Paul Thomas <pault@gcc.gnu.org>
* trans-expr.c (conv_parent_component_references): New function
to build missing parent references.
(gfc_conv_variable): Call it
* symbol.c (gfc_add_component): Check that component name in a
derived type extension does not appear in parent.
(gfc_find_component): For a derived type extension, check if
the component appears in the parent derived type by calling
self. Separate errors for private components and private types.
* decl.c (match_data_constant): Add extra arg to call to
gfc_match_structure_constructor.
(check_extended_derived_type): New function to check that a
parent derived type exists and that it is OK for exension.
(gfc_get_type_attr_spec): Add extra argument 'name' and return
it if extends is specified.
(gfc_match_derived_decl): Match derived type extension and
build a first component of the parent derived type if OK. Add
the f2k namespace if not present.
* gfortran.h : Add the extension attribute.
* module.c : Handle attribute 'extension'.
* match.h : Modify prototypes for gfc_get_type_attr_spec and
gfc_match_structure_constructor.
* primary.c (build_actual_constructor): New function extracted
from gfc_match_structure_constructor and modified to call self
iteratively to build derived type extensions, when f2k named
components are used.
(gfc_match_structure_constructor): Do not throw error for too
many components if a parent type is being handled. Use
gfc_find_component to generate errors for non-existent or
private components. Iteratively call self for derived type
extensions so that parent constructor is built.
(gfc_match_rvalue): Add extra arg to call to
gfc_match_structure_constructor.
* trans-array.c (gfc_conv_resolve_dependencies): If lhs and rhs
are the same symbol, aliassing does not matter.
2008-07-27 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/extends_1.f90: New test.
* gfortran.dg/extends_2.f90: New test.
* gfortran.dg/extends_3.f90: New test.
* gfortran.dg/private_type_6.f90: Modify error message.
* gfortran.dg/structure_constructor_7.f03: Modify error message.
* gfortran.dg/structure_constructor_8.f03: Modify error message.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 138162)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_component_ref (gfc_se * se, gfc
*** 395,400 ****
--- 395,434 ----
}
+ /* This function deals with component references to components of the
+ parent type for derived type extensons. */
+ static void
+ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
+ {
+ gfc_component *c;
+ gfc_component *cmp;
+ gfc_symbol *dt;
+ gfc_ref parent;
+
+ dt = ref->u.c.sym;
+ c = ref->u.c.component;
+
+ /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
+ parent.type = REF_COMPONENT;
+ parent.next = NULL;
+ parent.u.c.sym = dt;
+ parent.u.c.component = dt->components;
+
+ if (dt->attr.extension && dt->components)
+ {
+ /* Return if the component is not in the parent type. */
+ for (cmp = dt->components->next; cmp; cmp = cmp->next)
+ if (strcmp (c->name, cmp->name) == 0)
+ return;
+
+ /* Otherwise build the reference and call self. */
+ gfc_conv_component_ref (se, &parent);
+ parent.u.c.sym = dt->components->ts.derived;
+ parent.u.c.component = c;
+ conv_parent_component_references (se, &parent);
+ }
+ }
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 561,566 ****
--- 595,603 ----
break;
case REF_COMPONENT:
+ if (ref->u.c.sym->attr.extension)
+ conv_parent_component_references (se, ref);
+
gfc_conv_component_ref (se, ref);
break;
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 138162)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_resolve_dependencies (gfc_loopi
*** 3253,3266 ****
if (ss->type != GFC_SS_SECTION)
continue;
! if (gfc_could_be_alias (dest, ss)
! || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
{
! nDepend = 1;
! break;
}
!
! if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
{
lref = dest->expr->ref;
rref = ss->expr->ref;
--- 3253,3268 ----
if (ss->type != GFC_SS_SECTION)
continue;
! if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
{
! if (gfc_could_be_alias (dest, ss)
! || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
! {
! nDepend = 1;
! break;
! }
}
! else
{
lref = dest->expr->ref;
rref = ss->expr->ref;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 138162)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_component (gfc_symbol *sym, cons
*** 1701,1706 ****
--- 1701,1714 ----
tail = p;
}
+ if (sym->attr.extension
+ && gfc_find_component (sym->components->ts.derived, name))
+ {
+ gfc_error ("Component '%s' at %C already in the parent type "
+ "at %L", name, &sym->components->ts.derived->declared_at);
+ return FAILURE;
+ }
+
/* Allocate a new component. */
p = gfc_get_component ();
*************** gfc_find_component (gfc_symbol *sym, con
*** 1830,1846 ****
if (strcmp (p->name, name) == 0)
break;
if (p == NULL)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
! else
{
! if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
! || p->access == ACCESS_PRIVATE))
{
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
! p = NULL;
}
}
--- 1838,1873 ----
if (strcmp (p->name, name) == 0)
break;
+ if (p == NULL
+ && sym->attr.extension
+ && sym->components->ts.type == BT_DERIVED)
+ {
+ p = gfc_find_component (sym->components->ts.derived, name);
+ /* Do not overwrite the error. */
+ if (p == NULL)
+ return p;
+ }
+
if (p == NULL)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
!
! else if (sym->attr.use_assoc)
{
! if (p->access == ACCESS_PRIVATE)
{
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
! return NULL;
! }
!
! /* If there were components given and all components are private, error
! out at this place. */
! if (p->access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
! {
! gfc_error ("All components of '%s' are PRIVATE in structure"
! " constructor at %C", sym->name);
! return NULL;
}
}
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 138162)
--- gcc/fortran/decl.c (working copy)
*************** match_data_constant (gfc_expr **result)
*** 367,373 ****
return MATCH_ERROR;
}
else if (sym->attr.flavor == FL_DERIVED)
! return gfc_match_structure_constructor (sym, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
--- 367,373 ----
return MATCH_ERROR;
}
else if (sym->attr.flavor == FL_DERIVED)
! return gfc_match_structure_constructor (sym, result, false);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
*************** syntax:
*** 6250,6255 ****
--- 6250,6298 ----
}
+ /* Check a derived type that is being extended. */
+ static gfc_symbol*
+ check_extended_derived_type (char *name)
+ {
+ gfc_symbol *extended;
+
+ if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
+ {
+ gfc_error ("Ambiguous symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (!extended)
+ {
+ gfc_error ("No such symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (extended->attr.flavor != FL_DERIVED)
+ {
+ gfc_error ("'%s' in EXTENDS expression at %C is not a "
+ "derived type", name);
+ return NULL;
+ }
+
+ if (extended->attr.is_bind_c)
+ {
+ gfc_error ("'%s' cannot be extended at %C because it "
+ "is BIND(C)", extended->name);
+ return NULL;
+ }
+
+ if (extended->attr.sequence)
+ {
+ gfc_error ("'%s' cannot be extended at %C because it "
+ "is a SEQUENCE type", extended->name);
+ return NULL;
+ }
+
+ return extended;
+ }
+
+
/* Match the optional attribute specifiers for a type declaration.
Return MATCH_ERROR if an error is encountered in one of the handled
attributes (public, private, bind(c)), MATCH_NO if what's found is
*************** syntax:
*** 6257,6263 ****
checking on attribute conflicts needs to be done. */
match
! gfc_get_type_attr_spec (symbol_attribute *attr)
{
/* See if the derived type is marked as private. */
if (gfc_match (" , private") == MATCH_YES)
--- 6300,6306 ----
checking on attribute conflicts needs to be done. */
match
! gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
{
/* See if the derived type is marked as private. */
if (gfc_match (" , private") == MATCH_YES)
*************** gfc_get_type_attr_spec (symbol_attribute
*** 6295,6300 ****
--- 6338,6349 ----
/* TODO: attr conflicts need to be checked, probably in symbol.c. */
}
+ else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: derived type "
+ "extended at %C") == FAILURE)
+ return MATCH_ERROR;
+ }
else
return MATCH_NO;
*************** match
*** 6311,6318 ****
--- 6360,6369 ----
gfc_match_derived_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
+ char parent[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
gfc_symbol *sym;
+ gfc_symbol *extended;
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
*************** gfc_match_derived_decl (void)
*** 6320,6336 ****
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
gfc_clear_attr (&attr);
do
{
! is_type_attr_spec = gfc_get_type_attr_spec (&attr);
if (is_type_attr_spec == MATCH_ERROR)
return MATCH_ERROR;
if (is_type_attr_spec == MATCH_YES)
seen_attr = true;
} while (is_type_attr_spec == MATCH_YES);
if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
--- 6371,6397 ----
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
+ name[0] = '\0';
+ parent[0] = '\0';
gfc_clear_attr (&attr);
+ extended = NULL;
do
{
! is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
if (is_type_attr_spec == MATCH_ERROR)
return MATCH_ERROR;
if (is_type_attr_spec == MATCH_YES)
seen_attr = true;
} while (is_type_attr_spec == MATCH_YES);
+ /* Deal with derived type extensions. */
+ if (parent[0])
+ extended = check_extended_derived_type (parent);
+
+ if (parent[0] && !extended)
+ return MATCH_ERROR;
+
if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
*************** gfc_match_derived_decl (void)
*** 6383,6391 ****
if (attr.is_bind_c != 0)
sym->attr.is_bind_c = attr.is_bind_c;
/* Construct the f2k_derived namespace if it is not yet there. */
if (!sym->f2k_derived)
! sym->f2k_derived = gfc_get_namespace (NULL, 0);
gfc_new_block = sym;
--- 6444,6476 ----
if (attr.is_bind_c != 0)
sym->attr.is_bind_c = attr.is_bind_c;
+
/* Construct the f2k_derived namespace if it is not yet there. */
if (!sym->f2k_derived)
! sym->f2k_derived = gfc_get_namespace (NULL, 0);
!
!
! if (extended && !sym->components)
! {
! gfc_component *p;
! gfc_symtree *st;
!
! /* Add the extended derived type as the first component. */
! gfc_add_component (sym, parent, &p);
! sym->attr.extension = 1;
! extended->refs++;
! gfc_set_sym_referenced (extended);
!
! p->ts.type = BT_DERIVED;
! p->ts.derived = extended;
! p->initializer = gfc_default_initializer (&p->ts);
!
! /* Provide the links between the extended type and its extension. */
! if (!extended->f2k_derived)
! extended->f2k_derived = gfc_get_namespace (NULL, 0);
! st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
! st->n.sym = sym;
! }
gfc_new_block = sym;
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 138162)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 640,645 ****
--- 640,646 ----
unsigned untyped:1; /* No implicit type could be found. */
unsigned is_bind_c:1; /* say if is bound to C */
+ unsigned extension:1; /* extends a derived type */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
*************** typedef struct gfc_symbol
*** 1018,1026 ****
gfc_formal_arglist *formal;
struct gfc_namespace *formal_ns;
-
- /* The namespace containing type-associated procedure symbols. */
- /* TODO: Make this union with formal? */
struct gfc_namespace *f2k_derived;
struct gfc_expr *value; /* Parameter/Initializer value */
--- 1019,1024 ----
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 138162)
--- gcc/fortran/module.c (working copy)
*************** typedef enum
*** 1648,1654 ****
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
! AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP
}
ab_attribute;
--- 1648,1655 ----
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
! AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
! AB_EXTENSION
}
ab_attribute;
*************** static const mstring attr_bits[] =
*** 1688,1693 ****
--- 1689,1695 ----
minit ("ZERO_COMP", AB_ZERO_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit ("ABSTRACT", AB_ABSTRACT),
+ minit ("EXTENSION", AB_EXTENSION),
minit (NULL, -1)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 1801,1806 ****
--- 1803,1810 ----
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
+ if (attr->extension)
+ MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
mio_rparen ();
*************** mio_symbol_attribute (symbol_attribute *
*** 1919,1924 ****
--- 1923,1931 ----
case AB_ZERO_COMP:
attr->zero_comp = 1;
break;
+ case AB_EXTENSION:
+ attr->extension = 1;
+ break;
}
}
}
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 138162)
--- gcc/fortran/match.h (working copy)
*************** try get_bind_c_idents (void);
*** 182,191 ****
match gfc_match_bind_c_stmt (void);
match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
match gfc_match_bind_c (gfc_symbol *, bool);
! match gfc_get_type_attr_spec (symbol_attribute *);
/* primary.c. */
! match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **);
--- 182,191 ----
match gfc_match_bind_c_stmt (void);
match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
match gfc_match_bind_c (gfc_symbol *, bool);
! match gfc_get_type_attr_spec (symbol_attribute *, char*);
/* primary.c. */
! match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **, bool);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **);
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 138162)
--- gcc/fortran/primary.c (working copy)
*************** gfc_free_structure_ctor_component (gfc_s
*** 1984,1994 ****
gfc_free_expr (comp->val);
}
! match
! gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
- gfc_structure_ctor_component *comp_head, *comp_tail;
gfc_structure_ctor_component *comp_iter;
gfc_constructor *ctor_head, *ctor_tail;
gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
--- 1984,2086 ----
gfc_free_expr (comp->val);
}
!
! /* Translate the component list into the actual constructor by sorting it in
! the order required; this also checks along the way that each and every
! component actually has an initializer and handles default initializers
! for components without explicit value given. */
! static try
! build_actual_constructor (gfc_structure_ctor_component **comp_head,
! gfc_constructor **ctor_head, gfc_symbol *sym)
{
gfc_structure_ctor_component *comp_iter;
+ gfc_constructor *ctor_tail = NULL;
+ gfc_component *comp;
+
+ for (comp = sym->components; comp; comp = comp->next)
+ {
+ gfc_structure_ctor_component **next_ptr;
+ gfc_expr *value = NULL;
+
+ /* Try to find the initializer for the current component by name. */
+ next_ptr = comp_head;
+ for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
+ {
+ if (!strcmp (comp_iter->name, comp->name))
+ break;
+ next_ptr = &comp_iter->next;
+ }
+
+ /* If an extension, try building the parent derived type by building
+ a value expression for the parent derived type and calling self. */
+ if (!comp_iter && comp == sym->components && sym->attr.extension)
+ {
+ value = gfc_get_expr ();
+ value->expr_type = EXPR_STRUCTURE;
+ value->value.constructor = NULL;
+ value->ts = comp->ts;
+ value->where = gfc_current_locus;
+
+ if (build_actual_constructor (comp_head, &value->value.constructor,
+ comp->ts.derived) == FAILURE)
+ {
+ gfc_free_expr (value);
+ return FAILURE;
+ }
+ *ctor_head = ctor_tail = gfc_get_constructor ();
+ ctor_tail->expr = value;
+ continue;
+ }
+
+ /* If it was not found, try the default initializer if there's any;
+ otherwise, it's an error. */
+ if (!comp_iter)
+ {
+ if (comp->initializer)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with missing optional arguments"
+ " at %C") == FAILURE)
+ return FAILURE;
+ value = gfc_copy_expr (comp->initializer);
+ }
+ else
+ {
+ gfc_error ("No initializer for component '%s' given in the"
+ " structure constructor at %C!", comp->name);
+ return FAILURE;
+ }
+ }
+ else
+ value = comp_iter->val;
+
+ /* Add the value to the constructor chain built. */
+ if (ctor_tail)
+ {
+ ctor_tail->next = gfc_get_constructor ();
+ ctor_tail = ctor_tail->next;
+ }
+ else
+ *ctor_head = ctor_tail = gfc_get_constructor ();
+ gcc_assert (value);
+ ctor_tail->expr = value;
+
+ /* Remove the entry from the component list. We don't want the expression
+ value to be free'd, so set it to NULL. */
+ if (comp_iter)
+ {
+ *next_ptr = comp_iter->next;
+ comp_iter->val = NULL;
+ gfc_free_structure_ctor_component (comp_iter);
+ }
+ }
+ return SUCCESS;
+ }
+
+ match
+ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, bool parent)
+ {
+ gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
gfc_constructor *ctor_head, *ctor_tail;
gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
*************** gfc_match_structure_constructor (gfc_sym
*** 1996,2005 ****
match m;
const char* last_name = NULL;
! comp_head = comp_tail = NULL;
ctor_head = ctor_tail = NULL;
! if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
where = gfc_current_locus;
--- 2088,2097 ----
match m;
const char* last_name = NULL;
! comp_tail = comp_head = NULL;
ctor_head = ctor_tail = NULL;
! if (!parent && gfc_match_char ('(') != MATCH_YES)
goto syntax;
where = gfc_current_locus;
*************** gfc_match_structure_constructor (gfc_sym
*** 2047,2053 ****
if (last_name)
gfc_error ("Component initializer without name after"
" component named %s at %C!", last_name);
! else
gfc_error ("Too many components in structure constructor at"
" %C!");
goto cleanup;
--- 2139,2145 ----
if (last_name)
gfc_error ("Component initializer without name after"
" component named %s at %C!", last_name);
! else if (!parent)
gfc_error ("Too many components in structure constructor at"
" %C!");
goto cleanup;
*************** gfc_match_structure_constructor (gfc_sym
*** 2057,2095 ****
strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
}
! /* Find the current component in the structure definition; this is
! needed to get its access attribute in the private check below. */
if (comp)
! this_comp = comp;
else
{
! for (comp = sym->components; comp; comp = comp->next)
! if (!strcmp (comp->name, comp_tail->name))
! {
! this_comp = comp;
! break;
! }
comp = NULL; /* Reset needed! */
-
- /* Here we can check if a component name is given which does not
- correspond to any component of the defined structure. */
- if (!this_comp)
- {
- gfc_error ("Component '%s' in structure constructor at %C"
- " does not correspond to any component in the"
- " constructed structure!", comp_tail->name);
- goto cleanup;
- }
}
- gcc_assert (this_comp);
! /* Check the current component's access status. */
! if (sym->attr.use_assoc && this_comp->access == ACCESS_PRIVATE)
! {
! gfc_error ("Component '%s' is PRIVATE in structure constructor"
! " at %C!", comp_tail->name);
! goto cleanup;
! }
/* Check if this component is already given a value. */
for (comp_iter = comp_head; comp_iter != comp_tail;
--- 2149,2168 ----
strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
}
! /* Find the current component in the structure definition and check its
! access is not private. */
if (comp)
! this_comp = gfc_find_component (sym, comp->name);
else
{
! this_comp = gfc_find_component (sym, (const char *)comp_tail->name);
comp = NULL; /* Reset needed! */
}
! /* Here we can check if a component name is given which does not
! correspond to any component of the defined structure. */
! if (!this_comp)
! goto cleanup;
/* Check if this component is already given a value. */
for (comp_iter = comp_head; comp_iter != comp_tail;
*************** gfc_match_structure_constructor (gfc_sym
*** 2111,2195 ****
if (m == MATCH_ERROR)
goto cleanup;
! if (comp)
! comp = comp->next;
! }
! while (gfc_match_char (',') == MATCH_YES);
!
! if (gfc_match_char (')') != MATCH_YES)
! goto syntax;
!
! /* If there were components given and all components are private, error
! out at this place. */
! if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
! {
! gfc_error ("All components of '%s' are PRIVATE in structure"
! " constructor at %C", sym->name);
! goto cleanup;
! }
! }
! /* Translate the component list into the actual constructor by sorting it in
! the order required; this also checks along the way that each and every
! component actually has an initializer and handles default initializers
! for components without explicit value given. */
! for (comp = sym->components; comp; comp = comp->next)
! {
! gfc_structure_ctor_component **next_ptr;
! gfc_expr *value = NULL;
! /* Try to find the initializer for the current component by name. */
! next_ptr = &comp_head;
! for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
! {
! if (!strcmp (comp_iter->name, comp->name))
break;
- next_ptr = &comp_iter->next;
- }
-
- /* If it was not found, try the default initializer if there's any;
- otherwise, it's an error. */
- if (!comp_iter)
- {
- if (comp->initializer)
- {
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
- " constructor with missing optional arguments"
- " at %C") == FAILURE)
- goto cleanup;
- value = gfc_copy_expr (comp->initializer);
- }
- else
- {
- gfc_error ("No initializer for component '%s' given in the"
- " structure constructor at %C!", comp->name);
- goto cleanup;
- }
}
- else
- value = comp_iter->val;
! /* Add the value to the constructor chain built. */
! if (ctor_tail)
! {
! ctor_tail->next = gfc_get_constructor ();
! ctor_tail = ctor_tail->next;
! }
! else
! ctor_head = ctor_tail = gfc_get_constructor ();
! gcc_assert (value);
! ctor_tail->expr = value;
! /* Remove the entry from the component list. We don't want the expression
! value to be free'd, so set it to NULL. */
! if (comp_iter)
! {
! *next_ptr = comp_iter->next;
! comp_iter->val = NULL;
! gfc_free_structure_ctor_component (comp_iter);
! }
}
/* No component should be left, as this should have caused an error in the
loop constructing the component-list (name that does not correspond to any
component in the structure definition). */
--- 2184,2224 ----
if (m == MATCH_ERROR)
goto cleanup;
! /* If not explicitly a parent constructor, gather up the components
! and build one. */
! if (comp && comp == sym->components
! && sym->attr.extension
! && (comp_tail->val->ts.type != BT_DERIVED
! ||
! comp_tail->val->ts.derived != this_comp->ts.derived))
! {
! gfc_current_locus = where;
! gfc_free_expr (comp_tail->val);
!
! m = gfc_match_structure_constructor (comp->ts.derived,
! &comp_tail->val, true);
! if (m == MATCH_NO)
! goto syntax;
! if (m == MATCH_ERROR)
! goto cleanup;
! }
! if (comp)
! comp = comp->next;
! if (parent && !comp)
break;
}
! while (gfc_match_char (',') == MATCH_YES);
! if (!parent && gfc_match_char (')') != MATCH_YES)
! goto syntax;
}
+ if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+ goto cleanup;
+
/* No component should be left, as this should have caused an error in the
loop constructing the component-list (name that does not correspond to any
component in the structure definition). */
*************** gfc_match_rvalue (gfc_expr **result)
*** 2396,2402 ****
if (sym == NULL)
m = MATCH_ERROR;
else
! m = gfc_match_structure_constructor (sym, &e);
break;
/* If we're here, then the name is known to be the name of a
--- 2425,2431 ----
if (sym == NULL)
m = MATCH_ERROR;
else
! m = gfc_match_structure_constructor (sym, &e, false);
break;
/* If we're here, then the name is known to be the name of a
Index: gcc/testsuite/gfortran.dg/extends_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/extends_1.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/extends_1.f03 (revision 0)
***************
*** 0 ****
--- 1,73 ----
+ ! { dg-do run }
+ ! A basic functional test of derived type extension.
+ !
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ !
+ module persons
+ type :: person
+ character(24) :: name = ""
+ integer :: ss = 1
+ end type person
+ end module persons
+
+ module person_education
+ use persons
+ type, extends(person) :: education
+ integer :: attainment = 0
+ character(24) :: institution = ""
+ end type education
+ end module person_education
+
+ use person_education
+ type, extends(education) :: service
+ integer :: personnel_number = 0
+ character(24) :: department = ""
+ end type service
+
+ type, extends(service) :: person_record
+ type (person_record), pointer :: supervisor => NULL ()
+ end type person_record
+
+ type(person_record), pointer :: recruit, supervisor
+
+ ! Check that references by ultimate component work
+
+ allocate (supervisor)
+ supervisor%name = "Joe Honcho"
+ supervisor%ss = 123455
+ supervisor%attainment = 100
+ supervisor%institution = "Celestial University"
+ supervisor%personnel_number = 1
+ supervisor%department = "Directorate"
+
+ recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+ 99, "Records", supervisor)
+
+ if (trim (recruit%name) /= "John Smith") call abort
+ if (recruit%name /= recruit%service%name) call abort
+ if (recruit%supervisor%ss /= 123455) call abort
+ if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+ deallocate (supervisor)
+ deallocate (recruit)
+ contains
+ function entry (name, ss, attainment, institution, &
+ personnel_number, department, supervisor) result (new_person)
+ integer :: ss, attainment, personnel_number
+ character (*) :: name, institution, department
+ type (person_record), pointer :: supervisor, new_person
+
+ allocate (new_person)
+
+ ! Check mixtures of references
+ new_person%person%name = name
+ new_person%service%education%person%ss = ss
+ new_person%service%attainment = attainment
+ new_person%education%institution = institution
+ new_person%personnel_number = personnel_number
+ new_person%service%department = department
+ new_person%supervisor => supervisor
+ end function
+ end
+
+ ! { dg-final { cleanup-modules "persons person_education" } }
Index: gcc/testsuite/gfortran.dg/extends_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/extends_2.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/extends_2.f03 (revision 0)
***************
*** 0 ****
--- 1,66 ----
+ ! { dg-do run }
+ ! A test of f95 style constructors with derived type extension.
+ !
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ !
+ module persons
+ type :: person
+ character(24) :: name = ""
+ integer :: ss = 1
+ end type person
+ end module persons
+
+ module person_education
+ use persons
+ type, extends(person) :: education
+ integer :: attainment = 0
+ character(24) :: institution = ""
+ end type education
+ end module person_education
+
+ use person_education
+ type, extends(education) :: service
+ integer :: personnel_number = 0
+ character(24) :: department = ""
+ end type service
+
+ type, extends(service) :: person_record
+ type (person_record), pointer :: supervisor => NULL ()
+ end type person_record
+
+ type(person_record), pointer :: recruit, supervisor
+
+ ! Check that simple constructor works
+ allocate (supervisor)
+ supervisor%service = service ("Joe Honcho", 123455, 100, &
+ "Celestial University", 1, &
+ "Directorate")
+
+ recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+ 99, "Records", supervisor)
+
+ if (trim (recruit%name) /= "John Smith") call abort
+ if (recruit%name /= recruit%service%name) call abort
+ if (recruit%supervisor%ss /= 123455) call abort
+ if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+ deallocate (supervisor)
+ deallocate (recruit)
+ contains
+ function entry (name, ss, attainment, institution, &
+ personnel_number, department, supervisor) result (new_person)
+ integer :: ss, attainment, personnel_number
+ character (*) :: name, institution, department
+ type (person_record), pointer :: supervisor, new_person
+
+ allocate (new_person)
+
+ ! Check nested constructors
+ new_person = person_record (education (person (name, ss), &
+ attainment, institution), &
+ personnel_number, department, &
+ supervisor)
+ end function
+ end
+
+ ! { dg-final { cleanup-modules "persons person_education" } }
Index: gcc/testsuite/gfortran.dg/extends_3.f03
===================================================================
*** gcc/testsuite/gfortran.dg/extends_3.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/extends_3.f03 (revision 0)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-do run }
+ ! A test of f2k style constructors with derived type extension.
+ !
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ !
+ module persons
+ type :: person
+ character(24) :: name = ""
+ integer :: ss = 1
+ end type person
+ end module persons
+
+ module person_education
+ use persons
+ type, extends(person) :: education
+ integer :: attainment = 0
+ character(24) :: institution = ""
+ end type education
+ end module person_education
+
+ use person_education
+ type, extends(education) :: service
+ integer :: personnel_number = 0
+ character(24) :: department = ""
+ end type service
+
+ type, extends(service) :: person_record
+ type (person_record), pointer :: supervisor => NULL ()
+ end type person_record
+
+ type(person_record), pointer :: recruit, supervisor
+
+ ! Check that F2K constructor with missing entries works
+ allocate (supervisor)
+ supervisor%service = service (NAME = "Joe Honcho", SS= 123455)
+
+ recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+ 99, "Records", supervisor)
+
+ if (supervisor%ss /= 123455) call abort
+ if (trim (supervisor%name) /= "Joe Honcho") call abort
+ if (trim (supervisor%institution) /= "") call abort
+ if (supervisor%attainment /= 0) call abort
+
+ if (trim (recruit%name) /= "John Smith") call abort
+ if (recruit%name /= recruit%service%name) call abort
+ if (recruit%supervisor%ss /= 123455) call abort
+ if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+ deallocate (supervisor)
+ deallocate (recruit)
+ contains
+ function entry (name, ss, attainment, institution, &
+ personnel_number, department, supervisor) result (new_person)
+ integer :: ss, attainment, personnel_number
+ character (*) :: name, institution, department
+ type (person_record), pointer :: supervisor, new_person
+
+ allocate (new_person)
+
+ ! Check F2K constructor with order shuffled a bit
+ new_person = person_record (NAME = name, SS =ss, &
+ DEPARTMENT = department, &
+ INSTITUTION = institution, &
+ PERSONNEL_NUMBER = personnel_number, &
+ ATTAINMENT = attainment, &
+ SUPERVISOR = supervisor)
+ end function
+ end
+
+ ! { dg-final { cleanup-modules "persons person_education" } }
Index: gcc/testsuite/gfortran.dg/private_type_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/private_type_6.f90 (revision 138162)
--- gcc/testsuite/gfortran.dg/private_type_6.f90 (working copy)
*************** program foo_test
*** 19,25 ****
TYPE(footype) :: foo
TYPE(bartype) :: foo2
foo = footype(1) ! { dg-error "All components of 'footype' are PRIVATE" }
! foo2 = bartype(1,2) ! { dg-error "'dummy2' is PRIVATE" }
foo2%dummy2 = 5 ! { dg-error "is a PRIVATE component" }
end program foo_test
! { dg-final { cleanup-modules "foomod" } }
--- 19,25 ----
TYPE(footype) :: foo
TYPE(bartype) :: foo2
foo = footype(1) ! { dg-error "All components of 'footype' are PRIVATE" }
! foo2 = bartype(1,2) ! { dg-error "is a PRIVATE component" }
foo2%dummy2 = 5 ! { dg-error "is a PRIVATE component" }
end program foo_test
! { dg-final { cleanup-modules "foomod" } }
Index: gcc/testsuite/gfortran.dg/structure_constructor_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/structure_constructor_7.f03 (revision 138162)
--- gcc/testsuite/gfortran.dg/structure_constructor_7.f03 (working copy)
*************** PROGRAM test
*** 13,18 ****
TYPE(basics_t) :: basics
basics = basics_t (42, 1.5, 1000) ! { dg-error "Too many components" }
! basics = basics_t (42, xxx = 1000) ! { dg-error "Component 'xxx'" }
END PROGRAM test
--- 13,18 ----
TYPE(basics_t) :: basics
basics = basics_t (42, 1.5, 1000) ! { dg-error "Too many components" }
! basics = basics_t (42, xxx = 1000) ! { dg-error "is not a member" }
END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_8.f03
===================================================================
*** gcc/testsuite/gfortran.dg/structure_constructor_8.f03 (revision 138162)
--- gcc/testsuite/gfortran.dg/structure_constructor_8.f03 (working copy)
*************** PROGRAM test
*** 47,54 ****
struct2 = allpriv_t ()
! These should fail
! struct1 = haspriv_t (1, 2) ! { dg-error "'b' is PRIVATE" }
! struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "'b' is PRIVATE" }
! This should fail as all components are private
struct2 = allpriv_t (5) ! { dg-error "of 'allpriv_t' are PRIVATE" }
--- 47,54 ----
struct2 = allpriv_t ()
! These should fail
! struct1 = haspriv_t (1, 2) ! { dg-error "is a PRIVATE component" }
! struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "is a PRIVATE component" }
! This should fail as all components are private
struct2 = allpriv_t (5) ! { dg-error "of 'allpriv_t' are PRIVATE" }