From: Paul Thomas Date: Tue, 29 Jul 2008 20:44:09 +0000 (+0000) Subject: trans-expr.c (conv_parent_component_references): New function to build missing parent... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7d1f1e6144bab4e9e2fadc324c5213b415efb952;p=gcc.git trans-expr.c (conv_parent_component_references): New function to build missing parent references. 2008-07-29 Paul Thomas fortran/ * 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. If extension and components left over, throw error. (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. testsuite/ * gfortran.dg/extends_1.f03: New test. * gfortran.dg/extends_2.f03: New test. * gfortran.dg/extends_3.f03: New test. * gfortran.dg/extends_4.f03: New test. * gfortran.dg/extends_5.f03: New test. * gfortran.dg/extends_6.f03: 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. From-SVN: r138275 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 872678d6e3a..e8ce99b4461 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,42 @@ +2008-07-29 Paul Thomas + + * 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. If extension + and components left over, throw error. + (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-29 Jan Hubicka * options.c (gfc_post_options): Do not set flag_no_inline. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 9b1e5853b1d..8b9b8c0e868 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -367,7 +367,7 @@ match_data_constant (gfc_expr **result) return MATCH_ERROR; } else if (sym->attr.flavor == FL_DERIVED) - return gfc_match_structure_constructor (sym, result); + 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) @@ -6250,6 +6250,49 @@ syntax: } +/* 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 @@ -6257,7 +6300,7 @@ syntax: checking on attribute conflicts needs to be done. */ match -gfc_get_type_attr_spec (symbol_attribute *attr) +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) @@ -6295,6 +6338,12 @@ gfc_get_type_attr_spec (symbol_attribute *attr) /* 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; @@ -6311,8 +6360,10 @@ match 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; @@ -6320,17 +6371,27 @@ gfc_match_derived_decl (void) 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); + 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"); @@ -6383,10 +6444,34 @@ gfc_match_derived_decl (void) 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; return MATCH_YES; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 72cd871acc2..51192481326 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -638,6 +638,7 @@ typedef struct 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 @@ -1016,9 +1017,6 @@ typedef struct gfc_symbol 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 */ diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index cc51072dff4..9c9d206822c 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -182,10 +182,10 @@ gfc_try get_bind_c_idents (void); 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 *); +match gfc_get_type_attr_spec (symbol_attribute *, char*); /* primary.c. */ -match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **); +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 **); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index a418bb9d9a4..ed575f9574f 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1648,7 +1648,8 @@ typedef enum 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_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, + AB_EXTENSION } ab_attribute; @@ -1688,6 +1689,7 @@ static const mstring attr_bits[] = minit ("ZERO_COMP", AB_ZERO_COMP), minit ("PROTECTED", AB_PROTECTED), minit ("ABSTRACT", AB_ABSTRACT), + minit ("EXTENSION", AB_EXTENSION), minit (NULL, -1) }; @@ -1801,6 +1803,8 @@ mio_symbol_attribute (symbol_attribute *attr) 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 (); @@ -1919,6 +1923,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_ZERO_COMP: attr->zero_comp = 1; break; + case AB_EXTENSION: + attr->extension = 1; + break; } } } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 782f38e4425..dfea043d6e3 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1984,11 +1984,103 @@ gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp) gfc_free_expr (comp->val); } -match -gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) + +/* 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 gfc_try +build_actual_constructor (gfc_structure_ctor_component **comp_head, + gfc_constructor **ctor_head, gfc_symbol *sym) { - gfc_structure_ctor_component *comp_head, *comp_tail; 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; @@ -1996,10 +2088,10 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) match m; const char* last_name = NULL; - comp_head = comp_tail = NULL; + comp_tail = comp_head = NULL; ctor_head = ctor_tail = NULL; - if (gfc_match_char ('(') != MATCH_YES) + if (!parent && gfc_match_char ('(') != MATCH_YES) goto syntax; where = gfc_current_locus; @@ -2047,7 +2139,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) if (last_name) gfc_error ("Component initializer without name after" " component named %s at %C!", last_name); - else + else if (!parent) gfc_error ("Too many components in structure constructor at" " %C!"); goto cleanup; @@ -2057,39 +2149,20 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) 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. */ + /* Find the current component in the structure definition and check its + access is not private. */ if (comp) - this_comp = comp; + this_comp = gfc_find_component (sym, comp->name); else { - for (comp = sym->components; comp; comp = comp->next) - if (!strcmp (comp->name, comp_tail->name)) - { - this_comp = comp; - break; - } + 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) - { - 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; - } + /* 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; @@ -2111,89 +2184,56 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) if (m == MATCH_ERROR) goto cleanup; - if (comp) - comp = comp->next; - } - while (gfc_match_char (',') == MATCH_YES); + /* 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); - 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; - } - } + m = gfc_match_structure_constructor (comp->ts.derived, + &comp_tail->val, true); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + 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; + if (comp) + comp = comp->next; - /* 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)) + if (parent && !comp) 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; + while (gfc_match_char (',') == MATCH_YES); - /* 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); - } + 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). */ - gcc_assert (!comp_head); + if (comp_head && sym->attr.extension) + { + for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next) + { + gfc_error ("component '%s' at %L has already been set by a " + "parent derived type constructor", comp_iter->name, + &comp_iter->where); + } + goto cleanup; + } + else + gcc_assert (!comp_head); e = gfc_get_expr (); @@ -2396,7 +2436,7 @@ gfc_match_rvalue (gfc_expr **result) if (sym == NULL) m = MATCH_ERROR; else - m = gfc_match_structure_constructor (sym, &e); + m = gfc_match_structure_constructor (sym, &e, false); break; /* If we're here, then the name is known to be the name of a diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 58c54f4d42b..d4cbd0b6684 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1701,6 +1701,14 @@ gfc_add_component (gfc_symbol *sym, const char *name, 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 (); @@ -1830,17 +1838,36 @@ gfc_find_component (gfc_symbol *sym, const char *name) 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 + + else if (sym->attr.use_assoc) { - if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE - || p->access == ACCESS_PRIVATE)) + if (p->access == ACCESS_PRIVATE) { gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'", name, sym->name); - p = NULL; + 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; } } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index fe6b63de90b..6c6845daf4e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3257,14 +3257,16 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, if (ss->type != GFC_SS_SECTION) continue; - if (gfc_could_be_alias (dest, ss) - || gfc_are_equivalenced_arrays (dest->expr, ss->expr)) + if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym) { - nDepend = 1; - break; + 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) + else { lref = dest->expr->ref; rref = ss->expr->ref; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 05ee3902e34..94b912f6d4c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,6 +1,6 @@ /* Expression translation - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software - Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -395,6 +395,40 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) } +/* 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). */ @@ -561,6 +595,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_COMPONENT: + if (ref->u.c.sym->attr.extension) + conv_parent_component_references (se, ref); + gfc_conv_component_ref (se, ref); break; diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index e304d1687bf..6d63ecdf742 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1,6 +1,6 @@ /* IO Code translation/library interface - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software - Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Free Software Foundation, Inc. Contributed by Paul Brook This file is part of GCC. diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 79568ddab39..5836949f3ee 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2008-07-29 Paul Thomas + + * gfortran.dg/extends_1.f03: New test. + * gfortran.dg/extends_2.f03: New test. + * gfortran.dg/extends_3.f03: New test. + * gfortran.dg/extends_4.f03: New test. + * gfortran.dg/extends_5.f03: New test. + * gfortran.dg/extends_6.f03: 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. + 2008-07-29 Richard Guenther PR tree-optimization/36945 diff --git a/gcc/testsuite/gfortran.dg/extends_1.f03 b/gcc/testsuite/gfortran.dg/extends_1.f03 new file mode 100644 index 00000000000..57a50732c55 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_1.f03 @@ -0,0 +1,73 @@ +! { dg-do run } +! A basic functional test of derived type extension. +! +! Contributed by Paul Thomas +! +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" } } diff --git a/gcc/testsuite/gfortran.dg/extends_2.f03 b/gcc/testsuite/gfortran.dg/extends_2.f03 new file mode 100644 index 00000000000..aabbf662a4f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_2.f03 @@ -0,0 +1,66 @@ +! { dg-do run } +! A test of f95 style constructors with derived type extension. +! +! Contributed by Paul Thomas +! +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" } } diff --git a/gcc/testsuite/gfortran.dg/extends_3.f03 b/gcc/testsuite/gfortran.dg/extends_3.f03 new file mode 100644 index 00000000000..27ae670d95f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_3.f03 @@ -0,0 +1,71 @@ +! { dg-do run } +! A test of f2k style constructors with derived type extension. +! +! Contributed by Paul Thomas +! +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" } } diff --git a/gcc/testsuite/gfortran.dg/extends_4.f03 b/gcc/testsuite/gfortran.dg/extends_4.f03 new file mode 100644 index 00000000000..941a6639213 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_4.f03 @@ -0,0 +1,52 @@ +! { dg-do run } +! Check that derived type extension is compatible with renaming +! the parent type and that allocatable components are OK. At +! the same time, private type and components are checked. +! +! Contributed by Paul Thomas +! +module mymod + type :: a + real, allocatable :: x(:) + integer, private :: ia = 0 + end type a + type :: b + private + real, allocatable :: x(:) + integer :: i + end type b +contains + function set_b () result (res) + type(b) :: res + allocate (res%x(2)) + res%x = [10.0, 20.0] + res%i = 1 + end function + subroutine check_b (arg) + type(b) :: arg + if (any (arg%x /= [10.0, 20.0])) call abort + if (arg%i /= 1) call abort + end subroutine +end module mymod + + use mymod, e => a + type, extends(e) :: f + integer :: if + end type f + type, extends(b) :: d + integer :: id + end type d + + type(f) :: p + type(d) :: q + + p = f (x = [1.0, 2.0], if = 3) + if (any (p%e%x /= [1.0, 2.0])) call abort + + q%b = set_b () + call check_b (q%b) + q = d (b = set_b (), id = 99) + call check_b (q%b) +end + +! { dg-final { cleanup-modules "persons person_education" } } diff --git a/gcc/testsuite/gfortran.dg/extends_5.f03 b/gcc/testsuite/gfortran.dg/extends_5.f03 new file mode 100644 index 00000000000..5146d456355 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_5.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! Some errors for derived type extension. +! +! Contributed by Paul Thomas +! +module m + use iso_c_binding + type :: date + sequence + integer :: yr, mon + integer,public :: day + end type + type, bind(c) :: dt + integer(c_int) :: yr, mon + integer(c_int) :: day + end type +end module m + + use m + type, extends(date) :: datetime ! { dg-error "because it is a SEQUENCE type" } + end type ! { dg-error "Expecting END PROGRAM" } + + type, extends(dt) :: dt_type ! { dg-error "because it is BIND" } + end type ! { dg-error "Expecting END PROGRAM" } +end + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/extends_6.f03 b/gcc/testsuite/gfortran.dg/extends_6.f03 new file mode 100644 index 00000000000..866fbbd1c50 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_6.f03 @@ -0,0 +1,49 @@ +! { dg-do compile } +! Some errors pointed out in the development of the patch. +! +! Contributed by Tobias Burnus +! +module m + type :: date + private + integer :: yr, mon + integer,public :: day + end type + type :: dt + integer :: yr, mon + integer :: day + end type +end module m + + use m + type, extends(date) :: datetime + integer :: hr, min, sec + end type + type(datetime) :: o_dt + + type :: one + integer :: i + end type one + + type, extends(one) :: two + real :: r + end type two + + o_dt%day = 5 ! VALID but failed in first version of EXTENDS patch + o_dt%yr = 5 ! { dg-error "All components of 'date' are PRIVATE" } + + t = two(one = one(4), i = 5, r=4.4) ! { dg-error "has already been set" } + + call foo +contains + subroutine foo + use m, date_type => dt + type, extends(date_type) :: dt_type + end type + type (dt_type) :: foo_dt + foo_dt%date_type%day = 1 + foo_dt%dt%day = 1 ! { dg-error "not a member" } + end subroutine +end + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/private_type_6.f90 b/gcc/testsuite/gfortran.dg/private_type_6.f90 index d3cc809dfef..5e13ed53477 100644 --- a/gcc/testsuite/gfortran.dg/private_type_6.f90 +++ b/gcc/testsuite/gfortran.dg/private_type_6.f90 @@ -19,7 +19,7 @@ program foo_test 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 = 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" } } diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_7.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_7.f03 index 3ba79ea373b..5388e8805eb 100644 --- a/gcc/testsuite/gfortran.dg/structure_constructor_7.f03 +++ b/gcc/testsuite/gfortran.dg/structure_constructor_7.f03 @@ -13,6 +13,6 @@ PROGRAM test 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'" } + basics = basics_t (42, xxx = 1000) ! { dg-error "is not a member" } END PROGRAM test diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 index 4b0bce779db..520b52853d5 100644 --- a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 +++ b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 @@ -47,8 +47,8 @@ PROGRAM test 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" } + 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" }