diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 102 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 179 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 4 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/match.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 116 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 339 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 116 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 254 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 11 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 44 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 1 |
17 files changed, 894 insertions, 322 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 01abd74f890..393f2a05076 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,105 @@ +2011-11-28 Tobias Burnus <burnus@net-b.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/51308 + * symbol.c (check_conflict): Ignore BIND(C) + PARAMETER + conflicts for ISO_C_BINDING variables. + (gen_special_c_interop_ptr): Don't mark c_ptr_null/c_funptr_null + as SAVE. + +2011-11-25 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (set_loop_bounds): Remove dead conditions. + +2011-11-25 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/51250 + PR fortran/43829 + * trans-array.c (gfc_trans_create_temp_array): Get dimension from + the right gfc_ss struct. + +2011-11-25 Tobias Burnus <burnus@net-b.de> + + PR fortran/50408 + * trans-decl.c (gfc_get_module_backend_decl): Also copy + ts.u.derived from the gsym if the ts.type is BT_CLASS. + (gfc_get_extern_function_decl): Copy also the backend_decl + for the symbol's ts.u.{derived,cl} from the gsym. + * trans-types.c (gfc_copy_dt_decls_ifequal): Directly + return if "from" and "to" are the same. + +2011-11-25 Tobias Burnus <burnus@net-b.de> + + PR fortran/51302 + * trans-stmt.c (gfc_trans_simple_do): Add a fold_convert. + +2011-11-24 Tobias Burnus <burnus@net-b.de> + + PR fortran/51218 + * resolve.c (pure_subroutine): If called subroutine is + impure, unset implicit_pure. + (resolve_function): Move impure check to simplify code. + +2011-11-19 Tobias Burnus <burnus@net-b.de> + + PR fortran/51207 + * class.c (gfc_find_derived_vtab): Mark __def_init as PARAMETER + and hence as TREE_READONLY; add subroutine attribute to + __copy_ procedure. + + PR fortran/50640 + * trans.h (GFC_DECL_PUSH_TOPLEVEL): New DECL_LANG_FLAG_7. + * trans-decl.c (gfc_get_symbol_decl): Mark __def_init and vtab as + GFC_DECL_PUSH_TOPLEVEL. + (gfc_generate_function_code): If GFC_DECL_PUSH_TOPLEVEL, push it there. + (build_function_decl): Push __copy_ procedure to the toplevel. + +2011-11-16 Tobias Burnus <burnus@net-b.de> + + PR fortran/39427 + PR fortran/37829 + * decl.c (match_data_constant, match_data_constant, variable_decl, + gfc_match_decl_type_spec, access_attr_decl, + check_extended_derived_type, gfc_match_derived_decl, + gfc_match_derived_decl, gfc_match_derived_decl) Modified to deal + with DT constructors. + * gfortran.h (gfc_find_dt_in_generic, + gfc_convert_to_structure_constructor): New function prototypes. + * interface.c (check_interface0, check_interface1, + gfc_search_interface): Ignore DT constructors in generic list. + * match.h (gfc_match_structure_constructor): Update prototype. + * match.c (match_derived_type_spec): Ensure that one uses the DT + not the generic function. + * module.c (MOD_VERSION): Bump. + (dt_lower_string, dt_upper_string): New functions. + (find_use_name_n, find_use_operator, compare_true_names, + find_true_name, add_true_name, fix_mio_expr, load_needed, + read_module, write_dt_extensions, write_symbol): Changes to deal with + different symtree vs. sym names. + (create_derived_type): Create also generic procedure. + * parse.c (gfc_fixup_sibling_symbols): Don't regard DT and generic + function as the same. + * primary.c (gfc_convert_to_structure_constructor): New function. + (gfc_match_structure_constructor): Restructured; calls + gfc_convert_to_structure_constructor. + (build_actual_constructor, gfc_match_rvalue): Update for DT generic + functions. + * resolve.c (resolve_formal_arglist, resolve_structure_cons, + is_illegal_recursion, resolve_generic_f, resolve_variable, + resolve_fl_variable_derived, resolve_fl_derived0, + resolve_symbol): Handle DT and DT generic constructors. + * symbol.c (gfc_use_derived, gfc_undo_symbols, + gen_special_c_interop_ptr, gen_cptr_param, + generate_isocbinding_symbol, gfc_get_derived_super_type): Handle + derived-types, which are hidden in the generic type. + (gfc_find_dt_in_generic): New function + * trans-array.c (gfc_conv_array_initializer): Replace FL_PARAMETER + expr by actual value. + * trans-decl.c (gfc_get_module_backend_decl, gfc_trans_use_stmts): + Ensure that we use the DT and not the generic function. + * trans-types.c (gfc_get_derived_type): Ensure that we use the DT + and not the generic procedure. + 2011-11-14 Tobias Burnus <burnus@net-b.de> PR fortran/51073 diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index dc76ad158bb..bcb2d0b76bc 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -522,7 +522,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) def_init->attr.target = 1; def_init->attr.save = SAVE_IMPLICIT; def_init->attr.access = ACCESS_PUBLIC; - def_init->attr.flavor = FL_VARIABLE; + def_init->attr.flavor = FL_PARAMETER; gfc_set_sym_referenced (def_init); def_init->ts.type = BT_DERIVED; def_init->ts.u.derived = derived; @@ -552,6 +552,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) gfc_get_symbol (name, sub_ns, ©); sub_ns->proc_name = copy; copy->attr.flavor = FL_PROCEDURE; + copy->attr.subroutine = 1; copy->attr.if_source = IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) copy->module = ns->proc_name->name; diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 2dd38b9485e..3e553a38143 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -323,7 +323,7 @@ static match match_data_constant (gfc_expr **result) { char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym = NULL; gfc_expr *expr; match m; locus old_loc; @@ -366,15 +366,19 @@ match_data_constant (gfc_expr **result) if (gfc_find_symbol (name, NULL, 1, &sym)) return MATCH_ERROR; + if (sym && sym->attr.generic) + dt_sym = gfc_find_dt_in_generic (sym); + if (sym == NULL - || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED)) + || (sym->attr.flavor != FL_PARAMETER + && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED))) { gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C", name); return MATCH_ERROR; } - else if (sym->attr.flavor == FL_DERIVED) - return gfc_match_structure_constructor (sym, result, false); + else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED) + return gfc_match_structure_constructor (dt_sym, result); /* Check to see if the value is an initialization array expression. */ if (sym->value->expr_type == EXPR_ARRAY) @@ -1954,10 +1958,10 @@ variable_decl (int elem) st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name); if (!(current_ts.u.derived->attr.imported && st != NULL - && st->n.sym == current_ts.u.derived) + && gfc_find_dt_in_generic (st->n.sym) == current_ts.u.derived) && !gfc_current_ns->has_import_set) { - gfc_error ("the type of '%s' at %C has not been declared within the " + gfc_error ("The type of '%s' at %C has not been declared within the " "interface", name); m = MATCH_ERROR; goto cleanup; @@ -2501,10 +2505,11 @@ match gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) { char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym; match m; char c; bool seen_deferred_kind, matched_type; + const char *dt_name; /* A belt and braces check that the typespec is correctly being treated as a deferred characteristic association. */ @@ -2668,40 +2673,96 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) ts->u.derived = NULL; if (gfc_current_state () != COMP_INTERFACE && !gfc_find_symbol (name, NULL, 1, &sym) && sym) - ts->u.derived = sym; + { + sym = gfc_find_dt_in_generic (sym); + ts->u.derived = sym; + } return MATCH_YES; } /* Search for the name but allow the components to be defined later. If type = -1, this typespec has been seen in a function declaration but - the type could not be accessed at that point. */ + the type could not be accessed at that point. The actual derived type is + stored in a symtree with the first letter of the name captialized; the + symtree with the all lower-case name contains the associated + generic function. */ + dt_name = gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) name[0]), + (const char*)&name[1]); sym = NULL; - if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym)) + dt_sym = NULL; + if (ts->kind != -1) { - gfc_error ("Type name '%s' at %C is ambiguous", name); - return MATCH_ERROR; + gfc_get_ha_symbol (name, &sym); + if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) + { + gfc_error ("Type name '%s' at %C is ambiguous", name); + return MATCH_ERROR; + } + if (sym->generic && !dt_sym) + dt_sym = gfc_find_dt_in_generic (sym); } else if (ts->kind == -1) { int iface = gfc_state_stack->previous->state != COMP_INTERFACE || gfc_current_ns->has_import_set; - if (gfc_find_symbol (name, NULL, iface, &sym)) + gfc_find_symbol (name, NULL, iface, &sym); + if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) { gfc_error ("Type name '%s' at %C is ambiguous", name); return MATCH_ERROR; } + if (sym && sym->generic && !dt_sym) + dt_sym = gfc_find_dt_in_generic (sym); ts->kind = 0; if (sym == NULL) return MATCH_NO; } - if (sym->attr.flavor != FL_DERIVED - && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) - return MATCH_ERROR; + if ((sym->attr.flavor != FL_UNKNOWN + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) + || sym->attr.subroutine) + { + gfc_error ("Type name '%s' at %C conflicts with previously declared " + "entity at %L, which has the same name", name, + &sym->declared_at); + return MATCH_ERROR; + } gfc_set_sym_referenced (sym); - ts->u.derived = sym; + if (!sym->attr.generic + && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE) + return MATCH_ERROR; + + if (!sym->attr.function + && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) + return MATCH_ERROR; + + if (!dt_sym) + { + gfc_interface *intr, *head; + + /* Use upper case to save the actual derived-type symbol. */ + gfc_get_symbol (dt_name, NULL, &dt_sym); + dt_sym->name = gfc_get_string (sym->name); + head = sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + sym->generic = intr; + sym->attr.if_source = IFSRC_DECL; + } + + gfc_set_sym_referenced (dt_sym); + + if (dt_sym->attr.flavor != FL_DERIVED + && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL) + == FAILURE) + return MATCH_ERROR; + + ts->u.derived = dt_sym; return MATCH_YES; @@ -3053,6 +3114,20 @@ gfc_match_import (void) sym->refs++; sym->attr.imported = 1; + if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) + { + /* The actual derived type is stored in a symtree with the first + letter of the name captialized; the symtree with the all + lower-case name contains the associated generic function. */ + st = gfc_new_symtree (&gfc_current_ns->sym_root, + gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) sym->name[0]), + &sym->name[1])); + st->n.sym = sym; + sym->refs++; + sym->attr.imported = 1; + } + goto next_item; case MATCH_NO: @@ -6475,7 +6550,7 @@ access_attr_decl (gfc_statement st) char name[GFC_MAX_SYMBOL_LEN + 1]; interface_type type; gfc_user_op *uop; - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym; gfc_intrinsic_op op; match m; @@ -6505,6 +6580,13 @@ access_attr_decl (gfc_statement st) sym->name, NULL) == FAILURE) return MATCH_ERROR; + if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym)) + && gfc_add_access (&dt_sym->attr, + (st == ST_PUBLIC) ? ACCESS_PUBLIC + : ACCESS_PRIVATE, + sym->name, NULL) == FAILURE) + return MATCH_ERROR; + break; case INTERFACE_INTRINSIC_OP: @@ -7175,6 +7257,8 @@ check_extended_derived_type (char *name) return NULL; } + extended = gfc_find_dt_in_generic (extended); + if (extended->attr.flavor != FL_DERIVED) { gfc_error ("'%s' in EXTENDS expression at %C is not a " @@ -7277,11 +7361,12 @@ 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 *sym, *gensym; gfc_symbol *extended; match m; match is_type_attr_spec = MATCH_NO; bool seen_attr = false; + gfc_interface *intr = NULL, *head; if (gfc_current_state () == COMP_DERIVED) return MATCH_NO; @@ -7327,16 +7412,50 @@ gfc_match_derived_decl (void) return MATCH_ERROR; } - if (gfc_get_symbol (name, NULL, &sym)) + if (gfc_get_symbol (name, NULL, &gensym)) return MATCH_ERROR; - if (sym->ts.type != BT_UNKNOWN) + if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) { gfc_error ("Derived type name '%s' at %C already has a basic type " - "of %s", sym->name, gfc_typename (&sym->ts)); + "of %s", gensym->name, gfc_typename (&gensym->ts)); + return MATCH_ERROR; + } + + if (!gensym->attr.generic + && gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE) + return MATCH_ERROR; + + if (!gensym->attr.function + && gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE) + return MATCH_ERROR; + + sym = gfc_find_dt_in_generic (gensym); + + if (sym && (sym->components != NULL || sym->attr.zero_comp)) + { + gfc_error ("Derived type definition of '%s' at %C has already been " + "defined", sym->name); return MATCH_ERROR; } + if (!sym) + { + /* Use upper case to save the actual derived-type symbol. */ + gfc_get_symbol (gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) gensym->name[0]), + &gensym->name[1]), NULL, &sym); + sym->name = gfc_get_string (gensym->name); + head = gensym->generic; + intr = gfc_get_interface (); + intr->sym = sym; + intr->where = gfc_current_locus; + intr->sym->declared_at = gfc_current_locus; + intr->next = head; + gensym->generic = intr; + gensym->attr.if_source = IFSRC_DECL; + } + /* The symbol may already have the derived attribute without the components. The ways this can happen is via a function definition, an INTRINSIC statement or a subtype in another @@ -7346,16 +7465,18 @@ gfc_match_derived_decl (void) && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; - if (sym->components != NULL || sym->attr.zero_comp) - { - gfc_error ("Derived type definition of '%s' at %C has already been " - "defined", sym->name); - return MATCH_ERROR; - } - if (attr.access != ACCESS_UNKNOWN && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE) return MATCH_ERROR; + else if (sym->attr.access == ACCESS_UNKNOWN + && gensym->attr.access != ACCESS_UNKNOWN + && gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL) + == FAILURE) + return MATCH_ERROR; + + if (sym->attr.access != ACCESS_UNKNOWN + && gensym->attr.access == ACCESS_UNKNOWN) + gensym->attr.access = sym->attr.access; /* See if the derived type was labeled as bind(c). */ if (attr.is_bind_c != 0) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 17ebd58e50f..372c056d3d1 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2630,6 +2630,7 @@ gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus); gfc_namespace* gfc_find_proc_namespace (gfc_namespace*); bool gfc_is_associate_pointer (gfc_symbol*); +gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *); /* intrinsic.c -- true if working in an init-expr, false otherwise. */ extern bool gfc_init_expr_flag; @@ -2874,6 +2875,9 @@ match gfc_match_rvalue (gfc_expr **); match gfc_match_varspec (gfc_expr*, int, bool, bool); int gfc_check_digit (char, int); bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *); +gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *, + gfc_expr **, + gfc_actual_arglist **, bool); /* trans.c */ void gfc_generate_code (gfc_namespace *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 90d98c759dd..6d2acce378a 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1262,8 +1262,9 @@ check_interface0 (gfc_interface *p, const char *interface_name) { /* Make sure all symbols in the interface have been defined as functions or subroutines. */ - if ((!p->sym->attr.function && !p->sym->attr.subroutine) - || !p->sym->attr.if_source) + if (((!p->sym->attr.function && !p->sym->attr.subroutine) + || !p->sym->attr.if_source) + && p->sym->attr.flavor != FL_DERIVED) { if (p->sym->attr.external) gfc_error ("Procedure '%s' in %s at %L has no explicit interface", @@ -1276,11 +1277,18 @@ check_interface0 (gfc_interface *p, const char *interface_name) } /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ - if ((psave->sym->attr.function && !p->sym->attr.function) + if ((psave->sym->attr.function && !p->sym->attr.function + && p->sym->attr.flavor != FL_DERIVED) || (psave->sym->attr.subroutine && !p->sym->attr.subroutine)) { - gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" - " or all FUNCTIONs", interface_name, &p->sym->declared_at); + if (p->sym->attr.flavor != FL_DERIVED) + gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" + " or all FUNCTIONs", interface_name, + &p->sym->declared_at); + else + gfc_error ("In %s at %L procedures must be all FUNCTIONs as the " + "generic name is also the name of a derived type", + interface_name, &p->sym->declared_at); return 1; } @@ -1336,8 +1344,10 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) continue; - if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, - 0, NULL, 0)) + if (p->sym->attr.flavor != FL_DERIVED + && q->sym->attr.flavor != FL_DERIVED + && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, + generic_flag, 0, NULL, 0)) { if (referenced) gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", @@ -3019,6 +3029,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, for (; intr; intr = intr->next) { + if (intr->sym->attr.flavor == FL_DERIVED) + continue; if (sub_flag && intr->sym->attr.function) continue; if (!sub_flag && intr->sym->attr.subroutine) diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 4ea98b61017..fbafe82cc66 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1920,6 +1920,9 @@ match_derived_type_spec (gfc_typespec *ts) gfc_find_symbol (name, NULL, 1, &derived); + if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic) + derived = gfc_find_dt_in_generic (derived); + if (derived && derived->attr.flavor == FL_DERIVED) { ts->type = BT_DERIVED; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 0d841044b98..df18074c58a 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -206,7 +206,7 @@ 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_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 **); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 62f759876d3..7c28e8bb97c 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "7" +#define MOD_VERSION "8" /* Structure that describes a position within a module file. */ @@ -429,6 +429,34 @@ resolve_fixups (fixup_t *f, void *gp) } +/* Convert a string such that it starts with a lower-case character. Used + to convert the symtree name of a derived-type to the symbol name or to + the name of the associated generic function. */ + +const char * +dt_lower_string (const char *name) +{ + if (name[0] != (char) TOLOWER ((unsigned char) name[0])) + return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]), + &name[1]); + return gfc_get_string (name); +} + + +/* Convert a string such that it starts with an upper-case character. Used to + return the symtree-name for a derived type; the symbol name itself and the + symtree/symbol name of the associated generic function start with a lower- + case character. */ + +const char * +dt_upper_string (const char *name) +{ + if (name[0] != (char) TOUPPER ((unsigned char) name[0])) + return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]), + &name[1]); + return gfc_get_string (name); +} + /* Call here during module reading when we know what pointer to associate with an integer. Any fixups that exist are resolved at this time. */ @@ -699,12 +727,18 @@ static const char * find_use_name_n (const char *name, int *inst, bool interface) { gfc_use_rename *u; + const char *low_name = NULL; int i; + /* For derived types. */ + if (name[0] != (char) TOLOWER ((unsigned char) name[0])) + low_name = dt_lower_string (name); + i = 0; for (u = gfc_rename_list; u; u = u->next) { - if (strcmp (u->use_name, name) != 0 + if ((!low_name && strcmp (u->use_name, name) != 0) + || (low_name && strcmp (u->use_name, low_name) != 0) || (u->op == INTRINSIC_USER && !interface) || (u->op != INTRINSIC_USER && interface)) continue; @@ -723,6 +757,13 @@ find_use_name_n (const char *name, int *inst, bool interface) u->found = 1; + if (low_name) + { + if (u->local_name[0] == '\0') + return name; + return dt_upper_string (u->local_name); + } + return (u->local_name[0] != '\0') ? u->local_name : name; } @@ -780,6 +821,7 @@ find_use_operator (gfc_intrinsic_op op) typedef struct true_name { BBT_HEADER (true_name); + const char *name; gfc_symbol *sym; } true_name; @@ -803,7 +845,7 @@ compare_true_names (void *_t1, void *_t2) if (c != 0) return c; - return strcmp (t1->sym->name, t2->sym->name); + return strcmp (t1->name, t2->name); } @@ -817,7 +859,7 @@ find_true_name (const char *name, const char *module) gfc_symbol sym; int c; - sym.name = gfc_get_string (name); + t.name = gfc_get_string (name); if (module != NULL) sym.module = gfc_get_string (module); else @@ -847,6 +889,10 @@ add_true_name (gfc_symbol *sym) t = XCNEW (true_name); t->sym = sym; + if (sym->attr.flavor == FL_DERIVED) + t->name = dt_upper_string (sym->name); + else + t->name = sym->name; gfc_insert_bbt (&true_name_root, t, compare_true_names); } @@ -858,13 +904,19 @@ add_true_name (gfc_symbol *sym) static void build_tnt (gfc_symtree *st) { + const char *name; if (st == NULL) return; build_tnt (st->left); build_tnt (st->right); - if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL) + if (st->n.sym->attr.flavor == FL_DERIVED) + name = dt_upper_string (st->n.sym->name); + else + name = st->n.sym->name; + + if (find_true_name (name, st->n.sym->module) != NULL) return; add_true_name (st->n.sym); @@ -2986,8 +3038,12 @@ fix_mio_expr (gfc_expr *e) namespace to see if the required, non-contained symbol is available yet. If so, the latter should be written. */ if (e->symtree->n.sym && check_unique_name (e->symtree->name)) - ns_st = gfc_find_symtree (gfc_current_ns->sym_root, - e->symtree->n.sym->name); + { + const char *name = e->symtree->n.sym->name; + if (e->symtree->n.sym->attr.flavor == FL_DERIVED) + name = dt_upper_string (name); + ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name); + } /* On the other hand, if the existing symbol is the module name or the new symbol is a dummy argument, do not do the promotion. */ @@ -4205,6 +4261,7 @@ load_needed (pointer_info *p) 1, &ns->proc_name); sym = gfc_new_symbol (p->u.rsym.true_name, ns); + sym->name = dt_lower_string (p->u.rsym.true_name); sym->module = gfc_get_string (p->u.rsym.module); strcpy (sym->binding_label, p->u.rsym.binding_label); @@ -4497,6 +4554,7 @@ read_module (void) { info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns); + info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name); sym = info->u.rsym.sym; sym->module = gfc_get_string (info->u.rsym.module); @@ -4835,7 +4893,7 @@ write_dt_extensions (gfc_symtree *st) return; mio_lparen (); - mio_pool_string (&st->n.sym->name); + mio_pool_string (&st->name); if (st->n.sym->module != NULL) mio_pool_string (&st->n.sym->module); else @@ -4870,7 +4928,15 @@ write_symbol (int n, gfc_symbol *sym) gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name); mio_integer (&n); - mio_pool_string (&sym->name); + + if (sym->attr.flavor == FL_DERIVED) + { + const char *name; + name = dt_upper_string (sym->name); + mio_pool_string (&name); + } + else + mio_pool_string (&sym->name); mio_pool_string (&sym->module); if (sym->attr.is_bind_c || sym->attr.is_iso_c) @@ -5566,7 +5632,8 @@ create_derived_type (const char *name, const char *modname, intmod_id module, int id) { gfc_symtree *tmp_symtree; - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym; + gfc_interface *intr, *head; tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); if (tmp_symtree != NULL) @@ -5579,18 +5646,35 @@ create_derived_type (const char *name, const char *modname, gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); sym = tmp_symtree->n.sym; - sym->module = gfc_get_string (modname); sym->from_intmod = module; sym->intmod_sym_id = id; - sym->attr.flavor = FL_DERIVED; - sym->attr.private_comp = 1; - sym->attr.zero_comp = 1; - sym->attr.use_assoc = 1; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.function = 1; + sym->attr.generic = 1; + + gfc_get_sym_tree (dt_upper_string (sym->name), + gfc_current_ns, &tmp_symtree, false); + dt_sym = tmp_symtree->n.sym; + dt_sym->name = gfc_get_string (sym->name); + dt_sym->attr.flavor = FL_DERIVED; + dt_sym->attr.private_comp = 1; + dt_sym->attr.zero_comp = 1; + dt_sym->attr.use_assoc = 1; + dt_sym->module = gfc_get_string (modname); + dt_sym->from_intmod = module; + dt_sym->intmod_sym_id = id; + + head = sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + sym->generic = intr; + sym->attr.if_source = IFSRC_DECL; } - /* USE the ISO_FORTRAN_ENV intrinsic module. */ static void diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 24d8960d06b..7d91645207b 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3881,6 +3881,12 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) goto fixup_contained; + if ((st->n.sym->attr.flavor == FL_DERIVED + && sym->attr.generic && sym->attr.function) + ||(sym->attr.flavor == FL_DERIVED + && st->n.sym->attr.generic && st->n.sym->attr.function)) + goto fixup_contained; + old_sym = st->n.sym; if (old_sym->ns == ns && !old_sym->attr.contained diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 23dc0b66400..0f67ec78282 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2315,171 +2315,162 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, return SUCCESS; } -match -gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, - bool parent) + +gfc_try +gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr, + gfc_actual_arglist **arglist, + bool parent) { + gfc_actual_arglist *actual; gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter; gfc_constructor_base ctor_head = NULL; gfc_component *comp; /* Is set NULL when named component is first seen */ - gfc_expr *e; - locus where; - match m; const char* last_name = NULL; + locus old_locus; + gfc_expr *expr; - comp_tail = comp_head = NULL; - - if (!parent && gfc_match_char ('(') != MATCH_YES) - goto syntax; - - where = gfc_current_locus; + expr = parent ? *cexpr : e; + old_locus = gfc_current_locus; + if (parent) + ; /* gfc_current_locus = *arglist->expr ? ->where;*/ + else + gfc_current_locus = expr->where; - gfc_find_component (sym, NULL, false, true); + comp_tail = comp_head = NULL; - /* Check that we're not about to construct an ABSTRACT type. */ if (!parent && sym->attr.abstract) { - gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name); - return MATCH_ERROR; + gfc_error ("Can't construct ABSTRACT type '%s' at %L", + sym->name, &expr->where); + goto cleanup; } - /* Match the component list and store it in a list together with the - corresponding component names. Check for empty argument list first. */ - if (gfc_match_char (')') != MATCH_YES) + comp = sym->components; + actual = parent ? *arglist : expr->value.function.actual; + for ( ; actual; ) { - comp = sym->components; - do - { - gfc_component *this_comp = NULL; - - if (comp == sym->components && sym->attr.extension - && comp->ts.type == BT_DERIVED - && comp->ts.u.derived->attr.zero_comp) - /* Skip empty parents. */ - comp = comp->next; + gfc_component *this_comp = NULL; - if (!comp_head) - comp_tail = comp_head = gfc_get_structure_ctor_component (); - else - { - comp_tail->next = gfc_get_structure_ctor_component (); - comp_tail = comp_tail->next; - } - comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1); - comp_tail->val = NULL; - comp_tail->where = gfc_current_locus; + if (!comp_head) + comp_tail = comp_head = gfc_get_structure_ctor_component (); + else + { + comp_tail->next = gfc_get_structure_ctor_component (); + comp_tail = comp_tail->next; + } + if (actual->name) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure" + " constructor with named arguments at %C") + == FAILURE) + goto cleanup; - /* Try matching a component name. */ - if (gfc_match_name (comp_tail->name) == MATCH_YES - && gfc_match_char ('=') == MATCH_YES) + comp_tail->name = xstrdup (actual->name); + last_name = comp_tail->name; + comp = NULL; + } + else + { + /* Components without name are not allowed after the first named + component initializer! */ + if (!comp) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure" - " constructor with named arguments at %C") - == FAILURE) - goto cleanup; - - last_name = comp_tail->name; - comp = NULL; + if (last_name) + gfc_error ("Component initializer without name after component" + " named %s at %L!", last_name, + actual->expr ? &actual->expr->where + : &gfc_current_locus); + else + gfc_error ("Too many components in structure constructor at " + "%L!", actual->expr ? &actual->expr->where + : &gfc_current_locus); + goto cleanup; } - else - { - /* Components without name are not allowed after the first named - component initializer! */ - if (!comp) - { - 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_current_locus = comp_tail->where; - strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1); - } + comp_tail->name = xstrdup (comp->name); + } - /* Find the current component in the structure definition and check + /* 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, false, false); - else - { - this_comp = gfc_find_component (sym, - (const char *)comp_tail->name, - false, false); - 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; + if (comp) + this_comp = gfc_find_component (sym, comp->name, false, false); + else + { + this_comp = gfc_find_component (sym, (const char *)comp_tail->name, + false, false); + comp = NULL; /* Reset needed! */ + } - /* Check if this component is already given a value. */ - for (comp_iter = comp_head; comp_iter != comp_tail; - comp_iter = comp_iter->next) - { - gcc_assert (comp_iter); - if (!strcmp (comp_iter->name, comp_tail->name)) - { - gfc_error ("Component '%s' is initialized twice in the" - " 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; - /* Match the current initializer expression. */ - if (this_comp->attr.proc_pointer) - gfc_matching_procptr_assignment = 1; - m = gfc_match_expr (&comp_tail->val); - gfc_matching_procptr_assignment = 0; - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; + comp_tail->val = actual->expr; + if (actual->expr != NULL) + comp_tail->where = actual->expr->where; + actual->expr = NULL; - /* F2008, R457/C725, for PURE C1283. */ - if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val)) + /* Check if this component is already given a value. */ + for (comp_iter = comp_head; comp_iter != comp_tail; + comp_iter = comp_iter->next) + { + gcc_assert (comp_iter); + if (!strcmp (comp_iter->name, comp_tail->name)) { - gfc_error ("Coindexed expression to pointer component '%s' in " - "structure constructor at %C!", comp_tail->name); + gfc_error ("Component '%s' is initialized twice in the structure" + " constructor at %L!", comp_tail->name, + comp_tail->val ? &comp_tail->where + : &gfc_current_locus); goto cleanup; - } + } + } + /* F2008, R457/C725, for PURE C1283. */ + if (this_comp->attr.pointer && comp_tail->val + && gfc_is_coindexed (comp_tail->val)) + { + gfc_error ("Coindexed expression to pointer component '%s' in " + "structure constructor at %L!", comp_tail->name, + &comp_tail->where); + 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.u.derived != this_comp->ts.u.derived)) - { - gfc_current_locus = where; - gfc_free_expr (comp_tail->val); - comp_tail->val = NULL; + /* If not explicitly a parent constructor, gather up the components + and build one. */ + if (comp && comp == sym->components + && sym->attr.extension + && comp_tail->val + && (comp_tail->val->ts.type != BT_DERIVED + || + comp_tail->val->ts.u.derived != this_comp->ts.u.derived)) + { + gfc_try m; + gfc_actual_arglist *arg_null = NULL; - m = gfc_match_structure_constructor (comp->ts.u.derived, - &comp_tail->val, true); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - } + actual->expr = comp_tail->val; + comp_tail->val = NULL; - if (comp) - comp = comp->next; + m = gfc_convert_to_structure_constructor (NULL, + comp->ts.u.derived, &comp_tail->val, + comp->ts.u.derived->attr.zero_comp + ? &arg_null : &actual, true); + if (m == FAILURE) + goto cleanup; - if (parent && !comp) - break; - } + if (comp->ts.u.derived->attr.zero_comp) + { + comp = comp->next; + continue; + } + } - while (gfc_match_char (',') == MATCH_YES); + if (comp) + comp = comp->next; + if (parent && !comp) + break; - if (!parent && gfc_match_char (')') != MATCH_YES) - goto syntax; + actual = actual->next; } if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE) @@ -2488,9 +2479,8 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, /* 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). */ - if (comp_head) + if (comp_head && sym->attr.extension) { - gcc_assert (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 " @@ -2499,18 +2489,33 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, } goto cleanup; } + else + gcc_assert (!comp_head); - e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where); - e->ts.u.derived = sym; - e->value.constructor = ctor_head; + if (parent) + { + expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus); + expr->ts.u.derived = sym; + expr->value.constructor = ctor_head; + *cexpr = expr; + } + else + { + expr->ts.u.derived = sym; + expr->ts.kind = 0; + expr->ts.type = BT_DERIVED; + expr->value.constructor = ctor_head; + expr->expr_type = EXPR_STRUCTURE; + } - *result = e; - return MATCH_YES; + gfc_current_locus = old_locus; + if (parent) + *arglist = actual; + return SUCCESS; -syntax: - gfc_error ("Syntax error in structure constructor at %C"); + cleanup: + gfc_current_locus = old_locus; -cleanup: for (comp_iter = comp_head; comp_iter; ) { gfc_structure_ctor_component *next = comp_iter->next; @@ -2518,7 +2523,45 @@ cleanup: comp_iter = next; } gfc_constructor_free (ctor_head); - return MATCH_ERROR; + + return FAILURE; +} + + +match +gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) +{ + match m; + gfc_expr *e; + gfc_symtree *symtree; + + gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */ + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_FUNCTION; + + gcc_assert (sym->attr.flavor == FL_DERIVED + && symtree->n.sym->attr.flavor == FL_PROCEDURE); + e->value.function.esym = sym; + e->symtree->n.sym->attr.generic = 1; + + m = gfc_match_actual_arglist (0, &e->value.function.actual); + if (m != MATCH_YES) + { + gfc_free_expr (e); + return m; + } + + if (gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false) + != SUCCESS) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + + *result = e; + return MATCH_YES; } @@ -2715,7 +2758,7 @@ gfc_match_rvalue (gfc_expr **result) if (sym == NULL) m = MATCH_ERROR; else - m = gfc_match_structure_constructor (sym, &e, false); + goto generic_function; break; /* If we're here, then the name is known to be the name of a @@ -2989,6 +3032,12 @@ gfc_match_rvalue (gfc_expr **result) e->symtree = symtree; e->expr_type = EXPR_FUNCTION; + if (sym->attr.flavor == FL_DERIVED) + { + e->value.function.esym = sym; + e->symtree->n.sym->attr.generic = 1; + } + m = gfc_match_actual_arglist (0, &e->value.function.actual); break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d96b33225ed..6baeff44fa7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -454,7 +454,8 @@ resolve_formal_arglist (gfc_symbol *proc) static void find_arglists (gfc_symbol *sym) { - if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns) + if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns + || sym->attr.flavor == FL_DERIVED) return; resolve_formal_arglist (sym); @@ -967,13 +968,6 @@ resolve_structure_cons (gfc_expr *expr, int init) resolve_fl_derived0 (expr->ts.u.derived); cons = gfc_constructor_first (expr->value.constructor); - /* A constructor may have references if it is the result of substituting a - parameter variable. In this case we just pull out the component we - want. */ - if (expr->ref) - comp = expr->ref->u.c.sym->components; - else - comp = expr->ts.u.derived->components; /* See if the user is trying to invoke a structure constructor for one of the iso_c_binding derived types. */ @@ -992,6 +986,14 @@ resolve_structure_cons (gfc_expr *expr, int init) && cons->expr && cons->expr->expr_type == EXPR_NULL) return SUCCESS; + /* A constructor may have references if it is the result of substituting a + parameter variable. In this case we just pull out the component we + want. */ + if (expr->ref) + comp = expr->ref->u.c.sym->components; + else + comp = expr->ts.u.derived->components; + for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { int rank; @@ -1401,7 +1403,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) gfc_symbol* context_proc; gfc_namespace* real_context; - if (sym->attr.flavor == FL_PROGRAM) + if (sym->attr.flavor == FL_PROGRAM + || sym->attr.flavor == FL_DERIVED) return false; gcc_assert (sym->attr.flavor == FL_PROCEDURE); @@ -2323,6 +2326,7 @@ resolve_generic_f (gfc_expr *expr) { gfc_symbol *sym; match m; + gfc_interface *intr = NULL; sym = expr->symtree->n.sym; @@ -2335,6 +2339,11 @@ resolve_generic_f (gfc_expr *expr) return FAILURE; generic: + if (!intr) + for (intr = sym->generic; intr; intr = intr->next) + if (intr->sym->attr.flavor == FL_DERIVED) + break; + if (sym->ns->parent == NULL) break; gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); @@ -2347,16 +2356,25 @@ generic: /* Last ditch attempt. See if the reference is to an intrinsic that possesses a matching interface. 14.1.2.4 */ - if (sym && !gfc_is_intrinsic (sym, 0, expr->where)) + if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) { - gfc_error ("There is no specific function for the generic '%s' at %L", - expr->symtree->n.sym->name, &expr->where); + gfc_error ("There is no specific function for the generic '%s' " + "at %L", expr->symtree->n.sym->name, &expr->where); return FAILURE; } + if (intr) + { + if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL, + false) != SUCCESS) + return FAILURE; + return resolve_structure_cons (expr, 0); + } + m = gfc_intrinsic_func_interface (expr, 0); if (m == MATCH_YES) return SUCCESS; + if (m == MATCH_NO) gfc_error ("Generic function '%s' at %L is not consistent with a " "specific intrinsic interface", expr->symtree->n.sym->name, @@ -3173,10 +3191,10 @@ resolve_function (gfc_expr *expr) "procedure within a PURE procedure", name, &expr->where); t = FAILURE; } - } - if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL)) - gfc_current_ns->proc_name->attr.implicit_pure = 0; + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + } /* Functions without the RECURSIVE attribution are not allowed to * call themselves. */ @@ -3239,6 +3257,9 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) else if (gfc_pure (NULL)) gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, &c->loc); + + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; } @@ -5053,6 +5074,9 @@ resolve_variable (gfc_expr *e) if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) return FAILURE; + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) + sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); + /* On the other hand, the parser may not have known this is an array; in this case, we have to add a FULL reference. */ if (sym->assoc && sym->attr.dimension && !e->ref) @@ -10152,6 +10176,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) { gfc_symbol *s; gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); + if (s && s->attr.generic) + s = gfc_find_dt_in_generic (s); if (s && s->attr.flavor != FL_DERIVED) { gfc_error ("The type '%s' cannot be host associated at %L " @@ -11718,6 +11744,13 @@ resolve_fl_derived0 (gfc_symbol *sym) } } + 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 (!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) @@ -11788,6 +11821,23 @@ resolve_fl_derived0 (gfc_symbol *sym) static gfc_try resolve_fl_derived (gfc_symbol *sym) { + gfc_symbol *gen_dt = NULL; + + if (!sym->attr.is_class) + gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); + if (gen_dt && gen_dt->generic && gen_dt->generic->next + && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of " + "function '%s' at %L being the same name as derived " + "type at %L", sym->name, + gen_dt->generic->sym == sym + ? gen_dt->generic->next->sym->name + : gen_dt->generic->sym->name, + gen_dt->generic->sym == sym + ? &gen_dt->generic->next->sym->declared_at + : &gen_dt->generic->sym->declared_at, + &sym->declared_at) == FAILURE) + return FAILURE; + if (sym->attr.is_class && sym->ts.u.derived == NULL) { /* Fix up incomplete CLASS symbols. */ @@ -12191,6 +12241,20 @@ resolve_symbol (gfc_symbol *sym) } } + if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c + && sym->ts.u.derived->attr.generic) + { + sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); + if (!sym->ts.u.derived) + { + gfc_error ("The derived type '%s' at %L is of type '%s', " + "which has not been defined", sym->name, + &sym->declared_at, sym->ts.u.derived->name); + sym->ts.type = BT_UNKNOWN; + return; + } + } + /* If the symbol is marked as bind(c), verify it's type and kind. Do not do this for something that was implicitly typed because that is handled in gfc_set_default_type. Handle dummy arguments and procedure @@ -12260,7 +12324,8 @@ resolve_symbol (gfc_symbol *sym) the type is not declared in the scope of the implicit statement. Change the type to BT_UNKNOWN, both because it is so and to prevent an ICE. */ - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL + if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c + && sym->ts.u.derived->components == NULL && !sym->ts.u.derived->attr.zero_comp) { gfc_error ("The derived type '%s' at %L is of type '%s', " @@ -12276,22 +12341,9 @@ resolve_symbol (gfc_symbol *sym) if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.use_assoc && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE) - { - gfc_symbol *ds; - - if (resolve_fl_derived (sym->ts.u.derived) == FAILURE) - return; - - gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds); - if (!ds && sym->attr.function && gfc_check_symbol_access (sym)) - { - symtree = gfc_new_symtree (&sym->ns->sym_root, - sym->ts.u.derived->name); - symtree->n.sym = sym->ts.u.derived; - sym->ts.u.derived->refs++; - } - } + && sym->ns->proc_name->attr.flavor == FL_MODULE + && resolve_fl_derived (sym->ts.u.derived) == FAILURE) + return; /* Unless the derived-type declaration is use associated, Fortran 95 does not allow public entries of private derived types. diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 33ec706f40a..de42297981e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -742,9 +742,10 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (asynchronous); conf2 (threadprivate); conf2 (value); - conf2 (is_bind_c); conf2 (codimension); conf2 (result); + if (!attr->is_iso_c) + conf2 (is_bind_c); break; default: @@ -1949,6 +1950,9 @@ gfc_use_derived (gfc_symbol *sym) if (!sym) return NULL; + if (sym->attr.generic) + sym = gfc_find_dt_in_generic (sym); + if (sym->components != NULL || sym->attr.zero_comp) return sym; /* Already defined. */ @@ -2880,7 +2884,15 @@ gfc_undo_symbols (void) } } - gfc_delete_symtree (&p->ns->sym_root, p->name); + /* The derived type is saved in the symtree with the first + letter capitalized; the all lower-case version to the + derived type contains its associated generic function. */ + if (p->attr.flavor == FL_DERIVED) + gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) p->name[0]), + &p->name[1])); + else + gfc_delete_symtree (&p->ns->sym_root, p->name); gfc_release_symbol (p); continue; @@ -3752,13 +3764,11 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, "create symbol for %s", ptr_name); } - /* Set up the symbol's important fields. Save attr required so we can - initialize the ptr to NULL. */ - tmp_sym->attr.save = SAVE_EXPLICIT; tmp_sym->ts.is_c_interop = 1; tmp_sym->attr.is_c_interop = 1; tmp_sym->ts.is_iso_c = 1; tmp_sym->ts.type = BT_DERIVED; + tmp_sym->attr.flavor = FL_PARAMETER; /* The c_ptr and c_funptr derived types will provide the definition for c_null_ptr and c_null_funptr, respectively. */ @@ -3773,15 +3783,15 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, that has arg(s) of the missing type. In this case, a regular version of the thing should have been put in the current ns. */ + generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR, (const char *) (ptr_id == ISOCBINDING_NULL_PTR - ? "_gfortran_iso_c_binding_c_ptr" - : "_gfortran_iso_c_binding_c_funptr")); - + ? "c_ptr" + : "c_funptr")); tmp_sym->ts.u.derived = - get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR - ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR); + get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR + ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR); } /* Module name is some mangled version of iso_c_binding. */ @@ -3806,9 +3816,6 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, c->expr = gfc_get_expr (); c->expr->expr_type = EXPR_NULL; c->expr->ts.is_iso_c = 1; - /* Must declare c_null_ptr and c_null_funptr as having the - PARAMETER attribute so they can be used in init expressions. */ - tmp_sym->attr.flavor = FL_PARAMETER; return SUCCESS; } @@ -3859,9 +3866,9 @@ gen_cptr_param (gfc_formal_arglist **head, const char *c_ptr_type = NULL; if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER) - c_ptr_type = "_gfortran_iso_c_binding_c_funptr"; + c_ptr_type = "c_funptr"; else - c_ptr_type = "_gfortran_iso_c_binding_c_ptr"; + c_ptr_type = "c_ptr"; if(c_ptr_name == NULL) c_ptr_in = "gfc_cptr__"; @@ -4338,19 +4345,31 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, : c_interop_kinds_table[s].name; gfc_symtree *tmp_symtree = NULL; gfc_symbol *tmp_sym = NULL; - gfc_dt_list **dt_list_ptr = NULL; - gfc_component *tmp_comp = NULL; - char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1]; int index; if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR) return; + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); - /* Already exists in this scope so don't re-add it. - TODO: we should probably check that it's really the same symbol. */ - if (tmp_symtree != NULL) - return; + /* Already exists in this scope so don't re-add it. */ + if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL + && (!tmp_sym->attr.generic + || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL) + && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING) + { + if (tmp_sym->attr.flavor == FL_DERIVED + && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id)) + { + gfc_dt_list *dt_list; + dt_list = gfc_get_dt_list (); + dt_list->derived = tmp_sym; + dt_list->next = gfc_derived_types; + gfc_derived_types = dt_list; + } + + return; + } /* Create the sym tree in the current ns. */ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); @@ -4443,64 +4462,112 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, case ISOCBINDING_PTR: case ISOCBINDING_FUNPTR: - - /* Initialize an integer constant expression node. */ - tmp_sym->attr.flavor = FL_DERIVED; - tmp_sym->ts.is_c_interop = 1; - tmp_sym->attr.is_c_interop = 1; - tmp_sym->attr.is_iso_c = 1; - tmp_sym->ts.is_iso_c = 1; - tmp_sym->ts.type = BT_DERIVED; - - /* A derived type must have the bind attribute to be - interoperable (J3/04-007, Section 15.2.3), even though - the binding label is not used. */ - tmp_sym->attr.is_bind_c = 1; - - tmp_sym->attr.referenced = 1; - - tmp_sym->ts.u.derived = tmp_sym; - - /* Add the symbol created for the derived type to the current ns. */ - dt_list_ptr = &(gfc_derived_types); - while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL) - dt_list_ptr = &((*dt_list_ptr)->next); - - /* There is already at least one derived type in the list, so append - the one we're currently building for c_ptr or c_funptr. */ - if (*dt_list_ptr != NULL) - dt_list_ptr = &((*dt_list_ptr)->next); - (*dt_list_ptr) = gfc_get_dt_list (); - (*dt_list_ptr)->derived = tmp_sym; - (*dt_list_ptr)->next = NULL; - - /* Set up the component of the derived type, which will be - an integer with kind equal to c_ptr_size. Mangle the name of - the field for the c_address to prevent the curious user from - trying to access it from Fortran. */ - sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address"); - gfc_add_component (tmp_sym, comp_name, &tmp_comp); - if (tmp_comp == NULL) + { + gfc_interface *intr, *head; + gfc_symbol *dt_sym; + const char *hidden_name; + gfc_dt_list **dt_list_ptr = NULL; + gfc_component *tmp_comp = NULL; + char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1]; + + hidden_name = gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) tmp_sym->name[0]), + &tmp_sym->name[1]); + + /* Generate real derived type. */ + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, + hidden_name); + + if (tmp_symtree != NULL) + gcc_unreachable (); + gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false); + if (tmp_symtree) + dt_sym = tmp_symtree->n.sym; + else + gcc_unreachable (); + + /* Generate an artificial generic function. */ + dt_sym->name = gfc_get_string (tmp_sym->name); + head = tmp_sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + tmp_sym->generic = intr; + + if (!tmp_sym->attr.generic + && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL) + == FAILURE) + return; + + if (!tmp_sym->attr.function + && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL) + == FAILURE) + return; + + /* Say what module this symbol belongs to. */ + dt_sym->module = gfc_get_string (mod_name); + dt_sym->from_intmod = INTMOD_ISO_C_BINDING; + dt_sym->intmod_sym_id = s; + + /* Initialize an integer constant expression node. */ + dt_sym->attr.flavor = FL_DERIVED; + dt_sym->ts.is_c_interop = 1; + dt_sym->attr.is_c_interop = 1; + dt_sym->attr.is_iso_c = 1; + dt_sym->ts.is_iso_c = 1; + dt_sym->ts.type = BT_DERIVED; + + /* A derived type must have the bind attribute to be + interoperable (J3/04-007, Section 15.2.3), even though + the binding label is not used. */ + dt_sym->attr.is_bind_c = 1; + + dt_sym->attr.referenced = 1; + dt_sym->ts.u.derived = dt_sym; + + /* Add the symbol created for the derived type to the current ns. */ + dt_list_ptr = &(gfc_derived_types); + while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL) + dt_list_ptr = &((*dt_list_ptr)->next); + + /* There is already at least one derived type in the list, so append + the one we're currently building for c_ptr or c_funptr. */ + if (*dt_list_ptr != NULL) + dt_list_ptr = &((*dt_list_ptr)->next); + (*dt_list_ptr) = gfc_get_dt_list (); + (*dt_list_ptr)->derived = dt_sym; + (*dt_list_ptr)->next = NULL; + + /* Set up the component of the derived type, which will be + an integer with kind equal to c_ptr_size. Mangle the name of + the field for the c_address to prevent the curious user from + trying to access it from Fortran. */ + sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address"); + gfc_add_component (dt_sym, comp_name, &tmp_comp); + if (tmp_comp == NULL) gfc_internal_error ("generate_isocbinding_symbol(): Unable to " "create component for c_address"); - tmp_comp->ts.type = BT_INTEGER; + tmp_comp->ts.type = BT_INTEGER; - /* Set this because the module will need to read/write this field. */ - tmp_comp->ts.f90_type = BT_INTEGER; + /* Set this because the module will need to read/write this field. */ + tmp_comp->ts.f90_type = BT_INTEGER; - /* The kinds for c_ptr and c_funptr are the same. */ - index = get_c_kind ("c_ptr", c_interop_kinds_table); - tmp_comp->ts.kind = c_interop_kinds_table[index].value; + /* The kinds for c_ptr and c_funptr are the same. */ + index = get_c_kind ("c_ptr", c_interop_kinds_table); + tmp_comp->ts.kind = c_interop_kinds_table[index].value; - tmp_comp->attr.pointer = 0; - tmp_comp->attr.dimension = 0; + tmp_comp->attr.pointer = 0; + tmp_comp->attr.dimension = 0; - /* Mark the component as C interoperable. */ - tmp_comp->ts.is_c_interop = 1; + /* Mark the component as C interoperable. */ + tmp_comp->ts.is_c_interop = 1; + + /* Make it use associated (iso_c_binding module). */ + dt_sym->attr.use_assoc = 1; + } - /* Make it use associated (iso_c_binding module). */ - tmp_sym->attr.use_assoc = 1; break; case ISOCBINDING_NULL_PTR: @@ -4550,21 +4617,20 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); - if (tmp_sym->ts.u.derived == NULL) - { + if (tmp_sym->ts.u.derived == NULL) + { /* Create the necessary derived type so we can continue processing the file. */ - generate_isocbinding_symbol + generate_isocbinding_symbol (mod_name, s == ISOCBINDING_FUNLOC - ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR, - (const char *)(s == ISOCBINDING_FUNLOC - ? "_gfortran_iso_c_binding_c_funptr" - : "_gfortran_iso_c_binding_c_ptr")); + ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR, + (const char *)(s == ISOCBINDING_FUNLOC + ? "c_funptr" : "c_ptr")); tmp_sym->ts.u.derived = - get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC - ? ISOCBINDING_FUNPTR - : ISOCBINDING_PTR); - } + get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC + ? ISOCBINDING_FUNPTR + : ISOCBINDING_PTR); + } /* The function result is itself (no result clause). */ tmp_sym->result = tmp_sym; @@ -4712,6 +4778,9 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0) gfc_symbol* gfc_get_derived_super_type (gfc_symbol* derived) { + if (derived && derived->attr.generic) + derived = gfc_find_dt_in_generic (derived); + if (!derived->attr.extension) return NULL; @@ -4719,6 +4788,9 @@ gfc_get_derived_super_type (gfc_symbol* derived) gcc_assert (derived->components->ts.type == BT_DERIVED); gcc_assert (derived->components->ts.u.derived); + if (derived->components->ts.u.derived->attr.generic) + return gfc_find_dt_in_generic (derived->components->ts.u.derived); + return derived->components->ts.u.derived; } @@ -4814,3 +4886,19 @@ gfc_is_associate_pointer (gfc_symbol* sym) return true; } + + +gfc_symbol * +gfc_find_dt_in_generic (gfc_symbol *sym) +{ + gfc_interface *intr = NULL; + + if (!sym || sym->attr.flavor == FL_DERIVED) + return sym; + + if (sym->attr.generic) + for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next) + if (intr->sym->attr.flavor == FL_DERIVED) + break; + return intr ? intr->sym : NULL; +} diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 262743d0d37..ee8f89693b4 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1087,7 +1087,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, for (s = ss; s; s = s->parent) for (n = 0; n < s->loop->dimen; n++) { - dim = get_scalarizer_dim_for_array_dim (ss, ss->dim[n]); + dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]); /* For a callee allocated array express the loop bounds in terms of the descriptor fields. */ @@ -4341,9 +4341,9 @@ set_loop_bounds (gfc_loopinfo *loop) } /* Transform everything so we have a simple incrementing variable. */ - if (n < loop->dimen && integer_onep (info->stride[dim])) + if (integer_onep (info->stride[dim])) info->delta[dim] = gfc_index_zero_node; - else if (n < loop->dimen) + else { /* Set the delta for this section. */ info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); @@ -5027,6 +5027,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) tree index, range; VEC(constructor_elt,gc) *v = NULL; + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->attr.flavor == FL_PARAMETER + && expr->symtree->n.sym->value) + expr = expr->symtree->n.sym->value; + switch (expr->expr_type) { case EXPR_CONSTANT: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 80e4f555d1c..67bd3e233f0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -699,6 +699,18 @@ gfc_get_module_backend_decl (gfc_symbol *sym) } else if (sym->attr.flavor == FL_DERIVED) { + if (s && s->attr.flavor == FL_PROCEDURE) + { + gfc_interface *intr; + gcc_assert (s->attr.generic); + for (intr = s->generic; intr; intr = intr->next) + if (intr->sym->attr.flavor == FL_DERIVED) + { + s = intr->sym; + break; + } + } + if (!s->backend_decl) s->backend_decl = gfc_get_derived_type (s); gfc_copy_dt_decls_ifequal (s, sym, true); @@ -706,7 +718,7 @@ gfc_get_module_backend_decl (gfc_symbol *sym) } else if (s->backend_decl) { - if (sym->ts.type == BT_DERIVED) + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, true); else if (sym->ts.type == BT_CHARACTER) @@ -1459,6 +1471,10 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !sym->attr.proc_pointer) DECL_BY_REFERENCE (decl) = 1; + if (sym->attr.vtab + || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0)) + GFC_DECL_PUSH_TOPLEVEL (decl) = 1; + return decl; } @@ -1654,6 +1670,11 @@ gfc_get_extern_function_decl (gfc_symbol * sym) gfc_find_symbol (sym->name, gsym->ns, 0, &s); if (s && s->backend_decl) { + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, + true); + else if (sym->ts.type == BT_CHARACTER) + sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; sym->backend_decl = s->backend_decl; return sym->backend_decl; } @@ -1879,7 +1900,8 @@ build_function_decl (gfc_symbol * sym, bool global) /* Layout the function declaration and put it in the binding level of the current function. */ - if (global) + if (global + || (sym->name[0] == '_' && strncmp ("__copy", sym->name, 6) == 0)) pushdecl_top_level (fndecl); else pushdecl (fndecl); @@ -4035,7 +4057,18 @@ gfc_trans_use_stmts (gfc_namespace * ns) st = gfc_find_symtree (ns->sym_root, rent->local_name[0] ? rent->local_name : rent->use_name); - gcc_assert (st); + + /* The following can happen if a derived type is renamed. */ + if (!st) + { + char *name; + name = xstrdup (rent->local_name[0] + ? rent->local_name : rent->use_name); + name[0] = (char) TOUPPER ((unsigned char) name[0]); + st = gfc_find_symtree (ns->sym_root, name); + free (name); + gcc_assert (st); + } /* Sometimes, generic interfaces wind up being over-ruled by a local symbol (see PR41062). */ @@ -5293,7 +5326,10 @@ gfc_generate_function_code (gfc_namespace * ns) next = DECL_CHAIN (decl); DECL_CHAIN (decl) = NULL_TREE; - pushdecl (decl); + if (GFC_DECL_PUSH_TOPLEVEL (decl)) + pushdecl_top_level (decl); + else + pushdecl (decl); decl = next; } saved_function_decls = NULL_TREE; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 0d793f96858..b21be45a96d 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1259,7 +1259,8 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, loc = code->ext.iterator->start->where.lb->location; /* Initialize the DO variable: dovar = from. */ - gfc_add_modify_loc (loc, pblock, dovar, from); + gfc_add_modify_loc (loc, pblock, dovar, + fold_convert (TREE_TYPE(dovar), from)); /* Save value for do-tinkering checking. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index ce607d8dbfd..d643c2e45b8 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2188,6 +2188,9 @@ gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, gfc_component *to_cm; gfc_component *from_cm; + if (from == to) + return 1; + if (from->backend_decl == NULL || !gfc_compare_derived_types (from, to)) return 0; @@ -2257,6 +2260,10 @@ gfc_get_derived_type (gfc_symbol * derived) gfc_dt_list *dt; gfc_namespace *ns; + if (derived && derived->attr.flavor == FL_PROCEDURE + && derived->attr.generic) + derived = gfc_find_dt_in_generic (derived); + gcc_assert (derived && derived->attr.flavor == FL_DERIVED); /* See if it's one of the iso_c_binding derived types. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 22033d38d15..8fc7599473d 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -802,6 +802,7 @@ struct GTY((variable_size)) lang_decl { #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node) #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node) #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node) +#define GFC_DECL_PUSH_TOPLEVEL(node) DECL_LANG_FLAG_7(node) /* An array descriptor. */ #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node) |