+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
}
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. */
/* 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;
}
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;
/* 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 *);
}
-/* 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. */
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,
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");
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;
}
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);
return FAILURE;
}
- /* Sanity checks on data transfer statements. */
if (e->ts.type == BT_CHARACTER)
{
if (gfc_has_vector_index (e))
&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)
}
+/* 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
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)
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;
}
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
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;
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)
&& 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;
/* 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;
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.
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)
|| (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)
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))
{
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))
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;
e->ts = sym->ts;
}
+ if (check_assumed_size_reference (sym, e))
+ return FAILURE;
+
return SUCCESS;
}
}
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. */
}
+/* 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. */
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]);
}
-/* 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);
}
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);
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;
}
-\f
+
+
int
gfc_return_by_reference (gfc_symbol * sym)
{
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
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
* -------------------------------------------
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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
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
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 /"
--- /dev/null
+! { 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
! 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
projects / thirdparty / gcc.git / commitdiff
