/* Perform type resolution on the various structures.
- Copyright (C) 2001-2018 Free Software Foundation, Inc.
+ Copyright (C) 2001-2020 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
|| sym->attr.entry_master)
return;
+ if (!sym->result)
+ return;
+
/* Try to find out of what the return type is. */
if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
{
}
}
- /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
+ /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
type, lists the only ways a character length value of * can be used:
- dummy arguments of procedures, named constants, and function results
+ dummy arguments of procedures, named constants, function results and
+ in allocate statements if the allocate_object is an assumed length dummy
in external functions. Internal function results and results of module
procedures are not on this list, ergo, not permitted. */
if (sym->attr.dimension)
{
if (el == ns->entries)
- gfc_error ("FUNCTION result %s can't be an array in "
+ gfc_error ("FUNCTION result %s cannot be an array in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
- gfc_error ("ENTRY result %s can't be an array in "
+ gfc_error ("ENTRY result %s cannot be an array in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
}
else if (sym->attr.pointer)
{
if (el == ns->entries)
- gfc_error ("FUNCTION result %s can't be a POINTER in "
+ gfc_error ("FUNCTION result %s cannot be a POINTER in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
else
- gfc_error ("ENTRY result %s can't be a POINTER in "
+ gfc_error ("ENTRY result %s cannot be a POINTER in "
"FUNCTION %s at %L", sym->name,
ns->entries->sym->name, &sym->declared_at);
}
if (sym)
{
if (el == ns->entries)
- gfc_error ("FUNCTION result %s can't be of type %s "
+ gfc_error ("FUNCTION result %s cannot be of type %s "
"in FUNCTION %s at %L", sym->name,
gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
else
- gfc_error ("ENTRY result %s can't be of type %s "
+ gfc_error ("ENTRY result %s cannot be of type %s "
"in FUNCTION %s at %L", sym->name,
gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
have been ignored to continue parsing.
We do the checks again here. */
if (!csym->attr.use_assoc)
- gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
+ {
+ gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
+ gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
+ &common_block->where);
+ }
if (csym->value || csym->attr.data)
{
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->name);
+ gsym = gfc_get_gsymbol (common_root->n.common->name, false);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
+ gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
sym->name, &common_root->n.common->where, &sym->declared_at);
if (sym->attr.external)
- gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
+ gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
sym->name, &common_root->n.common->where);
if (sym->attr.intrinsic)
if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
err, sizeof (err), NULL, NULL))
{
- gfc_error_opt (OPT_Wargument_mismatch,
- "Interface mismatch for procedure-pointer "
+ gfc_error_opt (0, "Interface mismatch for procedure-pointer "
"component %qs in structure constructor at %L:"
" %s", comp->name, &cons->expr->where, err);
return false;
|| gfc_fl_struct (sym->attr.flavor))
return false;
- gcc_assert (sym->attr.flavor == FL_PROCEDURE);
-
/* If we've got an ENTRY, find real procedure. */
if (sym->attr.entry && sym->ns->entries)
proc_sym = sym->ns->entries->sym;
}
+/* Check that name is not a derived type. */
+
+static bool
+is_dt_name (const char *name)
+{
+ gfc_symbol *dt_list, *dt_first;
+
+ dt_list = dt_first = gfc_derived_types;
+ for (; dt_list; dt_list = dt_list->dt_next)
+ {
+ if (strcmp(dt_list->name, name) == 0)
+ return true;
+ if (dt_first == dt_list->dt_next)
+ break;
+ }
+ return false;
+}
+
+
/* Resolve an actual argument list. Most of the time, this is just
resolving the expressions in the list.
The exception is that we sometimes have to decide whether arguments
sym = e->symtree->n.sym;
+ if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
+ {
+ gfc_error ("Derived type %qs is used as an actual "
+ "argument at %L", sym->name, &e->where);
+ goto cleanup;
+ }
+
if (sym->attr.flavor == FL_PROCEDURE
|| sym->attr.intrinsic
|| sym->attr.external)
nothing to do for %REF. */
if (arg->name && arg->name[0] == '%')
{
- if (strncmp ("%VAL", arg->name, 4) == 0)
+ if (strcmp ("%VAL", arg->name) == 0)
{
if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
{
}
/* Statement functions have already been excluded above. */
- else if (strncmp ("%LOC", arg->name, 4) == 0
+ else if (strcmp ("%LOC", arg->name) == 0
&& e->ts.type == BT_PROCEDURE)
{
if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
static void
-resolve_global_procedure (gfc_symbol *sym, locus *where,
- gfc_actual_arglist **actual, int sub)
+resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
{
gfc_gsymbol * gsym;
gfc_namespace *ns;
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
+ gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
+ sym->binding_label != NULL);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
&& gsym->type != GSYM_UNKNOWN
&& !gsym->binding_label
&& gsym->ns
- && gsym->ns->resolved != -1
&& gsym->ns->proc_name
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
gfc_symbol *def_sym;
+ def_sym = gsym->ns->proc_name;
- /* Resolve the gsymbol namespace if needed. */
- if (!gsym->ns->resolved)
+ if (gsym->ns->resolved != -1)
{
- gfc_dt_list *old_dt_list;
- /* Stash away derived types so that the backend_decls do not
- get mixed up. */
- old_dt_list = gfc_derived_types;
- gfc_derived_types = NULL;
+ /* Resolve the gsymbol namespace if needed. */
+ if (!gsym->ns->resolved)
+ {
+ gfc_symbol *old_dt_list;
- gfc_resolve (gsym->ns);
+ /* Stash away derived types so that the backend_decls
+ do not get mixed up. */
+ old_dt_list = gfc_derived_types;
+ gfc_derived_types = NULL;
- /* Store the new derived types with the global namespace. */
- if (gfc_derived_types)
- gsym->ns->derived_types = gfc_derived_types;
+ gfc_resolve (gsym->ns);
- /* Restore the derived types of this namespace. */
- gfc_derived_types = old_dt_list;
- }
+ /* Store the new derived types with the global namespace. */
+ if (gfc_derived_types)
+ gsym->ns->derived_types = gfc_derived_types;
- /* Make sure that translation for the gsymbol occurs before
- the procedure currently being resolved. */
- ns = gfc_global_ns_list;
- for (; ns && ns != gsym->ns; ns = ns->sibling)
- {
- if (ns->sibling == gsym->ns)
- {
- ns->sibling = gsym->ns->sibling;
- gsym->ns->sibling = gfc_global_ns_list;
- gfc_global_ns_list = gsym->ns;
- break;
+ /* Restore the derived types of this namespace. */
+ gfc_derived_types = old_dt_list;
}
- }
- def_sym = gsym->ns->proc_name;
+ /* Make sure that translation for the gsymbol occurs before
+ the procedure currently being resolved. */
+ ns = gfc_global_ns_list;
+ for (; ns && ns != gsym->ns; ns = ns->sibling)
+ {
+ if (ns->sibling == gsym->ns)
+ {
+ ns->sibling = gsym->ns->sibling;
+ gsym->ns->sibling = gfc_global_ns_list;
+ gfc_global_ns_list = gsym->ns;
+ break;
+ }
+ }
- /* This can happen if a binding name has been specified. */
- if (gsym->binding_label && gsym->sym_name != def_sym->name)
- gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
+ /* This can happen if a binding name has been specified. */
+ if (gsym->binding_label && gsym->sym_name != def_sym->name)
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
- if (def_sym->attr.entry_master)
- {
- gfc_entry_list *entry;
- for (entry = gsym->ns->entries; entry; entry = entry->next)
- if (strcmp (entry->sym->name, sym->name) == 0)
- {
- def_sym = entry->sym;
- break;
- }
+ if (def_sym->attr.entry_master || def_sym->attr.entry)
+ {
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
+ }
}
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
reason, sizeof(reason), NULL, NULL))
{
- gfc_error_opt (OPT_Wargument_mismatch,
- "Interface mismatch in global procedure %qs at %L:"
+ gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:"
" %s", sym->name, &sym->declared_at, reason);
goto done;
}
-
- if (!pedantic
- || ((gfc_option.warn_std & GFC_STD_LEGACY)
- && !(gfc_option.warn_std & GFC_STD_GNU)))
- gfc_errors_to_warnings (true);
-
- if (sym->attr.if_source != IFSRC_IFBODY)
- gfc_procedure_use (def_sym, actual, where);
}
done:
static int
pure_stmt_function (gfc_expr *, gfc_symbol *);
-static int
-pure_function (gfc_expr *e, const char **name)
+int
+gfc_pure_function (gfc_expr *e, const char **name)
{
int pure;
gfc_component *comp;
}
+/* Check if the expression is a reference to an implicitly pure function. */
+
+int
+gfc_implicit_pure_function (gfc_expr *e)
+{
+ gfc_component *comp = gfc_get_proc_ptr_comp (e);
+ if (comp)
+ return gfc_implicit_pure (comp->ts.interface);
+ else if (e->value.function.esym)
+ return gfc_implicit_pure (e->value.function.esym);
+ else
+ return 0;
+}
+
+
static bool
impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
int *f ATTRIBUTE_UNUSED)
|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
return false;
- return pure_function (e, &name) ? false : true;
+ return gfc_pure_function (e, &name) ? false : true;
}
static bool check_pure_function (gfc_expr *e)
{
const char *name = NULL;
- if (!pure_function (e, &name) && name)
+ if (!gfc_pure_function (e, &name) && name)
{
if (forall_flag)
{
"within a PURE procedure", name, &e->where);
return false;
}
- gfc_unset_implicit_pure (NULL);
+ if (!gfc_implicit_pure_function (e))
+ gfc_unset_implicit_pure (NULL);
}
return true;
}
/* If SYM has references to outer arrays, so has the procedure calling
SYM. If SYM is a procedure pointer, we can assume the worst. */
- if (sym->attr.array_outer_dependency
- || sym->attr.proc_pointer)
+ if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
+ && gfc_current_ns->proc_name)
gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
}
return false;
}
- /* If this ia a deferred TBP with an abstract interface (which may
+ /* If this is a deferred TBP with an abstract interface (which may
of course be referenced), expr->value.function.esym will be set. */
if (sym && sym->attr.abstract && !expr->value.function.esym)
{
return false;
}
+ /* If this is a deferred TBP with an abstract interface, its result
+ cannot be an assumed length character (F2003: C418). */
+ if (sym && sym->attr.abstract && sym->attr.function
+ && sym->result->ts.u.cl
+ && sym->result->ts.u.cl->length == NULL
+ && !sym->result->ts.deferred)
+ {
+ gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
+ "character length result (F2008: C418)", sym->name,
+ &sym->declared_at);
+ return false;
+ }
+
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
/* If the procedure is external, check for usage. */
if (sym && is_external_proc (sym))
- resolve_global_procedure (sym, &expr->where,
- &expr->value.function.actual, 0);
+ resolve_global_procedure (sym, &expr->where, 0);
if (sym && sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl
if (expr->expr_type != EXPR_FUNCTION)
return t;
+ /* Walk the argument list looking for invalid BOZ. */
+ for (arg = expr->value.function.actual; arg; arg = arg->next)
+ if (arg->expr && arg->expr->ts.type == BT_BOZ)
+ {
+ gfc_error ("A BOZ literal constant at %L cannot appear as an "
+ "actual argument in a function reference",
+ &arg->expr->where);
+ return false;
+ }
+
temp = need_full_assumed_size;
need_full_assumed_size = 0;
if (arg->next->expr->expr_type != EXPR_CONSTANT)
break;
- if (arg->next->name && strncmp (arg->next->name, "kind", 4) == 0)
+ if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
break;
if ((int)mpz_get_si (arg->next->expr->value.integer)
/* If external, check for usage. */
if (csym && is_external_proc (csym))
- resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
+ resolve_global_procedure (csym, &c->loc, 1);
t = true;
if (c->resolved_sym == NULL)
}
+/* Callback finding an impure function as an operand to an .and. or
+ .or. expression. Remember the last function warned about to
+ avoid double warnings when recursing. */
+
+static int
+impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ gfc_expr *f = *e;
+ const char *name;
+ static gfc_expr *last = NULL;
+ bool *found = (bool *) data;
+
+ if (f->expr_type == EXPR_FUNCTION)
+ {
+ *found = 1;
+ if (f != last && !gfc_pure_function (f, &name)
+ && !gfc_implicit_pure_function (f))
+ {
+ if (name)
+ gfc_warning (OPT_Wfunction_elimination,
+ "Impure function %qs at %L might not be evaluated",
+ name, &f->where);
+ else
+ gfc_warning (OPT_Wfunction_elimination,
+ "Impure function at %L might not be evaluated",
+ &f->where);
+ }
+ last = f;
+ }
+
+ return 0;
+}
+
+/* Return true if TYPE is character based, false otherwise. */
+
+static int
+is_character_based (bt type)
+{
+ return type == BT_CHARACTER || type == BT_HOLLERITH;
+}
+
+
+/* If expression is a hollerith, convert it to character and issue a warning
+ for the conversion. */
+
+static void
+convert_hollerith_to_character (gfc_expr *e)
+{
+ if (e->ts.type == BT_HOLLERITH)
+ {
+ gfc_typespec t;
+ gfc_clear_ts (&t);
+ t.type = BT_CHARACTER;
+ t.kind = e->ts.kind;
+ gfc_convert_type_warn (e, &t, 2, 1);
+ }
+}
+
+/* Convert to numeric and issue a warning for the conversion. */
+
+static void
+convert_to_numeric (gfc_expr *a, gfc_expr *b)
+{
+ gfc_typespec t;
+ gfc_clear_ts (&t);
+ t.type = b->ts.type;
+ t.kind = b->ts.kind;
+ gfc_convert_type_warn (a, &t, 2, 1);
+}
+
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
gfc_expr *op1, *op2;
char msg[200];
bool dual_locus_error;
- bool t;
+ bool t = true;
/* Resolve all subnodes-- give them types. */
case INTRINSIC_PARENTHESES:
if (!gfc_resolve_expr (e->value.op.op1))
return false;
+ if (e->value.op.op1
+ && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
+ {
+ gfc_error ("BOZ literal constant at %L cannot be an operand of "
+ "unary operator %qs", &e->value.op.op1->where,
+ gfc_op2string (e->value.op.op));
+ return false;
+ }
break;
}
op2 = e->value.op.op2;
dual_locus_error = false;
+ /* op1 and op2 cannot both be BOZ. */
+ if (op1 && op1->ts.type == BT_BOZ
+ && op2 && op2->ts.type == BT_BOZ)
+ {
+ gfc_error ("Operands at %L and %L cannot appear as operands of "
+ "binary operator %qs", &op1->where, &op2->where,
+ gfc_op2string (e->value.op.op));
+ return false;
+ }
+
if ((op1 && op1->expr_type == EXPR_NULL)
|| (op2 && op2->expr_type == EXPR_NULL))
{
}
sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
- gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (e));
goto bad_op;
case INTRINSIC_PLUS:
break;
}
- sprintf (msg,
+ if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
+ sprintf (msg,
+ _("Unexpected derived-type entities in binary intrinsic "
+ "numeric operator %%<%s%%> at %%L"),
+ gfc_op2string (e->value.op.op));
+ else
+ sprintf (msg,
_("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
case INTRINSIC_CONCAT:
sprintf (msg,
_("Operands of string concatenation operator at %%L are %s/%s"),
- gfc_typename (&op1->ts), gfc_typename (&op2->ts));
+ gfc_typename (op1), gfc_typename (op2));
goto bad_op;
case INTRINSIC_AND:
gfc_convert_type (op1, &e->ts, 2);
else if (op2->ts.kind < e->ts.kind)
gfc_convert_type (op2, &e->ts, 2);
+
+ if (flag_frontend_optimize &&
+ (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
+ {
+ /* Warn about short-circuiting
+ with impure function as second operand. */
+ bool op2_f = false;
+ gfc_expr_walker (&op2, impure_function_callback, &op2_f);
+ }
break;
}
if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
gfc_convert_type (op2, &e->ts, 1);
e = logical_to_bitwise (e);
- return resolve_function (e);
+ goto simplify_op;
}
sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
e->ts.type = BT_INTEGER;
e->ts.kind = op1->ts.kind;
e = logical_to_bitwise (e);
- return resolve_function (e);
+ goto simplify_op;
}
if (op1->ts.type == BT_LOGICAL)
}
sprintf (msg, _("Operand of .not. operator at %%L is %s"),
- gfc_typename (&op1->ts));
+ gfc_typename (op1));
goto bad_op;
case INTRINSIC_GT:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
+
+ if (flag_dec
+ && is_character_based (op1->ts.type)
+ && is_character_based (op2->ts.type))
+ {
+ convert_hollerith_to_character (op1);
+ convert_hollerith_to_character (op2);
+ }
+
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
&& op1->ts.kind == op2->ts.kind)
{
break;
}
+ /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
+ if (op1->ts.type == BT_BOZ)
+ {
+ if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
+ "an operand of a relational operator",
+ &op1->where))
+ return false;
+
+ if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
+ return false;
+
+ if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
+ return false;
+ }
+
+ /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
+ if (op2->ts.type == BT_BOZ)
+ {
+ if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
+ "an operand of a relational operator",
+ &op2->where))
+ return false;
+
+ if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
+ return false;
+
+ if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
+ return false;
+ }
+ if (flag_dec
+ && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
+ convert_to_numeric (op1, op2);
+
+ if (flag_dec
+ && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
+ convert_to_numeric (op2, op1);
+
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
gfc_type_convert_binary (e, 1);
msg = "Inequality comparison for %s at %L";
gfc_warning (OPT_Wcompare_reals, msg,
- gfc_typename (&op1->ts), &op1->where);
+ gfc_typename (op1), &op1->where);
}
}
else
sprintf (msg,
_("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
}
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
- e->value.op.uop->name, gfc_typename (&op1->ts));
+ e->value.op.uop->name, gfc_typename (op1));
else
{
sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
- e->value.op.uop->name, gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ e->value.op.uop->name, gfc_typename (op1),
+ gfc_typename (op2));
e->value.op.uop->op->sym->attr.referenced = 1;
}
/* Deal with arrayness of an operand through an operator. */
- t = true;
-
switch (e->value.op.op)
{
case INTRINSIC_PLUS:
break;
}
+simplify_op:
+
/* Attempt to simplify the expression. */
if (t)
{
gfc_array_spec *as;
gfc_component *c;
gfc_ref *ref;
+ bool class_as = false;
if (e->symtree->n.sym->ts.type == BT_CLASS)
- as = CLASS_DATA (e->symtree->n.sym)->as;
+ {
+ as = CLASS_DATA (e->symtree->n.sym)->as;
+ class_as = true;
+ }
else
as = e->symtree->n.sym->as;
c = ref->u.c.component;
if (c->attr.dimension)
{
- if (as != NULL)
+ if (as != NULL && !(class_as && as == c->as))
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
static bool
-resolve_substring (gfc_ref *ref)
+resolve_substring (gfc_ref *ref, bool *equal_length)
{
int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
&ref->u.ss.end->where);
return false;
}
+ /* If the substring has the same length as the original
+ variable, the reference itself can be deleted. */
+
+ if (ref->u.ss.length != NULL
+ && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
+ && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
+ *equal_length = true;
}
return true;
gfc_ref *char_ref;
gfc_expr *start, *end;
gfc_typespec *ts = NULL;
+ mpz_t diff;
for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
{
- if (char_ref->type == REF_SUBSTRING)
- break;
+ if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
+ break;
if (char_ref->type == REF_COMPONENT)
ts = &char_ref->u.c.component->ts;
}
- if (!char_ref)
+ if (!char_ref || char_ref->type == REF_INQUIRY)
return;
gcc_assert (char_ref->next == NULL);
return;
}
- /* Length = (end - start + 1). */
- e->ts.u.cl->length = gfc_subtract (end, start);
- e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
- gfc_get_int_expr (gfc_charlen_int_kind,
- NULL, 1));
+ /* Length = (end - start + 1).
+ Check first whether it has a constant length. */
+ if (gfc_dep_difference (end, start, &diff))
+ {
+ gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
+ &e->where);
+
+ mpz_add_ui (len->value.integer, diff, 1);
+ mpz_clear (diff);
+ e->ts.u.cl->length = len;
+ /* The check for length < 0 is handled below */
+ }
+ else
+ {
+ e->ts.u.cl->length = gfc_subtract (end, start);
+ e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
+ gfc_get_int_expr (gfc_charlen_int_kind,
+ NULL, 1));
+ }
/* F2008, 6.4.1: Both the starting point and the ending point shall
be within the range 1, 2, ..., n unless the starting point exceeds
/* Resolve subtype references. */
-static bool
-resolve_ref (gfc_expr *expr)
+bool
+gfc_resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension;
- gfc_ref *ref;
+ gfc_ref *ref, **prev;
+ bool equal_length;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
break;
}
- for (ref = expr->ref; ref; ref = ref->next)
- switch (ref->type)
+ for (prev = &expr->ref; *prev != NULL;
+ prev = *prev == NULL ? prev : &(*prev)->next)
+ switch ((*prev)->type)
{
case REF_ARRAY:
- if (!resolve_array_ref (&ref->u.ar))
+ if (!resolve_array_ref (&(*prev)->u.ar))
return false;
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
- if (!resolve_substring (ref))
+ equal_length = false;
+ if (!resolve_substring (*prev, &equal_length))
return false;
+
+ if (expr->expr_type != EXPR_SUBSTRING && equal_length)
+ {
+ /* Remove the reference and move the charlen, if any. */
+ ref = *prev;
+ *prev = ref->next;
+ ref->next = NULL;
+ expr->ts.u.cl = ref->u.ss.length;
+ ref->u.ss.length = NULL;
+ gfc_free_ref_list (ref);
+ }
break;
}
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
break;
}
examining the base symbol and any reference structures it may have. */
void
-expression_rank (gfc_expr *e)
+gfc_expression_rank (gfc_expr *e)
{
gfc_ref *ref;
int i, rank;
goto done;
/* Constructors can have a rank different from one via RESHAPE(). */
- if (e->symtree == NULL)
- {
- e->rank = 0;
- goto done;
- }
-
- e->rank = (e->symtree->n.sym->as == NULL)
- ? 0 : e->symtree->n.sym->as->rank;
+ e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
+ ? 0 : e->symtree->n.sym->as->rank);
goto done;
}
{
/* Figure out the rank of the section. */
if (rank != 0)
- gfc_internal_error ("expression_rank(): Two array specs");
+ gfc_internal_error ("gfc_expression_rank(): Two array specs");
for (i = 0; i < ref->u.ar.dimen; i++)
if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
}
}
/* TS 29113, C535b. */
- else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
- && CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
- || (sym->ts.type != BT_CLASS && sym->as
- && sym->as->type == AS_ASSUMED_RANK))
+ else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && !sym->attr.select_rank_temporary)
{
- if (!actual_arg)
+ if (!actual_arg
+ && !(cs_base && cs_base->current
+ && cs_base->current->op == EXEC_SELECT_RANK))
{
gfc_error ("Assumed-rank variable %s at %L may only be used as "
"actual argument", sym->name, &e->where);
the ts' type of the component refs is still array valued, which
can't be translated that way. */
if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
- && sym->assoc->target->ts.type == BT_CLASS
+ && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
&& CLASS_DATA (sym->assoc->target)->as)
{
gfc_ref *ref = e->ref;
gfc_fix_class_refs (e);
if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
return false;
+ else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
+ {
+ /* This can happen because the parser did not detect that the
+ associate name is an array and the expression had no array
+ part_ref. */
+ gfc_ref *ref = gfc_get_ref ();
+ ref->type = REF_ARRAY;
+ ref->u.ar = *gfc_get_array_ref();
+ ref->u.ar.type = AR_FULL;
+ if (sym->as)
+ {
+ ref->u.ar.as = sym->as;
+ ref->u.ar.dimen = sym->as->rank;
+ }
+ ref->next = e->ref;
+ e->ref = ref;
+
+ }
}
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
}
}
- if (e->ref && !resolve_ref (e))
+ if (e->ref && !gfc_resolve_ref (e))
return false;
if (sym->attr.flavor == FL_PROCEDURE
}
if (t)
- expression_rank (e);
+ gfc_expression_rank (e);
if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
add_caf_get_intrinsic (e);
{
gfc_expr* po;
+ if (e->expr_type == EXPR_UNKNOWN)
+ {
+ gfc_error ("Error in typebound call at %L",
+ &e->where);
+ return NULL;
+ }
+
gcc_assert (e->expr_type == EXPR_COMPCALL);
if (e->value.compcall.base_object)
if (!base)
return false;
- gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+ if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
+ {
+ gfc_error ("Error in typebound call at %L", &e->where);
+ goto cleanup;
+ }
if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
return false;
/* Check that's really a SUBROUTINE. */
if (!c->expr1->value.compcall.tbp->subroutine)
{
- gfc_error ("%qs at %L should be a SUBROUTINE",
- c->expr1->value.compcall.name, &c->loc);
- return false;
+ if (!c->expr1->value.compcall.tbp->is_generic
+ && c->expr1->value.compcall.tbp->u.specific
+ && c->expr1->value.compcall.tbp->u.specific->n.sym
+ && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
+ c->expr1->value.compcall.tbp->subroutine = 1;
+ else
+ {
+ gfc_error ("%qs at %L should be a SUBROUTINE",
+ c->expr1->value.compcall.name, &c->loc);
+ return false;
+ }
}
if (!check_typebound_baseobject (c->expr1))
return false;
}
+
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
overridable = !e->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
- /* If the base_object is not a variable, the corresponding actual
- argument expression must be stored in e->base_expression so
- that the corresponding tree temporary can be used as the base
- object in gfc_conv_procedure_call. */
- if (expr->expr_type != EXPR_VARIABLE)
- {
- gfc_actual_arglist *args;
-
- for (args= e->value.function.actual; args; args = args->next)
- {
- if (expr == args->expr)
- expr = args->expr;
- }
- }
-
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
if (st == NULL)
return resolve_compcall (e, NULL);
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
return false;
/* Get the CLASS declared type. */
}
c = gfc_find_component (declared, "_data", true, true, NULL);
- declared = c->ts.u.derived;
/* Treat the call as if it is a typebound procedure, in order to roll
out the correct name for the specific function. */
if (st == NULL)
return resolve_typebound_call (code, NULL, NULL);
- if (!resolve_ref (code->expr1))
+ if (!gfc_resolve_ref (code->expr1))
return false;
/* Get the CLASS declared type. */
if (!comp->attr.subroutine)
gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
- if (!resolve_ref (c->expr1))
+ if (!gfc_resolve_ref (c->expr1))
return false;
if (!update_ppc_arglist (c->expr1))
if (!comp->attr.function)
gfc_add_function (&comp->attr, comp->name, &e->where);
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
return false;
if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
bool t;
bool inquiry_save, actual_arg_save, first_actual_arg_save;
- if (e == NULL)
+ if (e == NULL || e->do_not_resolve_again)
return true;
/* inquiry_argument only applies to variables. */
break;
case EXPR_SUBSTRING:
- t = resolve_ref (e);
+ t = gfc_resolve_ref (e);
break;
case EXPR_CONSTANT:
case EXPR_ARRAY:
t = false;
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
break;
t = gfc_resolve_array_constructor (e);
/* Also try to expand a constructor. */
if (t)
{
- expression_rank (e);
+ gfc_expression_rank (e);
if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
gfc_expand_constructor (e, false);
}
break;
case EXPR_STRUCTURE:
- t = resolve_ref (e);
+ t = gfc_resolve_ref (e);
if (!t)
break;
actual_arg = actual_arg_save;
first_actual_arg = first_actual_arg_save;
+ /* For some reason, resolving these expressions a second time mangles
+ the typespec of the expression itself. */
+ if (t && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.select_rank_temporary
+ && UNLIMITED_POLY (e->symtree->n.sym))
+ e->do_not_resolve_again = 1;
+
return t;
}
"Step expression in DO loop"))
return false;
- if (iter->step->expr_type == EXPR_CONSTANT)
- {
- if ((iter->step->ts.type == BT_INTEGER
- && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
- || (iter->step->ts.type == BT_REAL
- && mpfr_sgn (iter->step->value.real) == 0))
- {
- gfc_error ("Step expression in DO loop at %L cannot be zero",
- &iter->step->where);
- return false;
- }
- }
-
/* Convert start, end, and step to the same type as var. */
if (iter->start->ts.kind != iter->var->ts.kind
|| iter->start->ts.type != iter->var->ts.type)
|| iter->step->ts.type != iter->var->ts.type)
gfc_convert_type (iter->step, &iter->var->ts, 1);
+ if (iter->step->expr_type == EXPR_CONSTANT)
+ {
+ if ((iter->step->ts.type == BT_INTEGER
+ && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
+ || (iter->step->ts.type == BT_REAL
+ && mpfr_sgn (iter->step->value.real) == 0))
+ {
+ gfc_error ("Step expression in DO loop at %L cannot be zero",
+ &iter->step->where);
+ return false;
+ }
+ }
+
if (iter->start->expr_type == EXPR_CONSTANT
&& iter->end->expr_type == EXPR_CONSTANT
&& iter->step->expr_type == EXPR_CONSTANT)
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
break;
}
for (ref = result->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
+ if (ref->u.ar.dimen == 0
+ && ref->u.ar.as && ref->u.ar.as->corank)
+ return result;
+
ref->u.ar.type = AR_FULL;
for (i = 0; i < ref->u.ar.dimen; i++)
for (tail = e2->ref; tail && tail->next; tail = tail->next);
/* First compare rank. */
- if ((tail && e1->rank != tail->u.ar.as->rank)
+ if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
|| (!tail && e1->rank != e2->rank))
{
gfc_error ("Source-expr at %L must be scalar or have the "
break;
case REF_SUBSTRING:
+ case REF_INQUIRY:
allocatable = 0;
pointer = 0;
break;
if (codimension)
for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
- if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
- {
- gfc_error ("Coarray specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
- }
+ {
+ switch (ar->dimen_type[i])
+ {
+ case DIMEN_THIS_IMAGE:
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+
+ case DIMEN_RANGE:
+ if (ar->start[i] == 0 || ar->end[i] == 0)
+ {
+ /* If ar->stride[i] is NULL, we issued a previous error. */
+ if (ar->stride[i] == NULL)
+ gfc_error ("Bad array specification in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+ else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
+ {
+ gfc_error ("Upper cobound is less than lower cobound at %L",
+ &ar->start[i]->where);
+ goto failure;
+ }
+ break;
+
+ case DIMEN_ELEMENT:
+ if (ar->start[i]->expr_type == EXPR_CONSTANT)
+ {
+ gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
+ if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
+ {
+ gfc_error ("Upper cobound is less than lower cobound "
+ "of 1 at %L", &ar->start[i]->where);
+ goto failure;
+ }
+ }
+ break;
+
+ case DIMEN_STAR:
+ break;
+ default:
+ gfc_error ("Bad array specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+
+ }
+ }
for (i = 0; i < ar->dimen; i++)
{
if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
gfc_check_vardef_context (errmsg, false, false, false,
_("ERRMSG variable"));
+ /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
+ F18:R930 errmsg-variable is scalar-default-char-variable
+ F18:R906 default-char-variable is variable
+ F18:C906 default-char-variable shall be default character. */
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
&& (errmsg->ref->type == REF_ARRAY
|| errmsg->ref->type == REF_COMPONENT)))
- || errmsg->rank > 0 )
- gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
+ || errmsg->rank > 0
+ || errmsg->ts.kind != gfc_default_character_kind)
+ gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
"variable", &errmsg->where);
for (p = code->ext.alloc.list; p; p = p->next)
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
{
gfc_error ("Argument of SELECT statement at %L cannot be %s",
- &case_expr->where, gfc_typename (&case_expr->ts));
+ &case_expr->where, gfc_typename (case_expr));
/* Punt. Going on here just produce more garbage error messages. */
return;
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->low->where,
- gfc_typename (&case_expr->ts));
+ gfc_typename (case_expr));
if (cp->high
&& cp->low != cp->high
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->high->where,
- gfc_typename (&case_expr->ts));
+ gfc_typename (case_expr));
}
/* PR 19168 has a long discussion concerning a mismatch of the kinds
gcc_assert (target->symtree);
tsym = target->symtree->n.sym;
+ if (tsym->attr.flavor == FL_PROGRAM)
+ {
+ gfc_error ("Associating entity %qs at %L is a PROGRAM",
+ tsym->name, &target->where);
+ return;
+ }
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
- if (target->rank != 0)
+ if (target->rank != 0 && !sym->attr.select_rank_temporary)
{
gfc_array_spec *as;
/* The rank may be incorrectly guessed at parsing, therefore make sure
if (as->corank != 0)
sym->attr.codimension = 1;
}
+ else if (sym->ts.type == BT_CLASS && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
+ {
+ if (!CLASS_DATA (sym)->as)
+ CLASS_DATA (sym)->as = gfc_get_array_spec ();
+ as = CLASS_DATA (sym)->as;
+ as->rank = target->rank;
+ as->type = AS_DEFERRED;
+ as->corank = gfc_get_corank (target);
+ CLASS_DATA (sym)->attr.dimension = 1;
+ if (as->corank != 0)
+ CLASS_DATA (sym)->attr.codimension = 1;
+ }
}
- else
+ else if (!sym->attr.select_rank_temporary)
{
/* target's rank is 0, but the type of the sym is still array valued,
which has to be corrected. */
- if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
+ if (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
{
gfc_array_spec *as;
symbol_attribute attr;
if (!sym->ts.u.cl)
sym->ts.u.cl = target->ts.u.cl;
+ if (sym->ts.deferred && target->expr_type == EXPR_VARIABLE
+ && target->symtree->n.sym->attr.dummy
+ && sym->ts.u.cl == target->ts.u.cl)
+ {
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
+ sym->ts.deferred = 1;
+ }
+
if (!sym->ts.u.cl->length
&& !sym->ts.deferred
&& target->expr_type == EXPR_CONSTANT)
|| sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
&& target->expr_type != EXPR_VARIABLE)
{
- sym->ts.u.cl = gfc_get_charlen();
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
sym->ts.deferred = 1;
/* This is reset in trans-stmt.c after the assignment
if (code->expr2)
{
- if (code->expr1->symtree->n.sym->attr.untyped)
- code->expr1->symtree->n.sym->ts = code->expr2->ts;
- selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ gfc_ref *ref2 = NULL;
+ for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS)
+ ref2 = ref;
+
+ if (ref2)
+ {
+ if (code->expr1->symtree->n.sym->attr.untyped)
+ code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
+ selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
+ }
+ else
+ {
+ if (code->expr1->symtree->n.sym->attr.untyped)
+ code->expr1->symtree->n.sym->ts = code->expr2->ts;
+ selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ }
if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
default_case->next = if_st;
}
- /* Resolve the internal code. This can not be done earlier because
+ /* Resolve the internal code. This cannot be done earlier because
it requires that the sym->assoc of selectors is set already. */
gfc_current_ns = ns;
gfc_resolve_blocks (code->block, gfc_current_ns);
}
+/* Resolve a SELECT RANK statement. */
+
+static void
+resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
+{
+ gfc_namespace *ns;
+ gfc_code *body, *new_st, *tail;
+ gfc_case *c;
+ char tname[GFC_MAX_SYMBOL_LEN];
+ char name[2 * GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *st;
+ gfc_expr *selector_expr = NULL;
+ int case_value;
+ HOST_WIDE_INT charlen = 0;
+
+ ns = code->ext.block.ns;
+ gfc_resolve (ns);
+
+ code->op = EXEC_BLOCK;
+ if (code->expr2)
+ {
+ gfc_association_list* assoc;
+
+ assoc = gfc_get_association_list ();
+ assoc->st = code->expr1->symtree;
+ assoc->target = gfc_copy_expr (code->expr2);
+ assoc->target->where = code->expr2->where;
+ /* assoc->variable will be set by resolve_assoc_var. */
+
+ code->ext.block.assoc = assoc;
+ code->expr1->symtree->n.sym->assoc = assoc;
+
+ resolve_assoc_var (code->expr1->symtree->n.sym, false);
+ }
+ else
+ code->ext.block.assoc = NULL;
+
+ /* Loop over RANK cases. Note that returning on the errors causes a
+ cascade of further errors because the case blocks do not compile
+ correctly. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.block.case_list;
+ if (c->low)
+ case_value = (int) mpz_get_si (c->low->value.integer);
+ else
+ case_value = -2;
+
+ /* Check for repeated cases. */
+ for (tail = code->block; tail; tail = tail->block)
+ {
+ gfc_case *d = tail->ext.block.case_list;
+ int case_value2;
+
+ if (tail == body)
+ break;
+
+ /* Check F2018: C1153. */
+ if (!c->low && !d->low)
+ gfc_error ("RANK DEFAULT at %L is repeated at %L",
+ &c->where, &d->where);
+
+ if (!c->low || !d->low)
+ continue;
+
+ /* Check F2018: C1153. */
+ case_value2 = (int) mpz_get_si (d->low->value.integer);
+ if ((case_value == case_value2) && case_value == -1)
+ gfc_error ("RANK (*) at %L is repeated at %L",
+ &c->where, &d->where);
+ else if (case_value == case_value2)
+ gfc_error ("RANK (%i) at %L is repeated at %L",
+ case_value, &c->where, &d->where);
+ }
+
+ if (!c->low)
+ continue;
+
+ /* Check F2018: C1155. */
+ if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
+ || gfc_expr_attr (code->expr1).pointer))
+ gfc_error ("RANK (*) at %L cannot be used with the pointer or "
+ "allocatable selector at %L", &c->where, &code->expr1->where);
+
+ if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
+ || gfc_expr_attr (code->expr1).pointer))
+ gfc_error ("RANK (*) at %L cannot be used with the pointer or "
+ "allocatable selector at %L", &c->where, &code->expr1->where);
+ }
+
+ /* Add EXEC_SELECT to switch on rank. */
+ new_st = gfc_get_code (code->op);
+ new_st->expr1 = code->expr1;
+ new_st->expr2 = code->expr2;
+ new_st->block = code->block;
+ code->expr1 = code->expr2 = NULL;
+ code->block = NULL;
+ if (!ns->code)
+ ns->code = new_st;
+ else
+ ns->code->next = new_st;
+ code = new_st;
+ code->op = EXEC_SELECT_RANK;
+
+ selector_expr = code->expr1;
+
+ /* Loop over SELECT RANK cases. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.block.case_list;
+ int case_value;
+
+ /* Pass on the default case. */
+ if (c->low == NULL)
+ continue;
+
+ /* Associate temporary to selector. This should only be done
+ when this case is actually true, so build a new ASSOCIATE
+ that does precisely this here (instead of using the
+ 'global' one). */
+ if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
+ && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
+
+ if (c->ts.type == BT_CLASS)
+ sprintf (tname, "class_%s", c->ts.u.derived->name);
+ else if (c->ts.type == BT_DERIVED)
+ sprintf (tname, "type_%s", c->ts.u.derived->name);
+ else if (c->ts.type != BT_CHARACTER)
+ sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
+ else
+ sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
+
+ case_value = (int) mpz_get_si (c->low->value.integer);
+ if (case_value >= 0)
+ sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
+ else
+ sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
+
+ st = gfc_find_symtree (ns->sym_root, name);
+ gcc_assert (st->n.sym->assoc);
+
+ st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
+ st->n.sym->assoc->target->where = selector_expr->where;
+
+ new_st = gfc_get_code (EXEC_BLOCK);
+ new_st->ext.block.ns = gfc_build_block_ns (ns);
+ new_st->ext.block.ns->code = body->next;
+ body->next = new_st;
+
+ /* Chain in the new list only if it is marked as dangling. Otherwise
+ there is a CASE label overlap and this is already used. Just ignore,
+ the error is diagnosed elsewhere. */
+ if (st->n.sym->assoc->dangling)
+ {
+ new_st->ext.block.assoc = st->n.sym->assoc;
+ st->n.sym->assoc->dangling = 0;
+ }
+
+ resolve_assoc_var (st->n.sym, false);
+ }
+
+ gfc_current_ns = ns;
+ gfc_resolve_blocks (code->block, gfc_current_ns);
+ gfc_current_ns = old_ns;
+}
+
+
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
-- a derived type being transferred doesn't have private components, unless
static void
resolve_transfer (gfc_code *code)
{
- gfc_typespec *ts;
gfc_symbol *sym, *derived;
gfc_ref *ref;
gfc_expr *exp;
_("item in READ")))
return;
- ts = exp->expr_type == EXPR_STRUCTURE ? &exp->ts : &exp->symtree->n.sym->ts;
+ const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
+ || exp->expr_type == EXPR_FUNCTION
+ ? &exp->ts : &exp->symtree->n.sym->ts;
/* Go to actual component transferred. */
for (ref = exp->ref; ref; ref = ref->next)
if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
&& (ts->type == BT_DERIVED || ts->type == BT_CLASS))
{
- if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
- derived = ts->u.derived;
- else
- derived = ts->u.derived->components->ts.u.derived;
+ derived = ts->u.derived;
/* Determine when to use the formatted DTIO procedure. */
if (dt && (dt->format_expr || dt->format_label))
return;
}
- /* C_PTR and C_FUNPTR have private components which means they can not
+ /* C_PTR and C_FUNPTR have private components which means they cannot
be printed. However, if -std=gnu and not -pedantic, allow
the component to be printed to help debugging. */
if (ts->u.derived->ts.f90_type == BT_VOID)
}
/* Check STAT. */
+ gfc_resolve_expr (code->expr2);
if (code->expr2
&& (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
|| code->expr2->expr_type != EXPR_VARIABLE))
&code->expr2->where);
/* Check ERRMSG. */
+ gfc_resolve_expr (code->expr3);
if (code->expr3
&& (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
|| code->expr3->expr_type != EXPR_VARIABLE))
old_nvar = nvar;
+ if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
+ return;
+
/* Start to resolve a FORALL construct */
if (forall_save == 0)
{
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
+ case EXEC_SELECT_RANK:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
lhs = code->expr1;
rhs = code->expr2;
- if (rhs->is_boz
- && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
- "a DATA statement and outside INT/REAL/DBLE/CMPLX",
- &code->loc))
- return false;
+ if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
+ && rhs->ts.type == BT_CHARACTER
+ && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
+ {
+ /* Use of -fdec-char-conversions allows assignment of character data
+ to non-character variables. This not permited for nonconstant
+ strings. */
+ gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
+ gfc_typename (lhs), &rhs->where);
+ return false;
+ }
/* Handle the case of a BOZ literal on the RHS. */
- if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
+ if (rhs->ts.type == BT_BOZ)
{
- int rc;
- if (warn_surprising)
- gfc_warning (OPT_Wsurprising,
- "BOZ literal at %L is bitwise transferred "
- "non-integer symbol %qs", &code->loc,
- lhs->symtree->n.sym->name);
-
- if (!gfc_convert_boz (rhs, &lhs->ts))
+ if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
+ "statement value nor an actual argument of "
+ "INT/REAL/DBLE/CMPLX intrinsic subprogram",
+ &rhs->where))
return false;
- if ((rc = gfc_range_check (rhs)) != ARITH_OK)
- {
- if (rc == ARITH_UNDERFLOW)
- gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
- ". This check can be disabled with the option "
- "%<-fno-range-check%>", &rhs->where);
- else if (rc == ARITH_OVERFLOW)
- gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
- ". This check can be disabled with the option "
- "%<-fno-range-check%>", &rhs->where);
- else if (rc == ARITH_NAN)
- gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
- ". This check can be disabled with the option "
- "%<-fno-range-check%>", &rhs->where);
+
+ switch (lhs->ts.type)
+ {
+ case BT_INTEGER:
+ if (!gfc_boz2int (rhs, lhs->ts.kind))
+ return false;
+ break;
+ case BT_REAL:
+ if (!gfc_boz2real (rhs, lhs->ts.kind))
+ return false;
+ break;
+ default:
+ gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
return false;
}
}
- if (lhs->ts.type == BT_CHARACTER
- && warn_character_truncation)
+ if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
{
HOST_WIDE_INT llen = 0, rlen = 0;
if (lhs->ts.u.cl != NULL
"component in a PURE procedure",
&rhs->where);
else
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
+ /* F2008, C1283 (4). */
+ gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
+ "shall not be used as the expr at %L of an intrinsic "
+ "assignment statement in which the variable is of a "
+ "derived type if the derived type has a pointer "
+ "component at any level of component selection.",
&rhs->where);
return rval;
}
&& rhs->expr_type != EXPR_ARRAY)
gfc_add_data_component (rhs);
+ /* Make sure there is a vtable and, in particular, a _copy for the
+ rhs type. */
+ if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
+ gfc_find_vtab (&rhs->ts);
+
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
&& (lhs_coindexed
|| (code->expr2->expr_type == EXPR_FUNCTION
gfc_get_sym_tree (name, ns, &tmp, false);
gfc_add_type (tmp->n.sym, &e->ts, NULL);
+ if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
+ tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
+ NULL,
+ e->value.character.length);
+
as = NULL;
ref = NULL;
aref = NULL;
tmp->n.sym->attr.function = 0;
tmp->n.sym->attr.result = 0;
tmp->n.sym->attr.flavor = FL_VARIABLE;
+ tmp->n.sym->attr.dummy = 0;
+ tmp->n.sym->attr.intent = INTENT_UNKNOWN;
if (as)
{
if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
return false;
+ if (gfc_expr_attr ((*code)->expr1).pointer)
+ return false;
+
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
tmp_expr->where = (*code)->loc;
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
t = gfc_check_vardef_context (e, false, false, false,
_("pointer assignment"));
gfc_free_expr (e);
+
+ t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
+
if (!t)
break;
- gfc_check_pointer_assign (code->expr1, code->expr2);
-
/* Assigning a class object always is a regular assign. */
if (code->expr2->ts.type == BT_CLASS
&& code->expr1->ts.type == BT_CLASS
resolve_select_type (code, ns);
break;
+ case EXEC_SELECT_RANK:
+ resolve_select_rank (code, ns);
+ break;
+
case EXEC_BLOCK:
resolve_block_construct (code);
break;
case EXEC_ENDFILE:
case EXEC_REWIND:
case EXEC_FLUSH:
- if (!gfc_resolve_filepos (code->ext.filepos))
+ if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
break;
resolve_branch (code->ext.filepos->err, code);
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
{
if (!gsym)
- gsym = gfc_get_gsymbol (sym->binding_label);
+ gsym = gfc_get_gsymbol (sym->binding_label, true);
gsym->where = sym->declared_at;
gsym->sym_name = sym->name;
gsym->binding_label = sym->binding_label;
sym->binding_label, &sym->declared_at, &gsym->where);
/* Clear the binding label to prevent checking multiple times. */
sym->binding_label = NULL;
-
+ return;
}
- else if (sym->attr.flavor == FL_VARIABLE && module
- && (strcmp (module, gsym->mod_name) != 0
- || strcmp (sym->name, gsym->sym_name) != 0))
+
+ if (sym->attr.flavor == FL_VARIABLE && module
+ && (strcmp (module, gsym->mod_name) != 0
+ || strcmp (sym->name, gsym->sym_name) != 0))
{
/* This can only happen if the variable is defined in a module - if it
isn't the same module, reject it. */
sym->name, module, sym->binding_label,
&sym->declared_at, &gsym->where, gsym->mod_name);
sym->binding_label = NULL;
+ return;
}
- else if ((sym->attr.function || sym->attr.subroutine)
- && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
- || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
- && sym != gsym->ns->proc_name
- && (module != gsym->mod_name
- || strcmp (gsym->sym_name, sym->name) != 0
- || (module && strcmp (module, gsym->mod_name) != 0)))
+
+ if ((sym->attr.function || sym->attr.subroutine)
+ && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
+ || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
+ && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
+ && (module != gsym->mod_name
+ || strcmp (gsym->sym_name, sym->name) != 0
+ || (module && strcmp (module, gsym->mod_name) != 0)))
{
/* Print an error if the procedure is defined multiple times; we have to
exclude references to the same procedure via module association or
simplification now. */
for (i = 0; i < sym->as->rank + sym->as->corank; i++)
{
+ if (i == GFC_MAX_DIMENSIONS)
+ break;
+
e = sym->as->lower[i];
if (e && (!resolve_index_expr(e)
|| !gfc_is_constant_expr (e)))
namespace. 14.6.1.3 of the standard and the discussion on
comp.lang.fortran. */
if (sym->ns != sym->ts.u.derived->ns
+ && !sym->ts.u.derived->attr.use_assoc
&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
{
gfc_symbol *s;
|| sym->attr.associate_var
|| sym->attr.omp_udr_artificial_var))
{
+ /* If a function has a result variable, only check the variable. */
+ if (sym->result && sym->name != sym->result->name)
+ return true;
+
gfc_error ("Entity %qs at %L has a deferred type parameter and "
"requires either the POINTER or ALLOCATABLE attribute",
sym->name, &sym->declared_at);
static bool
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
- int no_init_flag, automatic_flag;
- gfc_expr *e;
- const char *auto_save_msg;
- bool saved_specification_expr;
-
- auto_save_msg = "Automatic object %qs at %L cannot have the "
- "SAVE attribute";
+ const char *auto_save_msg = "Automatic object %qs at %L cannot have the "
+ "SAVE attribute";
if (!resolve_fl_var_and_proc (sym, mp_flag))
return false;
/* Set this flag to check that variables are parameters of all entries.
This check is effected by the call to gfc_resolve_expr through
is_non_constant_shape_array. */
- saved_specification_expr = specification_expr;
+ bool saved_specification_expr = specification_expr;
specification_expr = true;
if (sym->ns->proc_name
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
- e = sym->ts.u.cl->length;
+ gfc_expr *e = NULL;
+
+ if (sym->ts.u.cl)
+ e = sym->ts.u.cl->length;
+ else
+ return false;
+
if (e == NULL && !sym->attr.dummy && !sym->attr.result
&& !sym->ts.deferred && !sym->attr.select_type_temporary
&& !sym->attr.omp_udr_artificial_var)
apply_default_init_local (sym); /* Try to apply a default initialization. */
/* Determine if the symbol may not have an initializer. */
- no_init_flag = automatic_flag = 0;
+ int no_init_flag = 0, automatic_flag = 0;
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|| sym->attr.intrinsic || sym->attr.result)
no_init_flag = 1;
&& !resolve_fl_var_and_proc (sym, mp_flag))
return false;
+ /* Constraints on deferred type parameter. */
+ if (!deferred_requirements (sym))
+ return false;
+
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
module procedures are excluded by 2.2.3.3 - i.e., they are not
externally accessible and can access all the objects accessible in
the host. */
- if (!(sym->ns->parent
+ if (!(sym->ns->parent && sym->ns->parent->proc_name
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
&& gfc_check_symbol_access (sym))
{
{
gfc_error ("Function %qs at %L cannot have an initializer",
sym->name, &sym->declared_at);
+
+ /* Make sure no second error is issued for this. */
+ sym->value->error = 1;
return false;
}
}
/* An elemental function is required to return a scalar 12.7.1 */
- if (sym->attr.elemental && sym->attr.function && sym->as)
+ if (sym->attr.elemental && sym->attr.function
+ && (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)))
{
gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
"result", sym->name, &sym->declared_at);
while (curr_arg != NULL)
{
/* Skip implicitly typed dummy args here. */
- if (curr_arg->sym->attr.implicit_type == 0)
+ if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
if (!gfc_verify_c_interop_param (curr_arg->sym))
/* If something is found to fail, record the fact so we
can mark the symbol for the procedure as not being
if (sym1->attr.subroutine != sym2->attr.subroutine
|| sym1->attr.function != sym2->attr.function)
{
- gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
+ gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
" GENERIC %qs at %L",
sym1->name, sym2->name, generic_name, &where);
return false;
/* If we attempt to "overwrite" a specific binding, this is an error. */
if (p->overridden && !p->overridden->is_generic)
{
- gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
+ gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
" the same name", name, &p->where);
return false;
}
/* F08:C468. All operator bindings must have a passed-object dummy argument. */
if (target->specific->nopass)
{
- gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
+ gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
return NULL;
}
}
else
{
+ /* If proc has not been resolved at this point, proc->name may
+ actually be a USE associated entity. See PR fortran/89647. */
+ if (!proc->resolved
+ && proc->attr.function == 0 && proc->attr.subroutine == 0)
+ {
+ gfc_symbol *tmp;
+ gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
+ if (tmp && tmp->attr.use_assoc)
+ {
+ proc->module = tmp->module;
+ proc->attr.proc = tmp->attr.proc;
+ proc->attr.function = tmp->attr.function;
+ proc->attr.subroutine = tmp->attr.subroutine;
+ proc->attr.use_assoc = tmp->attr.use_assoc;
+ proc->ts = tmp->ts;
+ proc->result = tmp->result;
+ }
+ }
+
/* Check for F08:C465. */
if ((!proc->attr.subroutine && !proc->attr.function)
|| (proc->attr.proc != PROC_MODULE
&& proc->attr.if_source != IFSRC_IFBODY)
|| proc->attr.abstract)
{
- gfc_error ("%qs must be a module procedure or an external procedure with"
- " an explicit interface at %L", proc->name, &where);
+ gfc_error ("%qs must be a module procedure or an external "
+ "procedure with an explicit interface at %L",
+ proc->name, &where);
goto error;
}
}
static void
add_dt_to_dt_list (gfc_symbol *derived)
{
- gfc_dt_list *dt_list;
-
- for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
- if (derived == dt_list->derived)
- return;
-
- dt_list = gfc_get_dt_list ();
- dt_list->next = gfc_derived_types;
- dt_list->derived = derived;
- gfc_derived_types = dt_list;
+ if (!derived->dt_next)
+ {
+ if (gfc_derived_types)
+ {
+ derived->dt_next = gfc_derived_types->dt_next;
+ gfc_derived_types->dt_next = derived;
+ }
+ else
+ {
+ derived->dt_next = derived;
+ }
+ gfc_derived_types = derived;
+ }
}
resolve_component (gfc_component *c, gfc_symbol *sym)
{
gfc_symbol *super_type;
+ symbol_attribute *attr;
if (c->attr.artificial)
return true;
}
/* F2008, C448. */
- if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
+ if (c->ts.type == BT_CLASS)
+ {
+ if (CLASS_DATA (c))
+ {
+ attr = &(CLASS_DATA (c)->attr);
+
+ /* Fix up contiguous attribute. */
+ if (c->attr.contiguous)
+ attr->contiguous = 1;
+ }
+ else
+ attr = NULL;
+ }
+ else
+ attr = &c->attr;
+
+ if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
{
gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
"is not an array pointer", c->name, &c->loc);
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)
- {
- gfc_error ("The pointer component %qs of %qs at %L is a type "
- "that has not been declared", c->name, sym->name,
- &c->loc);
- return false;
- }
-
- if (c->ts.type == BT_CLASS && c->attr.class_ok
- && CLASS_DATA (c)->attr.class_pointer
- && CLASS_DATA (c)->ts.u.derived->components == NULL
- && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
- && !UNLIMITED_POLY (c))
- {
- gfc_error ("The pointer component %qs of %qs at %L is a type "
- "that has not been declared", c->name, sym->name,
- &c->loc);
- return false;
- }
-
/* If an allocatable component derived type is of the same type as
the enclosing derived type, we need a vtable generating so that
the __deallocate procedure is created. */
&sym->declared_at))
return false;
+ if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
+ {
+ gfc_error ("Derived type %qs at %L has not been declared",
+ sym->name, &sym->declared_at);
+ return false;
+ }
+
/* Resolve the finalizer procedures. */
if (!gfc_resolve_finalizers (sym, NULL))
return false;
}
/* TS 29113, C535a. */
if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
- && !sym->attr.select_type_temporary)
+ && !sym->attr.select_type_temporary
+ && !(cs_base && cs_base->current
+ && cs_base->current->op == EXEC_SELECT_RANK))
{
gfc_error ("Assumed-rank array at %L must be a dummy argument",
&sym->declared_at);
for (; formal; formal = formal->next)
if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
{
- gfc_error ("Namelist %qs can not be an argument to "
+ gfc_error ("Namelist %qs cannot be an argument to "
"subroutine or function at %L",
formal->sym->name, &sym->declared_at);
return;
/* Set the formal_arg_flag so that check_conflict will not throw
an error for host associated variables in the specification
expression for an array_valued function. */
- if (sym->attr.function && sym->as)
+ if ((sym->attr.function || sym->attr.result) && sym->as)
formal_arg_flag = true;
saved_specification_expr = specification_expr;
e = e->value.function.actual->expr;
if (e->expr_type != EXPR_VARIABLE)
- gfc_internal_error ("check_data_variable(): Bad expression");
+ {
+ gfc_error ("Expecting definable entity near %L", where);
+ return false;
+ }
sym = e->symtree->n.sym;
{
gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
sym->name, &sym->declared_at);
+ return false;
}
if (e->ref == NULL && sym->as)
return false;
}
- has_pointer = sym->attr.pointer;
-
if (gfc_is_coindexed (e))
{
gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
return false;
}
+ has_pointer = sym->attr.pointer;
+
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
- if (has_pointer
- && ref->type == REF_ARRAY
- && ref->u.ar.type != AR_FULL)
- {
- gfc_error ("DATA element %qs at %L is a pointer and so must "
- "be a full array", sym->name, where);
- return false;
- }
+ if (has_pointer)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
+ {
+ gfc_error ("DATA element %qs at %L is a pointer and so must "
+ "be a full array", sym->name, where);
+ return false;
+ }
+
+ if (values.vnode->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_error ("DATA object near %L has the pointer attribute "
+ "and the corresponding DATA value is not a valid "
+ "initial-data-target", where);
+ return false;
+ }
+ }
}
if (e->rank == 0 || has_pointer)
}
-/* Function called by resolve_fntype to flag other symbol used in the
- length type parameter specification of function resuls. */
+/* Function called by resolve_fntype to flag other symbols used in the
+ length type parameter specification of function results. */
static bool
flag_fn_result_spec (gfc_expr *expr,
- gfc_symbol *sym ATTRIBUTE_UNUSED,
+ gfc_symbol *sym,
int *f ATTRIBUTE_UNUSED)
{
gfc_namespace *ns;
if (!ns->parent)
break;
+ if (sym == s)
+ {
+ gfc_error ("Self reference in character length expression "
+ "for %qs at %L", sym->name, &expr->where);
+ return true;
+ }
+
if (!s->fn_result_spec
&& s->attr.flavor == FL_PARAMETER)
{
}
if (sym->ts.type == BT_CHARACTER)
- gfc_traverse_expr (sym->ts.u.cl->length, NULL, flag_fn_result_spec, 0);
+ gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
}
gfc_traverse_ns (ns, resolve_values);
- if (ns->save_all)
+ if (ns->save_all || !flag_automatic)
gfc_save_all (ns);
iter_stack = NULL;
bitmap_obstack_initialize (&labels_obstack);
gfc_resolve_oacc_declare (ns);
+ gfc_resolve_oacc_routines (ns);
gfc_resolve_omp_local_vars (ns);
gfc_resolve_code (ns->code, ns);
projects / thirdparty / gcc.git / blobdiff