diff options
| author | Tobias Burnus <burnus@gcc.gnu.org> | 2011-11-16 22:37:43 +0100 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2011-11-16 22:37:43 +0100 |
| commit | c3f34952484cfe374448d5021dfb7dedf138c9ab (patch) | |
| tree | 61a919d8cae4728618964335046a765c914ca292 /gcc | |
| parent | 16e835bb5c484dfd735d5ee24c023ace800d0332 (diff) | |
| download | gcc-c3f34952484cfe374448d5021dfb7dedf138c9ab.zip gcc-c3f34952484cfe374448d5021dfb7dedf138c9ab.tar.gz gcc-c3f34952484cfe374448d5021dfb7dedf138c9ab.tar.bz2 | |
re PR fortran/39427 (F2003: Procedures with same name as types/type constructors)
gcc/fortran
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.
gcc/testsuite/
2011-11-16 Tobias Burnus <burnus@net-b.de>
PR fortran/39427
PR fortran/37829
* gfortran.dg/constructor_1.f90: New.
* gfortran.dg/constructor_2.f90: New.
* gfortran.dg/constructor_3.f90: New.
* gfortran.dg/constructor_4.f90: New.
* gfortran.dg/constructor_5.f90: New.
* gfortran.dg/constructor_6.f90: New.
* gfortran.dg/use_only_5.f90: New.
* gfortran.dg/c_ptr_tests_17.f90: New.
* gfortran.dg/c_ptr_tests_18.f90: New.
* gfortran.dg/used_types_25.f90: New.
* gfortran.dg/used_types_26.f90: New
* gfortran.dg/type_decl_3.f90: New.
* gfortran.dg/function_types_3.f90: Update dg-error.
* gfortran.dg/result_1.f90: Ditto.
* gfortran.dg/structure_constructor_3.f03: Ditto.
* gfortran.dg/structure_constructor_4.f03: Ditto.
From-SVN: r181425
Diffstat (limited to 'gcc')
31 files changed, 1440 insertions, 309 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 01abd74..cd452ab 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,49 @@ +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/decl.c b/gcc/fortran/decl.c index 2dd38b9..3e553a3 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 17ebd58..372c056 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 90d98c7..6d2acce 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 4ea98b6..fbafe82 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 0d84104..df18074 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 62f7598..7c28e8b 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 24d8960..7d91645 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 23dc0b6..0f67ec7 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 d96b332..94c21be 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, @@ -5053,6 +5071,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 +10173,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 +11741,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 +11818,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 +12238,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 +12321,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 +12338,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 33ec706..9bd6ed4 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1949,6 +1949,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 +2883,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; @@ -3773,15 +3784,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. */ @@ -3859,9 +3870,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 +4349,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 +4466,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 +4621,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 +4782,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 +4792,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 +4890,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 262743d..2fb2d34 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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 80e4f55..02c0ed7 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); @@ -4035,7 +4047,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). */ diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index ce607d8..3f4ebd5 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2257,6 +2257,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/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 72a8fde..78c101a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,24 @@ +2011-11-16 Tobias Burnus <burnus@net-b.de> + + PR fortran/39427 + PR fortran/37829 + * gfortran.dg/constructor_1.f90: New. + * gfortran.dg/constructor_2.f90: New. + * gfortran.dg/constructor_3.f90: New. + * gfortran.dg/constructor_4.f90: New. + * gfortran.dg/constructor_5.f90: New. + * gfortran.dg/constructor_6.f90: New. + * gfortran.dg/use_only_5.f90: New. + * gfortran.dg/c_ptr_tests_17.f90: New. + * gfortran.dg/c_ptr_tests_18.f90: New. + * gfortran.dg/used_types_25.f90: New. + * gfortran.dg/used_types_26.f90: New + * gfortran.dg/type_decl_3.f90: New. + * gfortran.dg/function_types_3.f90: Update dg-error. + * gfortran.dg/result_1.f90: Ditto. + * gfortran.dg/structure_constructor_3.f03: Ditto. + * gfortran.dg/structure_constructor_4.f03: Ditto. + 2011-10-16 Matthew Gretton-Dann <matthew.gretton-dann@arm.com> * gcc.dg/vect/pr30858.c: Update expected output for @@ -12,7 +33,7 @@ 2011-11-16 Razya Ladelsky <razya@il.ibm.com> - PR tree-optimization/49960 + PR tree-optimization/49960 * gcc.dg/autopar/pr49960.c: New test. * gcc.dg/autopar/pr49960-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90 b/gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90 new file mode 100644 index 0000000..9bbd0dd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90 @@ -0,0 +1,88 @@ +! { dg-do compile } +! +! PR fortran/37829 +! +! Contributed by James Van Buskirk and Jerry DeLisle. +! +! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR. + +module m3 + use ISO_C_BINDING + implicit none + private + + public kill_C_PTR + interface + function kill_C_PTR() bind(C) + import + implicit none + type(C_PTR) kill_C_PTR + end function kill_C_PTR + end interface + + public kill_C_FUNPTR + interface + function kill_C_FUNPTR() bind(C) + import + implicit none + type(C_FUNPTR) kill_C_FUNPTR + end function kill_C_FUNPTR + end interface +end module m3 + +module m1 + use m3 +end module m1 + +program X + use m1 + use ISO_C_BINDING + implicit none + type(C_PTR) cp + type(C_FUNPTR) fp + integer(C_INT),target :: i + interface + function fun() bind(C) + use ISO_C_BINDING + implicit none + real(C_FLOAT) fun + end function fun + end interface + + cp = C_NULL_PTR + cp = C_LOC(i) + fp = C_NULL_FUNPTR + fp = C_FUNLOC(fun) +end program X + +function fun() bind(C) + use ISO_C_BINDING + implicit none + real(C_FLOAT) fun + fun = 1.0 +end function fun + +function kill_C_PTR() bind(C) + use ISO_C_BINDING + implicit none + type(C_PTR) kill_C_PTR + integer(C_INT), pointer :: p + allocate(p) + kill_C_PTR = C_LOC(p) +end function kill_C_PTR + +function kill_C_FUNPTR() bind(C) + use ISO_C_BINDING + implicit none + type(C_FUNPTR) kill_C_FUNPTR + interface + function fun() bind(C) + use ISO_C_BINDING + implicit none + real(C_FLOAT) fun + end function fun + end interface + kill_C_FUNPTR = C_FUNLOC(fun) +end function kill_C_FUNPTR + +! { dg-final { cleanup-modules "m3 m1" } } diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90 b/gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90 new file mode 100644 index 0000000..6239516 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR fortran/37829 +! PR fortran/45190 +! +! Contributed by Mat Cross +! +! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR. + +MODULE NAG_J_TYPES + USE ISO_C_BINDING, ONLY : C_PTR + IMPLICIT NONE + TYPE :: NAG_IMAGE + INTEGER :: WIDTH, HEIGHT, PXFMT, NCHAN + TYPE (C_PTR) :: PIXELS + END TYPE NAG_IMAGE +END MODULE NAG_J_TYPES +program cfpointerstress + use nag_j_types + use iso_c_binding + implicit none + type(nag_image),pointer :: img + type(C_PTR) :: ptr + real, pointer :: r + allocate(r) + allocate(img) + r = 12 + ptr = c_loc(img) + write(*,*) 'C_ASSOCIATED =', C_ASSOCIATED(ptr) + call c_f_pointer(ptr, img) + write(*,*) 'ASSOCIATED =', associated(img) + deallocate(r) +end program cfpointerstress + +! { dg-final { cleanup-modules "nag_j_types" } } diff --git a/gcc/testsuite/gfortran.dg/constructor_1.f90 b/gcc/testsuite/gfortran.dg/constructor_1.f90 new file mode 100644 index 0000000..e8fe03a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/constructor_1.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! Contributed by Damian Rouson. +! +module mycomplex_module + private + public :: mycomplex + type mycomplex +! private + real :: argument, modulus + end type + interface mycomplex + module procedure complex_to_mycomplex, two_reals_to_mycomplex + end interface +! : + contains + type(mycomplex) function complex_to_mycomplex(c) + complex, intent(in) :: c +! : + end function complex_to_mycomplex + type(mycomplex) function two_reals_to_mycomplex(x,y) + real, intent(in) :: x + real, intent(in), optional :: y +! : + end function two_reals_to_mycomplex +! : + end module mycomplex_module +! : +program myuse + use mycomplex_module + type(mycomplex) :: a, b, c +! : + a = mycomplex(argument=5.6, modulus=1.0) ! The structure constructor + c = mycomplex(x=0.0, y=1.0) ! A function reference + c = mycomplex(0.0, 1.0) ! A function reference +end program myuse + +! { dg-final { cleanup-modules "mycomplex_module" } } diff --git a/gcc/testsuite/gfortran.dg/constructor_2.f90 b/gcc/testsuite/gfortran.dg/constructor_2.f90 new file mode 100644 index 0000000..0e3d8af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/constructor_2.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! +! PR fortran/39427 +! +module foo_module + interface foo + procedure constructor + end interface + + type foo + integer :: bar + end type +contains + type(foo) function constructor() + constructor%bar = 1 + end function + + subroutine test_foo() + type(foo) :: f + f = foo() + if (f%bar /= 1) call abort () + f = foo(2) + if (f%bar /= 2) call abort () + end subroutine test_foo +end module foo_module + + +! Same as foo_module but order +! of INTERFACE and TYPE reversed +module bar_module + type bar + integer :: bar + end type + + interface bar + procedure constructor + end interface +contains + type(bar) function constructor() + constructor%bar = 3 + end function + + subroutine test_bar() + type(bar) :: f + f = bar() + if (f%bar /= 3) call abort () + f = bar(4) + if (f%bar /= 4) call abort () + end subroutine test_bar +end module bar_module + +program main + use foo_module + use bar_module + implicit none + + type(foo) :: f + type(bar) :: b + + call test_foo() + f = foo() + if (f%bar /= 1) call abort () + f = foo(2) + if (f%bar /= 2) call abort () + + call test_bar() + b = bar() + if (b%bar /= 3) call abort () + b = bar(4) + if (b%bar /= 4) call abort () +end program main + +! { dg-final { cleanup-tree-dump "foo_module bar_module" } } diff --git a/gcc/testsuite/gfortran.dg/constructor_3.f90 b/gcc/testsuite/gfortran.dg/constructor_3.f90 new file mode 100644 index 0000000..4015090 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/constructor_3.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! +module m + interface cons + procedure cons42 + end interface cons +contains + integer function cons42() + cons42 = 42 + end function cons42 +end module m + + +module m2 + type cons + integer :: j = -1 + end type cons + interface cons + procedure consT + end interface cons +contains + type(cons) function consT(k) + integer :: k + consT%j = k**2 + end function consT +end module m2 + + +use m +use m2, only: cons +implicit none +type(cons) :: x +integer :: k +x = cons(3) +k = cons() +if (x%j /= 9) call abort () +if (k /= 42) call abort () +!print *, x%j +!print *, k +end + +! { dg-final { cleanup-modules "m m2" } } diff --git a/gcc/testsuite/gfortran.dg/constructor_4.f90 b/gcc/testsuite/gfortran.dg/constructor_4.f90 new file mode 100644 index 0000000..34dfba8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/constructor_4.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! +module m + type t ! { dg-error "the same name as derived type" } + integer :: x + end type t + interface t + module procedure f + end interface t +contains + function f() ! { dg-error "the same name as derived type" } + type(t) :: f + end function +end module + +module m2 + interface t2 + module procedure f2 + end interface t2 + type t2 ! { dg-error "the same name as derived type" } + integer :: x2 + end type t2 +contains + function f2() ! { dg-error "the same name as derived type" } + type(t2) :: f2 + end function +end module diff --git a/gcc/testsuite/gfortran.dg/constructor_5.f90 b/gcc/testsuite/gfortran.dg/constructor_5.f90 new file mode 100644 index 0000000..ab9c9f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/constructor_5.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! +module m + type t + integer :: x + end type t + interface t + module procedure f + end interface t +contains + function f() + type(t) :: f + end function +end module + +module m2 + interface t2 + module procedure f2 + end interface t2 + type t2 + integer :: x2 + end type t2 +contains + function f2() + type(t2) :: f2 + end function +end module + +! { dg-final { cleanup-modules "m m2" } } diff --git a/gcc/testsuite/gfortran.dg/constructor_6.f90 b/gcc/testsuite/gfortran.dg/constructor_6.f90 new file mode 100644 index 0000000..00b99f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/constructor_6.f90 @@ -0,0 +1,171 @@ +! { dg-do run } +! +! PR fortran/39427 +! +! Contributed by Norman S. Clerman (in PR fortran/45155) +! +! Constructor test case +! +! +module test_cnt + integer, public, save :: my_test_cnt = 0 +end module test_cnt + +module Rational + use test_cnt + implicit none + private + + type, public :: rational_t + integer :: n = 0, id = 1 + contains + procedure, nopass :: Construct_rational_t + procedure :: Print_rational_t + procedure, private :: Rational_t_init + generic :: Rational_t => Construct_rational_t + generic :: print => Print_rational_t + end type rational_t + +contains + + function Construct_rational_t (message_) result (return_type) + character (*), intent (in) :: message_ + type (rational_t) :: return_type + +! print *, trim (message_) + if (my_test_cnt /= 1) call abort() + my_test_cnt = my_test_cnt + 1 + call return_type % Rational_t_init + + end function Construct_rational_t + + subroutine Print_rational_t (this_) + class (rational_t), intent (in) :: this_ + +! print *, "n, id", this_% n, this_% id + if (my_test_cnt == 0) then + if (this_% n /= 0 .or. this_% id /= 1) call abort () + else if (my_test_cnt == 2) then + if (this_% n /= 10 .or. this_% id /= 0) call abort () + else + call abort () + end if + my_test_cnt = my_test_cnt + 1 + end subroutine Print_rational_t + + subroutine Rational_t_init (this_) + class (rational_t), intent (in out) :: this_ + + this_% n = 10 + this_% id = 0 + + end subroutine Rational_t_init + +end module Rational + +module Temp_node + use test_cnt + implicit none + private + + real, parameter :: NOMINAL_TEMP = 20.0 + + type, public :: temp_node_t + real :: temperature = NOMINAL_TEMP + integer :: id = 1 + contains + procedure :: Print_temp_node_t + procedure, private :: Temp_node_t_init + generic :: Print => Print_temp_node_t + end type temp_node_t + + interface temp_node_t + module procedure Construct_temp_node_t + end interface + +contains + + function Construct_temp_node_t (message_) result (return_type) + character (*), intent (in) :: message_ + type (temp_node_t) :: return_type + + !print *, trim (message_) + if (my_test_cnt /= 4) call abort() + my_test_cnt = my_test_cnt + 1 + call return_type % Temp_node_t_init + + end function Construct_temp_node_t + + subroutine Print_temp_node_t (this_) + class (temp_node_t), intent (in) :: this_ + +! print *, "temp, id", this_% temperature, this_% id + if (my_test_cnt == 3) then + if (this_% temperature /= 20 .or. this_% id /= 1) call abort () + else if (my_test_cnt == 5) then + if (this_% temperature /= 10 .or. this_% id /= 0) call abort () + else + call abort () + end if + my_test_cnt = my_test_cnt + 1 + end subroutine Print_temp_node_t + + subroutine Temp_node_t_init (this_) + class (temp_node_t), intent (in out) :: this_ + + this_% temperature = 10.0 + this_% id = 0 + + end subroutine Temp_node_t_init + +end module Temp_node + +program Struct_over + use test_cnt + use Rational, only : rational_t + use Temp_node, only : temp_node_t + + implicit none + + type (rational_t) :: sample_rational_t + type (temp_node_t) :: sample_temp_node_t + +! print *, "rational_t" +! print *, "----------" +! print *, "" +! +! print *, "after declaration" + if (my_test_cnt /= 0) call abort() + call sample_rational_t % print + + if (my_test_cnt /= 1) call abort() + + sample_rational_t = sample_rational_t % rational_t ("using override") + if (my_test_cnt /= 2) call abort() +! print *, "after override" + ! call print (sample_rational_t) + ! call sample_rational_t % print () + call sample_rational_t % print + + if (my_test_cnt /= 3) call abort() + +! print *, "sample_t" +! print *, "--------" +! print *, "" +! +! print *, "after declaration" + call sample_temp_node_t % print + + if (my_test_cnt /= 4) call abort() + + sample_temp_node_t = temp_node_t ("using override") + if (my_test_cnt /= 5) call abort() +! print *, "after override" + ! call print (sample_rational_t) + ! call sample_rational_t % print () + call sample_temp_node_t % print + if (my_test_cnt /= 6) call abort() + +end program Struct_over + +! { dg-final { cleanup-modules "test_cnt rational temp_node" } } diff --git a/gcc/testsuite/gfortran.dg/function_types_3.f90 b/gcc/testsuite/gfortran.dg/function_types_3.f90 index 8d00f5f..49d5d5f 100644 --- a/gcc/testsuite/gfortran.dg/function_types_3.f90 +++ b/gcc/testsuite/gfortran.dg/function_types_3.f90 @@ -14,6 +14,6 @@ end ! PR 50403: SIGSEGV in gfc_use_derived -type(f) function f() ! { dg-error "conflicts with DERIVED attribute|is not accessible" } +type(f) function f() ! { dg-error "Type name 'f' at .1. conflicts with previously declared entity|The type for function 'f' at .1. is not accessible" } f=110 ! { dg-error "Unclassifiable statement" } end diff --git a/gcc/testsuite/gfortran.dg/result_1.f90 b/gcc/testsuite/gfortran.dg/result_1.f90 index 162ffaf..96d2a1f 100644 --- a/gcc/testsuite/gfortran.dg/result_1.f90 +++ b/gcc/testsuite/gfortran.dg/result_1.f90 @@ -14,5 +14,10 @@ namelist /s/ a,b,c ! { dg-error "attribute conflicts" } end function function h() result(t) -type t ! { dg-error "attribute conflicts" } +type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" } +end type t ! { dg-error "Expecting END FUNCTION statement" } +end function + +function i() result(t) +type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" } end function diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_3.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_3.f03 index aa59349..5fb7d61 100644 --- a/gcc/testsuite/gfortran.dg/structure_constructor_3.f03 +++ b/gcc/testsuite/gfortran.dg/structure_constructor_3.f03 @@ -13,6 +13,6 @@ PROGRAM test TYPE(basics_t) :: basics - basics = basics_t (i=42, 1.5) ! { dg-error "without name after" } + basics = basics_t (i=42, 1.5) ! { dg-error "Missing keyword name" } END PROGRAM test diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_4.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_4.f03 index 647be5f..8a5aaa7 100644 --- a/gcc/testsuite/gfortran.dg/structure_constructor_4.f03 +++ b/gcc/testsuite/gfortran.dg/structure_constructor_4.f03 @@ -14,6 +14,6 @@ PROGRAM test TYPE(basics_t) :: basics basics = basics_t (42, r=1.5, i=15) ! { dg-error "'i' is initialized twice" } - basics = basics_t (42, r=1., r=-2.) ! { dg-error "'r' is initialized twice" } + basics = basics_t (42, r=1., r=-2.) ! { dg-error "has already appeared in the current argument list" } END PROGRAM test diff --git a/gcc/testsuite/gfortran.dg/type_decl_3.f90 b/gcc/testsuite/gfortran.dg/type_decl_3.f90 new file mode 100644 index 0000000..a3fc54a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/type_decl_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! +! PR fortran/39427 +! + subroutine t(x) ! { dg-error "conflicts with previously declared entity" } + type(t) :: x ! { dg-error "conflicts with previously declared entity" } + end subroutine t diff --git a/gcc/testsuite/gfortran.dg/use_only_5.f90 b/gcc/testsuite/gfortran.dg/use_only_5.f90 new file mode 100644 index 0000000..56d33f4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_only_5.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR fortran/39427 +! +! Test case was failing with the initial version of the +! constructor patch. +! +! Based on the Fortran XML library FoX + +module m_common_attrs + implicit none + private + + type dict_item + integer, allocatable :: i(:) + end type dict_item + + type dictionary_t + private + type(dict_item), pointer :: d => null() + end type dictionary_t + + public :: dictionary_t + public :: get_prefix_by_index + +contains + pure function get_prefix_by_index(dict) result(prefix) + type(dictionary_t), intent(in) :: dict + character(len=size(dict%d%i)) :: prefix + end function get_prefix_by_index +end module m_common_attrs + +module m_common_namespaces + use m_common_attrs, only: dictionary_t + use m_common_attrs, only: get_prefix_by_index +end module m_common_namespaces + +! { dg-final { cleanup-modules "m_common_attrs m_common_namespaces" } } diff --git a/gcc/testsuite/gfortran.dg/used_types_25.f90 b/gcc/testsuite/gfortran.dg/used_types_25.f90 new file mode 100644 index 0000000..35ac8c7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_25.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! Created to check this ambiguity when +! constructors were added. Cf. PR fortran/39427 + +module m + type t + end type t +end module m + +use m + type t ! { dg-error "Derived type definition of 't' at .1. has already been defined" } + end type t ! { dg-error "Expecting END PROGRAM statement" } +end + +! { dg-final { cleanup-modules "m" } } + diff --git a/gcc/testsuite/gfortran.dg/used_types_26.f90 b/gcc/testsuite/gfortran.dg/used_types_26.f90 new file mode 100644 index 0000000..2c0437f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_26.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! Check for ambiguity. +! +! Added as part of the constructor work (PR fortran/39427). +! + module m + type t + end type t + end module m + + module m2 + type t + end type t + end module m2 + + use m + use m2 + type(t) :: x ! { dg-error "Type name 't' at .1. is ambiguous" } + end + +! { dg-final { cleanup-modules "m m2" } } |