diff options
24 files changed, 1138 insertions, 131 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8fb7318..31f1f82 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,82 @@ +2005-12-22 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/20889 + *resolve.c(resolve_structure_cons): Do not attempt to convert + the type of mismatched pointer type components, except when + the constructor component is BT_UNKNOWN; emit error instead. + + PR fortran/25029 + PR fortran/21256 + *resolve.c(check_assumed_size_reference): New function to check for upper + bound in assumed size array references. + (resolve_assumed_size_actual): New function to do a very restricted scan + of actual argument expressions of those procedures for which incomplete + assumed size array references are not allowed. + (resolve_function, resolve_call): Switch off assumed size checking of + actual arguments, except for elemental procedures and array valued + intrinsics; excepting LBOUND. + (resolve_variable): Call check_assumed_size_reference. + + PR fortran/19362 + PR fortran/20244 + PR fortran/20864 + PR fortran/25391 + *interface.c(gfc_compare_types): Broken into two. + (gfc_compare_derived_types): Second half of gfc_compare_types with + corrections for a missing check that module name is non-NULL and + a check for private components. + *symbol.c(gfc_free_dt_list): New function. + (gfc_free_namespace): Call gfc_free_dt_list. + *resolve.c(resolve_symbol): Build the list of derived types in the + symbols namespace. + *gfortran.h: Define the structure type gfc_dt_list. Add a new field, + derived_types to gfc_namespace. Provide a prototye for the new + function gfc_compare_derived_types. + *trans_types.c(gfc_get_derived_type): Test for the derived type being + available in the host namespace. In this case, the host backend + declaration is used for the structure and its components. If an + unbuilt, equal structure that is not use associated is found in the + host namespace, build it there and then. On exit,traverse the + namespace of the derived type to see if there are equal but unbuilt. + If so, copy the structure and its component declarations. + (copy_dt_decls_ifequal): New functions to copy declarations to other + equal structure types. + + PR fortran/20862 + * io.c (gfc_match_format): Make the appearance of a format statement + in a module specification block an error. + + PR fortran/23152 + * match.c (gfc_match_namelist): Set assumed shape arrays in + namelists as std=GFC_STD_GNU and assumed size arrays as an + unconditional error. + + PR fortran/25069 + * match.c (gfc_match_namelist): Set the respecification of a USE + associated namelist group as std=GFC_STD_GNU. Permit the concatenation + on no error. + + PR fortran/25053 + PR fortran/25063 + PR fortran/25064 + PR fortran/25066 + PR fortran/25067 + PR fortran/25068 + PR fortran/25307 + * io.c (resolve_tag): Change std on IOSTAT != default integer to + GFC_STD_GNU and change message accordingly. Add same error for + SIZE. + (match_dt_element, gfortran.h): Add field err_where to gfc_dt and + set it when tags are being matched. + (gfc_resolve_dt): Remove tests that can be done before resolution + and add some of the new ones here. + (check_io_constraints): New function that checks for most of the + data transfer constraints. Some of these were previously done in + match_io, from where this function is called, and some were done + in gfc_resolve_dt. + (match_io): Remove most of the tests of constraints and add the + call to check_io_constraints. + 2005-12-21 Erik Edelmann <eedelman@gcc.gnu.org> PR fortran/25423 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7d0c725..475b0ca 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -833,6 +833,16 @@ typedef struct gfc_symtree } gfc_symtree; +/* A linked list of derived types in the namespace. */ +typedef struct gfc_dt_list +{ + struct gfc_symbol *derived; + struct gfc_dt_list *next; +} +gfc_dt_list; + +#define gfc_get_dt_list() gfc_getmem(sizeof(gfc_dt_list)) + /* A namespace describes the contents of procedure, module or interface block. */ @@ -892,6 +902,9 @@ typedef struct gfc_namespace /* A list of all alternate entry points to this procedure (or NULL). */ gfc_entry_list *entries; + /* A list of all derived types in this procedure (or NULL). */ + gfc_dt_list *derived_types; + /* Set to 1 if namespace is a BLOCK DATA program unit. */ int is_block_data; } @@ -1356,7 +1369,7 @@ typedef struct gfc_st_label *format_label; gfc_st_label *err, *end, *eor; - locus eor_where, end_where; + locus eor_where, end_where, err_where; } gfc_dt; @@ -1895,6 +1908,7 @@ int gfc_is_compile_time_shape (gfc_array_spec *); /* interface.c -- FIXME: some of these should be in symbol.c */ void gfc_free_interface (gfc_interface *); +int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_types (gfc_typespec *, gfc_typespec *); void gfc_check_interfaces (gfc_namespace *); void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5dc6944..b58fb83 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -320,43 +320,39 @@ gfc_match_end_interface (void) } -/* Compare two typespecs, recursively if necessary. */ +/* Compare two derived types using the criteria in 4.4.2 of the standard, + recursing through gfc_compare_types for the components. */ int -gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2) +gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2) { gfc_component *dt1, *dt2; - if (ts1->type != ts2->type) - return 0; - if (ts1->type != BT_DERIVED) - return (ts1->kind == ts2->kind); - - /* Compare derived types. */ - if (ts1->derived == ts2->derived) - return 1; - /* Special case for comparing derived types across namespaces. If the true names and module names are the same and the module name is nonnull, then they are equal. */ - if (strcmp (ts1->derived->name, ts2->derived->name) == 0 - && ((ts1->derived->module == NULL && ts2->derived->module == NULL) - || (ts1->derived != NULL && ts2->derived != NULL - && strcmp (ts1->derived->module, ts2->derived->module) == 0))) + if (strcmp (derived1->name, derived2->name) == 0 + && derived1 != NULL && derived2 != NULL + && derived1->module != NULL && derived2->module != NULL + && strcmp (derived1->module, derived2->module) == 0) return 1; /* Compare type via the rules of the standard. Both types must have the SEQUENCE attribute to be equal. */ - if (strcmp (ts1->derived->name, ts2->derived->name)) + if (strcmp (derived1->name, derived2->name)) return 0; - dt1 = ts1->derived->components; - dt2 = ts2->derived->components; + if (derived1->component_access == ACCESS_PRIVATE + || derived2->component_access == ACCESS_PRIVATE) + return 0; - if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0) + if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0) return 0; + dt1 = derived1->components; + dt2 = derived2->components; + /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a simple test can speed things up. Otherwise, lots of things have to match. */ @@ -389,6 +385,24 @@ gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2) return 1; } +/* Compare two typespecs, recursively if necessary. */ + +int +gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2) +{ + + if (ts1->type != ts2->type) + return 0; + if (ts1->type != BT_DERIVED) + return (ts1->kind == ts2->kind); + + /* Compare derived types. */ + if (ts1->derived == ts2->derived) + return 1; + + return gfc_compare_derived_types (ts1->derived ,ts2->derived); +} + /* Given two symbols that are formal arguments, compare their ranks and types. Returns nonzero if they have the same rank and type, diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 23c1cb2..7ca000a 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -816,6 +816,13 @@ gfc_match_format (void) gfc_expr *e; locus start; + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) + { + gfc_error ("Format statement in module main block at %C."); + return MATCH_ERROR; + } + if (gfc_statement_label == NULL) { gfc_error ("Missing format label at %C"); @@ -1056,8 +1063,16 @@ resolve_tag (const io_tag * tag, gfc_expr * e) if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Non-default " - "integer kind in IOSTAT tag at %L", + if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default " + "INTEGER in IOSTAT tag at %L", + &e->where) == FAILURE) + return FAILURE; + } + + if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind) + { + if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default " + "INTEGER in SIZE tag at %L", &e->where) == FAILURE) return FAILURE; } @@ -1728,6 +1743,8 @@ match_dt_element (io_kind k, gfc_dt * dt) if (m != MATCH_NO) return m; m = match_ltag (&tag_err, &dt->err); + if (m == MATCH_YES) + dt->err_where = gfc_current_locus; if (m != MATCH_NO) return m; m = match_etag (&tag_advance, &dt->advance); @@ -1807,7 +1824,6 @@ gfc_resolve_dt (gfc_dt * dt) return FAILURE; } - /* Sanity checks on data transfer statements. */ if (e->ts.type == BT_CHARACTER) { if (gfc_has_vector_index (e)) @@ -1816,85 +1832,50 @@ gfc_resolve_dt (gfc_dt * dt) &e->where); return FAILURE; } + } - if (dt->rec != NULL) - { - gfc_error ("REC tag at %L is incompatible with internal file", - &dt->rec->where); - return FAILURE; - } - - if (dt->namelist != NULL) - { - gfc_error ("Internal file at %L is incompatible with namelist", - &dt->io_unit->where); - return FAILURE; - } - - if (dt->advance != NULL) - { - gfc_error ("ADVANCE tag at %L is incompatible with internal file", - &dt->advance->where); - return FAILURE; - } + if (e->rank && e->ts.type != BT_CHARACTER) + { + gfc_error ("External IO UNIT cannot be an array at %L", &e->where); + return FAILURE; } - if (dt->rec != NULL) + if (dt->err) { - if (dt->end != NULL) + if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + if (dt->err->defined == ST_LABEL_UNKNOWN) { - gfc_error ("REC tag at %L is incompatible with END tag", - &dt->rec->where); + gfc_error ("ERR tag label %d at %L not defined", + dt->err->value, &dt->err_where); return FAILURE; } + } - if (dt->format_label == &format_asterisk) + if (dt->end) + { + if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + if (dt->end->defined == ST_LABEL_UNKNOWN) { - gfc_error - ("END tag at %L is incompatible with list directed format (*)", - &dt->end_where); + gfc_error ("END tag label %d at %L not defined", + dt->end->value, &dt->end_where); return FAILURE; } + } - if (dt->namelist != NULL) + if (dt->eor) + { + if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + if (dt->eor->defined == ST_LABEL_UNKNOWN) { - gfc_error ("REC tag at %L is incompatible with namelist", - &dt->rec->where); + gfc_error ("EOR tag label %d at %L not defined", + dt->eor->value, &dt->eor_where); return FAILURE; } } - if (dt->advance != NULL && dt->format_label == &format_asterisk) - { - gfc_error ("ADVANCE tag at %L is incompatible with list directed " - "format (*)", &dt->advance->where); - return FAILURE; - } - - if (dt->eor != 0 && dt->advance == NULL) - { - gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt->eor_where); - return FAILURE; - } - - if (dt->size != NULL && dt->advance == NULL) - { - gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt->size->where); - return FAILURE; - } - - /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string - constant. */ - - if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE) - return FAILURE; - - if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE) - return FAILURE; - - if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE) - return FAILURE; - /* Check the format label actually exists. */ if (dt->format_label && dt->format_label != &format_asterisk && dt->format_label->defined == ST_LABEL_UNKNOWN) @@ -2181,6 +2162,165 @@ terminate_io (gfc_code * io_code) } +/* Check the constraints for a data transfer statement. The majority of the + constraints appearing in 9.4 of the standard appear here. Some are handled + in resolve_tag and others in gfc_resolve_dt. */ + +static match +check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end) +{ +#define io_constraint(condition,msg,arg)\ +if (condition) \ + {\ + gfc_error(msg,arg);\ + m = MATCH_ERROR;\ + } + + match m; + gfc_expr * expr; + gfc_symbol * sym = NULL; + + m = MATCH_YES; + + expr = dt->io_unit; + if (expr && expr->expr_type == EXPR_VARIABLE + && expr->ts.type == BT_CHARACTER) + { + sym = expr->symtree->n.sym; + + io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN, + "Internal file at %L must not be INTENT(IN)", + &expr->where); + + io_constraint (gfc_has_vector_index (dt->io_unit), + "Internal file incompatible with vector subscript at %L", + &expr->where); + + io_constraint (dt->rec != NULL, + "REC tag at %L is incompatible with internal file", + &dt->rec->where); + + io_constraint (dt->namelist != NULL, + "Internal file at %L is incompatible with namelist", + &expr->where); + + io_constraint (dt->advance != NULL, + "ADVANCE tag at %L is incompatible with internal file", + &dt->advance->where); + } + + if (expr && expr->ts.type != BT_CHARACTER) + { + + io_constraint (gfc_pure (NULL) + && (k == M_READ || k == M_WRITE), + "IO UNIT in %s statement at %C must be " + "an internal file in a PURE procedure", + io_kind_name (k)); + } + + + if (k != M_READ) + { + io_constraint (dt->end, + "END tag not allowed with output at %L", + &dt->end_where); + + io_constraint (dt->eor, + "EOR tag not allowed with output at %L", + &dt->eor_where); + + io_constraint (k != M_READ && dt->size, + "SIZE=specifier not allowed with output at %L", + &dt->size->where); + } + else + { + io_constraint (dt->size && dt->advance == NULL, + "SIZE tag at %L requires an ADVANCE tag", + &dt->size->where); + + io_constraint (dt->eor && dt->advance == NULL, + "EOR tag at %L requires an ADVANCE tag", + &dt->eor_where); + } + + + + if (dt->namelist) + { + io_constraint (io_code && dt->namelist, + "NAMELIST cannot be followed by IO-list at %L", + &io_code->loc); + + io_constraint (dt->format_expr, + "IO spec-list cannot contain both NAMELIST group name " + "and format specification at %L.", + &dt->format_expr->where); + + io_constraint (dt->format_label, + "IO spec-list cannot contain both NAMELIST group name " + "and format label at %L", spec_end); + + io_constraint (dt->rec, + "NAMELIST IO is not allowed with a REC=specifier " + "at %L.", &dt->rec->where); + + io_constraint (dt->advance, + "NAMELIST IO is not allowed with a ADVANCE=specifier " + "at %L.", &dt->advance->where); + } + + if (dt->rec) + { + io_constraint (dt->end, + "An END tag is not allowed with a " + "REC=specifier at %L.", &dt->end_where); + + + io_constraint (dt->format_label == &format_asterisk, + "FMT=* is not allowed with a REC=specifier " + "at %L.", spec_end); + } + + if (dt->advance) + { + const char * advance; + int not_yes, not_no; + expr = dt->advance; + advance = expr->value.character.string; + + io_constraint (dt->format_label == &format_asterisk, + "List directed format(*) is not allowed with a " + "ADVANCE=specifier at %L.", &expr->where); + + not_no = strncasecmp (advance, "no", 2) != 0; + not_yes = strncasecmp (advance, "yes", 2) != 0; + + io_constraint (expr->expr_type == EXPR_CONSTANT + && not_no && not_yes, + "ADVANCE=specifier at %L must have value = " + "YES or NO.", &expr->where); + + io_constraint (dt->size && expr->expr_type == EXPR_CONSTANT + && not_no && k == M_READ, + "SIZE tag at %L requires an ADVANCE = 'NO'", + &dt->size->where); + + io_constraint (dt->eor && expr->expr_type == EXPR_CONSTANT + && not_no && k == M_READ, + "EOR tag at %L requires an ADVANCE = 'NO'", + &dt->eor_where); + } + + expr = dt->format_expr; + if (expr != NULL && expr->expr_type == EXPR_CONSTANT) + check_format_string (expr); + + return m; +} +#undef io_constraint + /* Match a READ, WRITE or PRINT statement. */ static match @@ -2189,12 +2329,13 @@ match_io (io_kind k) char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_code *io_code; gfc_symbol *sym; - gfc_expr *expr; int comma_flag, c; locus where; + locus spec_end; gfc_dt *dt; match m; + where = gfc_current_locus; comma_flag = 0; current_dt = dt = gfc_getmem (sizeof (gfc_dt)); if (gfc_match_char ('(') == MATCH_NO) @@ -2217,12 +2358,6 @@ match_io (io_kind k) m = MATCH_ERROR; goto cleanup; } - if (gfc_match_eos () == MATCH_NO) - { - gfc_error ("Namelist followed by I/O list at %C"); - m = MATCH_ERROR; - goto cleanup; - } dt->io_unit = default_unit (k); dt->namelist = sym; @@ -2321,6 +2456,10 @@ loop: } get_io_list: + + /* Used in check_io_constraints, where no locus is available. */ + spec_end = gfc_current_locus; + /* Optional leading comma (non-standard). */ if (!comma_flag && gfc_match_char (',') == MATCH_YES @@ -2346,33 +2485,12 @@ get_io_list: goto syntax; } - /* A full IO statement has been matched. */ - if (dt->io_unit->expr_type == EXPR_VARIABLE - && k == M_WRITE - && dt->io_unit->ts.type == BT_CHARACTER - && dt->io_unit->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("Internal file '%s' at %L is INTENT(IN)", - dt->io_unit->symtree->n.sym->name, &dt->io_unit->where); - m = MATCH_ERROR; - goto cleanup; - } - - expr = dt->format_expr; + /* A full IO statement has been matched. Check the constraints. spec_end is + supplied for cases where no locus is supplied. */ + m = check_io_constraints (k, dt, io_code, &spec_end); - if (expr != NULL && expr->expr_type == EXPR_CONSTANT) - check_format_string (expr); - - if (gfc_pure (NULL) - && (k == M_READ || k == M_WRITE) - && dt->io_unit->ts.type != BT_CHARACTER) - { - gfc_error - ("io-unit in %s statement at %C must be an internal file in a " - "PURE procedure", io_kind_name (k)); - m = MATCH_ERROR; - goto cleanup; - } + if (m == MATCH_ERROR) + goto cleanup; new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; new_st.ext.dt = dt; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 501a091..e28127b 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2503,6 +2503,14 @@ gfc_match_namelist (void) return MATCH_ERROR; } + if (group_name->attr.flavor == FL_NAMELIST + && group_name->attr.use_assoc + && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' " + "at %C already is USE associated and can" + "not be respecified.", group_name->name) + == FAILURE) + return MATCH_ERROR; + if (group_name->attr.flavor != FL_NAMELIST && gfc_add_flavor (&group_name->attr, FL_NAMELIST, group_name->name, NULL) == FAILURE) @@ -2520,6 +2528,21 @@ gfc_match_namelist (void) && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE) goto error; + /* Use gfc_error_check here, rather than goto error, so that this + these are the only errors for the next two lines. */ + if (sym->as && sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Assumed size array '%s' in namelist '%s'at " + "%C is not allowed.", sym->name, group_name->name); + gfc_error_check (); + } + + if (sym->as && sym->as->type == AS_ASSUMED_SHAPE + && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in " + "namelist '%s' at %C is an extension.", + sym->name, group_name->name) == FAILURE) + gfc_error_check (); + nl = gfc_get_namelist (); nl->sym = sym; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index de2da63..5ba4c8e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -588,9 +588,18 @@ resolve_structure_cons (gfc_expr * expr) /* If we don't have the right type, try to convert it. */ - if (!gfc_compare_types (&cons->expr->ts, &comp->ts) - && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE) - t = FAILURE; + if (!gfc_compare_types (&cons->expr->ts, &comp->ts)) + { + t = FAILURE; + if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN) + gfc_error ("The element in the derived type constructor at %L, " + "for pointer component '%s', is %s but should be %s", + &cons->expr->where, comp->name, + gfc_basic_typename (cons->expr->ts.type), + gfc_basic_typename (comp->ts.type)); + else + t = gfc_convert_type (cons->expr, &comp->ts, 1); + } } return t; @@ -686,6 +695,68 @@ procedure_kind (gfc_symbol * sym) return PTYPE_UNKNOWN; } +/* Check references to assumed size arrays. The flag need_full_assumed_size + is zero when matching actual arguments. */ + +static int need_full_assumed_size = 1; + +static int +check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e) +{ + gfc_ref * ref; + int dim; + int last = 1; + + if (!need_full_assumed_size + || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) + return 0; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + for (dim = 0; dim < ref->u.ar.as->rank; dim++) + last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT); + + if (last) + { + gfc_error ("The upper bound in the last dimension must " + "appear in the reference to the assumed size " + "array '%s' at %L.", sym->name, &e->where); + return 1; + } + return 0; +} + + +/* Look for bad assumed size array references in argument expressions + of elemental and array valued intrinsic procedures. Since this is + called from procedure resolution functions, it only recurses at + operators. */ +static bool +resolve_assumed_size_actual (gfc_expr *e) +{ + if (e == NULL) + return false; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + if (e->symtree + && check_assumed_size_reference (e->symtree->n.sym, e)) + return true; + break; + + case EXPR_OP: + if (resolve_assumed_size_actual (e->value.op.op1) + || resolve_assumed_size_actual (e->value.op.op2)) + return true; + break; + + default: + break; + } + return false; +} + /* Resolve an actual argument list. Most of the time, this is just resolving the expressions in the list. @@ -1083,9 +1154,16 @@ resolve_function (gfc_expr * expr) const char *name; try t; + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size = 0; + if (resolve_actual_arglist (expr->value.function.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size = 1; + /* See if function is already resolved. */ if (expr->value.function.name != NULL) @@ -1129,7 +1207,6 @@ resolve_function (gfc_expr * expr) || (expr->value.function.isym != NULL && expr->value.function.isym->elemental))) { - /* The rank of an elemental is the rank of its array argument(s). */ for (arg = expr->value.function.actual; arg; arg = arg->next) @@ -1140,6 +1217,31 @@ resolve_function (gfc_expr * expr) break; } } + + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } + } + + else if (expr->value.function.actual != NULL + && expr->value.function.isym != NULL + && strcmp (expr->value.function.isym->name, "lbound")) + { + /* Array instrinsics must also have the last upper bound of an + asumed size array argument. */ + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } } if (!pure_function (expr, &name)) @@ -1381,9 +1483,17 @@ resolve_call (gfc_code * c) { try t; + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size = 0; + if (resolve_actual_arglist (c->ext.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size = 1; + + t = SUCCESS; if (c->resolved_sym == NULL) switch (procedure_kind (c->symtree->n.sym)) @@ -1404,6 +1514,21 @@ resolve_call (gfc_code * c) gfc_internal_error ("resolve_subroutine(): bad function type"); } + if (c->ext.actual != NULL + && c->symtree->n.sym->attr.elemental) + { + gfc_actual_arglist * a; + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (a = c->ext.actual; a; a = a->next) + { + if (a->expr != NULL + && a->expr->rank > 0 + && resolve_assumed_size_actual (a->expr)) + return FAILURE; + } + } + if (t == SUCCESS) find_noncopying_intrinsics (c->resolved_sym, c->ext.actual); return t; @@ -2330,6 +2455,9 @@ resolve_variable (gfc_expr * e) e->ts = sym->ts; } + if (check_assumed_size_reference (sym, e)) + return FAILURE; + return SUCCESS; } @@ -4580,6 +4708,17 @@ resolve_symbol (gfc_symbol * sym) } break; + case FL_DERIVED: + /* Add derived type to the derived type list. */ + { + gfc_dt_list * dt_list; + dt_list = gfc_get_dt_list (); + dt_list->next = sym->ns->derived_types; + dt_list->derived = sym; + sym->ns->derived_types = dt_list; + } + break; + default: /* An external symbol falls through to here if it is not referenced. */ diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 20fb747..bda1c1d 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2307,6 +2307,21 @@ free_sym_tree (gfc_symtree * sym_tree) } +/* Free a derived type list. */ + +static void +gfc_free_dt_list (gfc_dt_list * dt) +{ + gfc_dt_list *n; + + for (; dt; dt = n) + { + n = dt->next; + gfc_free (dt); + } +} + + /* Free a namespace structure and everything below it. Interface lists associated with intrinsic operators are not freed. These are taken care of when a specific name is freed. */ @@ -2343,6 +2358,8 @@ gfc_free_namespace (gfc_namespace * ns) gfc_free_equiv (ns->equiv); + gfc_free_dt_list (ns->derived_types); + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) gfc_free_interface (ns->operator[i]); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 6aaf81a..4e6b74e 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1395,13 +1395,44 @@ gfc_add_field_to_struct (tree *fieldlist, tree context, } -/* Build a tree node for a derived type. */ +/* Copy the backend_decl and component backend_decls if + the two derived type symbols are "equal", as described + in 4.4.2 and resolved by gfc_compare_derived_types. */ + +static int +copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to) +{ + gfc_component *to_cm; + gfc_component *from_cm; + + if (from->backend_decl == NULL + || !gfc_compare_derived_types (from, to)) + return 0; + + to->backend_decl = from->backend_decl; + + to_cm = to->components; + from_cm = from->components; + + for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) + to_cm->backend_decl = from_cm->backend_decl; + + return 1; +} + + +/* Build a tree node for a derived type. If there are equal + derived types, with different local names, these are built + at the same time. If an equal derived type has been built + in a parent namespace, this is used. */ static tree gfc_get_derived_type (gfc_symbol * derived) { tree typenode, field, field_type, fieldlist; gfc_component *c; + gfc_dt_list *dt; + gfc_namespace * ns; gcc_assert (derived && derived->attr.flavor == FL_DERIVED); @@ -1417,6 +1448,29 @@ gfc_get_derived_type (gfc_symbol * derived) } else { + /* In a module, if an equal derived type is already available in the + specification block, use its backend declaration and those of its + components, rather than building anew so that potential dummy and + actual arguments use the same TREE_TYPE. Non-module structures, + need to be built, if found, because the order of visits to the + namespaces is different. */ + + for (ns = derived->ns->parent; ns; ns = ns->parent) + { + for (dt = ns->derived_types; dt; dt = dt->next) + { + if (derived->module == NULL + && dt->derived->backend_decl == NULL + && gfc_compare_derived_types (dt->derived, derived)) + gfc_get_derived_type (dt->derived); + + if (copy_dt_decls_ifequal (dt->derived, derived)) + break; + } + if (derived->backend_decl) + goto other_equal_dts; + } + /* We see this derived type first time, so build the type node. */ typenode = make_node (RECORD_TYPE); TYPE_NAME (typenode) = get_identifier (derived->name); @@ -1495,9 +1549,16 @@ gfc_get_derived_type (gfc_symbol * derived) derived->backend_decl = typenode; - return typenode; +other_equal_dts: + /* Add this backend_decl to all the other, equal derived types and + their components in this namespace. */ + for (dt = derived->ns->derived_types; dt; dt = dt->next) + copy_dt_decls_ifequal (derived, dt->derived); + + return derived->backend_decl; } - + + int gfc_return_by_reference (gfc_symbol * sym) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index acfd2c8..d7eb3eb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,45 @@ +2005-12-22 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/20889 + *gfortran.dg/pointer_component_type_1.f90: New test. + + PR fortran/25029 + PR fortran/21256 + *gfortran.dg/assumed_size_refs.f90: New test for the conditions that + should give an error with assumed size array refernces and checks those + that should not. + *gfortran.dg/gfortran.dg/pr15140.f90: Give the assumed size array + reference an upper bound so that it does not generate an error. + + PR fortran/19362 + PR fortran/20244 + PR fortran/20864 + PR fortran/25391 + *gfortran.dg/used_dummy_types_1.f90: New test. + *gfortran.dg/used_dummy_types_2.f90: New test. + *gfortran.dg/used_dummy_types_3.f90: New test. + *gfortran.dg/used_dummy_types_4.f90: New test. + *gfortran.dg/used_dummy_types_5.f90: New test. + + PR fortran/23152 + *gfortran.dg/namelist_use.f90: Add trap for warning on NAMELIST + group already being USE associated. + *gfortran.dg/assumed_shape_nml.f90: New test. + *gfortran.dg/assumed_size_nml.f90: New test. + + PR fortran/20862 + PR fortran/25053 + PR fortran/25063 + PR fortran/25064 + PR fortran/25066 + PR fortran/25067 + PR fortran/25068 + PR fortran/25307 + * gfortran.dg/io_constraints_1.f90: New test. + * gfortran.dg/io_constraints_1.f90: New test. + * gfortran.dg/iostat_3.f90: Change wording of warning. + * gfortran.dg/g77/19981216-0.f: the same. + 2005-12-22 Kazu Hirata <kazu@codesourcery.com> PR tree-optimization/23518 diff --git a/gcc/testsuite/gfortran.dg/assumed_shape_nml.f90 b/gcc/testsuite/gfortran.dg/assumed_shape_nml.f90 new file mode 100644 index 0000000..c2a8808 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_shape_nml.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! One of two tests for the fix of PR23152 - There used to be +! no warning for assumed shape arrays in namelists. +! +! Conributed by Paul Thomas <pault@gcc.gnu.org> +! +program assumed_shape_nml + real, dimension (10) :: z + z = 42.0 + call foo (z) +contains + subroutine foo (y) + real, DIMENSION (1:) :: y + namelist /mynml/ y ! { dg-warning "is an extension" } + write (*, mynml) + end subroutine foo +end program assumed_shape_nml diff --git a/gcc/testsuite/gfortran.dg/assumed_size_nml.f90 b/gcc/testsuite/gfortran.dg/assumed_size_nml.f90 new file mode 100644 index 0000000..76d5148 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_size_nml.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! One of two tests for the fix of PR23152 - An ICE would +! ensue from assumed shape arrays in namelists. +! +! Conributed by Paul Thomas <pault@gcc.gnu.org> +! +program assumed_size_nml + real, dimension (10) :: z + z = 42.0 + call foo (z) +contains + subroutine foo (y) + real, DIMENSION (*) :: y + namelist /mynml/ y ! { dg-error "is not allowed" } + write (6, mynml) + end subroutine foo +end program assumed_size_nml
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/g77/19981216-0.f b/gcc/testsuite/gfortran.dg/g77/19981216-0.f index 118c321..5920ddf 100644 --- a/gcc/testsuite/gfortran.dg/g77/19981216-0.f +++ b/gcc/testsuite/gfortran.dg/g77/19981216-0.f @@ -29,7 +29,7 @@ c { dg-do compile } name = 'blah' open(unit=8,status='unknown',file=name,form='formatted', - F iostat=ios) ! { dg-warning "integer kind in IOSTAT" } + F iostat=ios) ! { dg-warning "INTEGER in IOSTAT" } END * ------------------------------------------- diff --git a/gcc/testsuite/gfortran.dg/initialization_1.f90 b/gcc/testsuite/gfortran.dg/initialization_1.f90 index f131459..3ce6b10 100644 --- a/gcc/testsuite/gfortran.dg/initialization_1.f90 +++ b/gcc/testsuite/gfortran.dg/initialization_1.f90 @@ -29,7 +29,6 @@ contains integer :: m2(2) = shape (x) ! { dg-error "assumed size array" } ! These are warnings because they are gfortran extensions. - integer :: m3 = size (x, 1) ! { dg-warning "Evaluation of nonstandard initialization" } integer :: m4(2) = shape (z) ! { dg-warning "Evaluation of nonstandard initialization" } ! This does not depend on non-constant properties. diff --git a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 new file mode 100644 index 0000000..fa4c973 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 @@ -0,0 +1,78 @@ +! { dg-do compile } +! Part I of the test of the IO constraints patch, which fixes PRs: +! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +! +module fails + + 2000 format (1h , 2i6) ! { dg-error "Format statement in module" } + +end module fails + +module global + + integer :: modvar + namelist /NL/ modvar + +contains + + subroutine foo (i) + integer :: i + write (*, 100) i + 100 format (1h , "i=", i6) ! This is OK. + end subroutine foo + +end module global + + use global + integer :: a,b, c(20) + integer(8) :: ierr + character*80 :: buffer(3) + +! Appending to a USE associated namelist is an extension. + + NAMELIST /NL/ a,b ! { dg-warning "already is USE associated" } + + a=1 ; b=2 + +!9.2.2.1: + write(c, *) a, b ! { dg-error "array" } +!Was correctly picked up before patch. + write(buffer((/3,1,2/)), *) a, b ! { dg-error "vector subscript" } + +!9.2.2.2 and one of 9.4.1 +!________________________ + + write(6, NML=NL, FMT = '(i6)') ! { dg-error "group name and format" } + write(6, NML=NL, FMT = 200) ! { dg-error "group name and format" } + +!9.4.1 +!_____ +! + +! R912 +!Was correctly picked up before patch. + write(6, NML=NL, iostat = ierr) ! { dg-warning "requires default INTEGER" } + READ(1, fmt='(i6)', advance='NO', size = ierr) ! { dg-warning "requires default INTEGER" } + +! Constraints +!Was correctly picked up before patch. + write(1, fmt='(i6)', end = 100) a ! { dg-error "END tag" } +!Was correctly picked up before patch. + write(1, fmt='(i6)', eor = 100) a ! { dg-error "EOR tag" } +!Was correctly picked up before patch. + write(1, fmt='(i6)', size = b) a ! { dg-error "SIZE=specifier not allowed" } + + + READ(1, fmt='(i6)', end = 900) a ! { dg-error "not defined" } + READ(1, fmt='(i6)', eor = 900, advance='NO') a ! { dg-error "not defined" } + READ(1, fmt='(i6)', ERR = 900) a ! { dg-error "not defined" } + +!Was correctly picked up before patch. + READ(1, fmt=800) a ! { dg-error "not defined" } + + +100 continue +200 format (2i6) + END diff --git a/gcc/testsuite/gfortran.dg/io_constraints_2.f90 b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 new file mode 100644 index 0000000..8100a4d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! Part II of the test of the IO constraints patch, which fixes PRs: +! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +! + +module global + + integer :: modvar + namelist /NL/ modvar + +contains + + subroutine foo (i) + integer :: i + write (*, 100) i + 100 format (1h , "i=", i6) ! This is OK. + end subroutine foo + +end module global + + use global + integer :: a,b, c(20) + integer(8) :: ierr + character*80 :: buffer(3) + + +! Appending to a USE associated namelist is an extension. + + NAMELIST /NL/ a,b ! { dg-warning "already is USE associated" } + + a=1 ; b=2 + + write(*, NML=NL) z ! { dg-error "followed by IO-list" } +!Was correctly picked up before patch. + print NL, z ! { dg-error "followed by IO-list" } +! +! Not allowed with internal unit +!Was correctly picked up before patch. + write(buffer, NML=NL) ! { dg-error "incompatible with namelist" } +!Was correctly picked up before patch. + write(buffer, fmt='(i6)', REC=10) a ! { dg-error "REC tag" } + write(buffer, fmt='(i6)', END=10) a ! { dg-error "END tag" } + +! Not allowed with REC= specifier +!Was correctly picked up before patch. + read(10, REC=10, END=100) ! { dg-error "END tag is not allowed" } + write(*, *, REC=10) ! { dg-error "FMT=" } + +! Not allowed with an ADVANCE=specifier + READ(buffer, fmt='(i6)', advance='YES') a ! { dg-error "internal file" } + READ(1, NML=NL, advance='YES') ! { dg-error "NAMELIST IO is not allowed" } + + write(1, fmt='(i6)', advance='YES', size = c(1)) a ! { dg-error "output" } + write(1, fmt='(i6)', advance='YES', eor = 100) a ! { dg-error "output" } + + read(1, fmt='(i6)', advance='YES', size = c(1)) a ! { dg-error "ADVANCE = 'NO'" } + read(1, fmt='(i6)', advance='YES', eor = 100) a ! { dg-error "ADVANCE = 'NO'" } + + READ(1, fmt='(i6)', advance='NO', size = buffer) a ! { dg-error "INTEGER" } +!Was correctly picked up before patch. -correct syntax error + READ(1, fmt='(i6)', advance='YES', size = 10) a ! { dg-error "Syntax error" } + + READ(1, fmt='(i6)', advance='MAYBE') ! { dg-error "YES or NO" } + +100 continue +200 format (2i6) + END diff --git a/gcc/testsuite/gfortran.dg/iostat_3.f90 b/gcc/testsuite/gfortran.dg/iostat_3.f90 index db9547b..1dc72d1 100644 --- a/gcc/testsuite/gfortran.dg/iostat_3.f90 +++ b/gcc/testsuite/gfortran.dg/iostat_3.f90 @@ -3,6 +3,6 @@ real :: u integer(kind=8) :: i open (10,status="scratch") - read (10,*,iostat=i) u ! { dg-warning "Fortran 2003: Non-default integer kind in IOSTAT tag" } - close (10,iostat=i) ! { dg-warning "Fortran 2003: Non-default integer kind in IOSTAT tag" } + read (10,*,iostat=i) u ! { dg-warning "Fortran 95 requires default INTEGER in IOSTAT tag" } + close (10,iostat=i) ! { dg-warning "Fortran 95 requires default INTEGER in IOSTAT tag" } end diff --git a/gcc/testsuite/gfortran.dg/namelist_use.f90 b/gcc/testsuite/gfortran.dg/namelist_use.f90 index 871e529..6d5cf80 100644 --- a/gcc/testsuite/gfortran.dg/namelist_use.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_use.f90 @@ -15,7 +15,8 @@ end module global program namelist_use use global real :: rrr - namelist /nml2/ ii, rrr ! Concatenate use and host associated variables. +! Concatenate use and host associated variables - an extension. + namelist /nml2/ ii, rrr ! { dg-warning "already is USE associated" } open (10, status="scratch") write (10,*) "&NML1 aa='lmno' ii=1 rr=2.5 /" write (10,*) "&NML2 aa='pqrs' ii=2 rrr=3.5 /" diff --git a/gcc/testsuite/gfortran.dg/pointer_component_type_1.f90 b/gcc/testsuite/gfortran.dg/pointer_component_type_1.f90 new file mode 100644 index 0000000..b3a4086 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_component_type_1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! This checks the fix for PR20889 in wrong pointer types in derived +! type constructors would either give no message or would segfault. +! +! Contributed by Joost VandVondele <jv244@cam.ac.uk> +!============== + TYPE TEST + REAL, POINTER :: A + END TYPE + + TYPE TEST1 + REAL :: A + END TYPE + + INTEGER, POINTER :: IP + real, POINTER :: RP + TYPE(TEST) :: DD + TYPE(TEST1) :: EE +! Next line is the original => gave no warning/error. + DD=TEST(NULL(IP)) ! { dg-error "INTEGER but should be REAL" } +! Would segfault here. + DD=TEST(IP) ! { dg-error "INTEGER but should be REAL" } +! Check right target type is OK. + DD=TEST(NULL(RP)) +! Check non-pointer is OK. + EE= TEST1(1) +! Test attempted conversion from character to real. + EE= TEST1("e") ! { dg-error "convert CHARACTER" } +END
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/pr15140.f90 b/gcc/testsuite/gfortran.dg/pr15140.f90 index 393badc..0f566dc 100644 --- a/gcc/testsuite/gfortran.dg/pr15140.f90 +++ b/gcc/testsuite/gfortran.dg/pr15140.f90 @@ -3,7 +3,7 @@ ! argument of the subroutine directly, but instead use a copy of it. function M(NAMES) CHARACTER*(*) NAMES(*) - if (any(names.ne."asdfg")) call abort + if (any(names(1:2).ne."asdfg")) call abort m = LEN(NAMES(1)) END function M diff --git a/gcc/testsuite/gfortran.dg/used_dummy_types_1.f90 b/gcc/testsuite/gfortran.dg/used_dummy_types_1.f90 new file mode 100644 index 0000000..9d034a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_dummy_types_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! This checks the fix for PR20244 in which USE association +! of derived types would cause an ICE, if the derived type +! was also available by host association. This occurred +! because the backend declarations were different. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +!============== +module mtyp + type t1 + integer::a + end type t1 +end module mtyp +!============== +module atest + use mtyp + type(t1)::ze +contains + subroutine test(ze_in ) + use mtyp + implicit none + type(t1)::ze_in + ze_in = ze + end subroutine test + subroutine init( ) + implicit none + ze = t1 (42) + end subroutine init +end module atest +!============== + use atest + type(t1) :: res = t1 (0) + call init () + call test (res) + if (res%a.ne.42) call abort +end
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/used_dummy_types_2.f90 b/gcc/testsuite/gfortran.dg/used_dummy_types_2.f90 new file mode 100644 index 0000000..f12d286 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_dummy_types_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! This tests that the fix for PR25391 also fixes PR20244. If +! the USE mod1 in subroutine foo were deleted, the code would +! compile fine. With the USE statement, the compiler would +! make new TYPEs for T1 and T2 and bomb out in fold-convert. +! This is a slightly more elaborate test than +! used_dummy_types_1.f90 and came from the PR. +! +! Contributed by Jakub Jelinek <jakubcc.gnu.org> +module mod1 + type t1 + real :: f1 + end type t1 + type t2 + type(t1), pointer :: f2(:) + real, pointer :: f3(:,:) + end type t2 +end module mod1 + +module mod2 + use mod1 + type(t1), pointer, save :: v(:) +contains + subroutine foo (x) + use mod1 + implicit none + type(t2) :: x + integer :: d + d = size (x%f3, 2) + v = x%f2(:) + end subroutine foo +end module mod2 diff --git a/gcc/testsuite/gfortran.dg/used_dummy_types_3.f90 b/gcc/testsuite/gfortran.dg/used_dummy_types_3.f90 new file mode 100644 index 0000000..b252e45 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_dummy_types_3.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! This checks the fix for PR20864 in which same name, USE associated +! derived types from different modules, with private components were +! not recognised to be different. +! +! Contributed by Joost VandVondele <jv244@cam.ac.uk> +!============== + MODULE T1 + TYPE data_type + SEQUENCE + ! private causes the types in T1 and T2 to be different 4.4.2 + PRIVATE + INTEGER :: I + END TYPE + END MODULE + + MODULE T2 + TYPE data_type + SEQUENCE + PRIVATE + INTEGER :: I + END TYPE + + CONTAINS + + SUBROUTINE TEST(x) + TYPE(data_type) :: x + END SUBROUTINE TEST + END MODULE + + USE T1 + USE T2 , ONLY : TEST + TYPE(data_type) :: x + CALL TEST(x) ! { dg-error "Type/rank mismatch in argument" } + END + diff --git a/gcc/testsuite/gfortran.dg/used_dummy_types_4.f90 b/gcc/testsuite/gfortran.dg/used_dummy_types_4.f90 new file mode 100644 index 0000000..98b5905 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_dummy_types_4.f90 @@ -0,0 +1,101 @@ +! { dg-do compile } +! This checks the fix for PR19362 in which types from different scopes +! that are the same, according to 4.4.2, would generate an ICE if one +! were assigned to the other. As well as the test itself, various +! other requirements of 4.4.2 are tested here. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +!============== +module global + + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + + TYPE :: nonseq_type1 + integer :: i + end type nonseq_type1 + type (nonseq_type1) :: ns1 + +end module global + +! Host types with local name != true name + use global, only: seq_type2=>seq_type1, nonseq_type2=>nonseq_type1, ns1 + type (nonseq_type2) :: ns2 + +! Host non-sequence types + type :: different_type + integer :: i + end type different_type + type (different_type) :: dt1 + + type :: same_type + integer :: i + end type same_type + type (same_type) :: st1 + + real :: seq_type1 + +! Provide a reference to dt1. + dt1 = different_type (42) +! These share a type declaration. + ns2 = ns1 +! USE associated seq_type1 is renamed. + seq_type1 = 1.0 + +! These are different. + st1 = dt ! { dg-error "convert REAL" } + + call foo (st1) ! { dg-error "Type/rank mismatch in argument" } + +contains + + subroutine foo (st2) + +! Contained type with local name != true name. +! This is the same as seq_type2 in the host. + use global, only: seq_type3=>seq_type1 + +! This local declaration is the same as seq_type3 and seq_type2. + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + +! Host association of renamed type. + type (seq_type2) :: x +! Locally declared version of the same thing. + type (seq_type1) :: y +! USE associated renamed type. + type (seq_type3) :: z + +! Contained type that is different to that in the host. + type :: different_type + complex :: z + end type different_type + + type :: same_type + integer :: i + end type same_type + + type (different_type) :: b + type (same_type) :: st2 + +! Error because these are not the same. + b = dt1 ! { dg-error "convert TYPE" } + +! Error in spite of the name - these are non-sequence types and are NOT +! the same. + st1 = st2 ! { dg-error "convert TYPE" } + + b%z = (2.0,-1.0) + +! Check that the references that are correct actually work. These test the +! fix for PR19362. + x = seq_type1 (1) + y = x + y = seq_type3 (99) + end subroutine foo +END + diff --git a/gcc/testsuite/gfortran.dg/used_dummy_types_5.f90 b/gcc/testsuite/gfortran.dg/used_dummy_types_5.f90 new file mode 100644 index 0000000..b8b15e0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_dummy_types_5.f90 @@ -0,0 +1,85 @@ +! { dg-do compile } +! This checks that the fix for PR19362 has not broken gfortran +! in respect of.references allowed by 4.4.2. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +!============== +module global + + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + + TYPE :: nonseq_type1 + integer :: i = 44 + end type nonseq_type1 + type (nonseq_type1), save :: ns1 + +end module global + + use global, only: seq_type2=>seq_type1, nonseq_type1, ns1 + +! Host non-sequence types + type :: different_type + integer :: i + end type different_type + + type :: same_type + sequence + integer :: i + end type same_type + + type (seq_type2) :: t1 + type (different_type) :: dt1 + + type (nonseq_type1) :: ns2 + type (same_type) :: st1 + real seq_type1 + + t1 = seq_type2 (42) + dt1 = different_type (43) + ns2 = ns1 + seq_type1 =1.0e32 + st1%i = 45 + + call foo (t1) + +contains + + subroutine foo (x) + + use global, only: seq_type3=>seq_type1 + + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + + type :: different_type + complex :: z + end type different_type + + type :: same_type + sequence + integer :: i + end type same_type +! Host association of renamed type. + type (seq_type2) :: x +! Locally declared version of the same thing. + type (seq_type1) :: y +! USE associated renamed type. + type (seq_type3) :: z + + + type (different_type) :: dt2 + type (same_type) :: st2 + + dt2%z = (2.0,-1.0) + y = seq_type2 (46) + z = seq_type3 (47) + st2 = st1 + print *, x, y, z, dt2, st2, ns2, ns1 + end subroutine foo +END + |