-/* Perform type resolution on the various stuctures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
+/* Perform type resolution on the various structures.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "bitmap.h"
#include "arith.h" /* For gfc_compare_expr(). */
#include "dependency.h"
+#include "data.h"
+#include "target-memory.h" /* for gfc_simplify_transfer */
/* Types used in equivalence statements. */
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
|| (sym->as && sym->as->rank > 0))
- proc->attr.always_explicit = 1;
+ {
+ proc->attr.always_explicit = 1;
+ sym->attr.always_explicit = 1;
+ }
formal_arg_flag = 1;
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| sym->attr.optional)
- proc->attr.always_explicit = 1;
+ {
+ proc->attr.always_explicit = 1;
+ if (proc->result)
+ proc->result->attr.always_explicit = 1;
+ }
/* If the flavor is unknown at this point, it has to be a variable.
A procedure specification would have already set the type. */
&sym->declared_at);
continue;
}
+
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_error ("Dummy procedure '%s' not allowed in elemental "
+ "procedure '%s' at %L", sym->name, proc->name,
+ &sym->declared_at);
+ continue;
+ }
}
/* Each dummy shall be specified to be scalar. */
static void
resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{
- try t;
+ gfc_try t;
- /* If this namespace is not a function, ignore it. */
- if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE))
+ /* If this namespace is not a function or an entry master function,
+ ignore it. */
+ if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
+ || sym->attr.entry_master)
return;
/* Try to find out of what the return type is. */
&& ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
el->sym->ns = ns;
+ /* Do the same for entries where the master is not a module
+ procedure. These are retained in the module namespace because
+ of the module procedure declaration. */
+ for (el = el->next; el; el = el->next)
+ if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
+ && el->sym->attr.mod_proc)
+ el->sym->ns = ns;
+ el = ns->entries;
+
/* Add an entry statement for it. */
c = gfc_get_code ();
c->op = EXEC_ENTRY;
|| (el->sym->result->attr.pointer
!= ns->entries->sym->result->attr.pointer))
break;
-
- else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
- gfc_error ("Procedure %s at %L has entries with mismatched "
+ else if (as && fas && ns->entries->sym->result != el->sym->result
+ && gfc_compare_array_spec (as, fas) == 0)
+ gfc_error ("Function %s at %L has entries with mismatched "
"array specifications", ns->entries->sym->name,
&ns->entries->sym->declared_at);
+ /* The characteristics need to match and thus both need to have
+ the same string length, i.e. both len=*, or both len=4.
+ Having both len=<variable> is also possible, but difficult to
+ check at compile time. */
+ else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
+ && (((ts->cl->length && !fts->cl->length)
+ ||(!ts->cl->length && fts->cl->length))
+ || (ts->cl->length
+ && ts->cl->length->expr_type
+ != fts->cl->length->expr_type)
+ || (ts->cl->length
+ && ts->cl->length->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ts->cl->length->value.integer,
+ fts->cl->length->value.integer) != 0)))
+ gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
+ "entries returning variables of different "
+ "string lengths", ns->entries->sym->name,
+ &ns->entries->sym->declared_at);
}
if (el == NULL)
}
+static bool
+has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
+
+ gcc_assert (der->attr.flavor == FL_DERIVED);
+ for (c = der->components; c; c = c->next)
+ if ((c->ts.type != BT_DERIVED && c->initializer)
+ || (c->ts.type == BT_DERIVED
+ && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
+ break;
+
+ return c != NULL;
+}
+
+/* Resolve common variables. */
+static void
+resolve_common_vars (gfc_symbol *sym, bool named_common)
+{
+ gfc_symbol *csym = sym;
+
+ for (; csym; csym = csym->common_next)
+ {
+ if (csym->value || csym->attr.data)
+ {
+ if (!csym->ns->is_block_data)
+ gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
+ "but only in BLOCK DATA initialization is "
+ "allowed", csym->name, &csym->declared_at);
+ else if (!named_common)
+ gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
+ "in a blank COMMON but initialization is only "
+ "allowed in named common blocks", csym->name,
+ &csym->declared_at);
+ }
+
+ if (csym->ts.type != BT_DERIVED)
+ continue;
+
+ if (!(csym->ts.derived->attr.sequence
+ || csym->ts.derived->attr.is_bind_c))
+ gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+ "has neither the SEQUENCE nor the BIND(C) "
+ "attribute", csym->name, &csym->declared_at);
+ if (csym->ts.derived->attr.alloc_comp)
+ gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+ "has an ultimate component that is "
+ "allocatable", csym->name, &csym->declared_at);
+ if (has_default_initializer (csym->ts.derived))
+ gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+ "may not have default initializer", csym->name,
+ &csym->declared_at);
+ }
+}
+
+/* Resolve common blocks. */
+static void
+resolve_common_blocks (gfc_symtree *common_root)
+{
+ gfc_symbol *sym;
+
+ if (common_root == NULL)
+ return;
+
+ if (common_root->left)
+ resolve_common_blocks (common_root->left);
+ if (common_root->right)
+ resolve_common_blocks (common_root->right);
+
+ resolve_common_vars (common_root->n.common->head, true);
+
+ gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
+ if (sym == NULL)
+ return;
+
+ if (sym->attr.flavor == FL_PARAMETER)
+ gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+ sym->name, &common_root->n.common->where, &sym->declared_at);
+
+ if (sym->attr.intrinsic)
+ gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
+ sym->name, &common_root->n.common->where);
+ else if (sym->attr.result
+ ||(sym->attr.function && gfc_current_ns->proc_name == sym))
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
+ "that is also a function result", sym->name,
+ &common_root->n.common->where);
+ else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
+ && sym->attr.proc != PROC_ST_FUNCTION)
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
+ "that is also a global procedure", sym->name,
+ &common_root->n.common->where);
+}
+
+
/* Resolve contained function types. Because contained functions can call one
another, they have to be worked out before any of the contained procedures
can be resolved.
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. */
-static try
+static gfc_try
resolve_structure_cons (gfc_expr *expr)
{
gfc_constructor *cons;
gfc_component *comp;
- try t;
+ gfc_try t;
symbol_attribute a;
t = SUCCESS;
else
comp = expr->ts.derived->components;
+ /* See if the user is trying to invoke a structure constructor for one of
+ the iso_c_binding derived types. */
+ if (expr->ts.derived && expr->ts.derived->ts.is_iso_c && cons
+ && cons->expr != NULL)
+ {
+ gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
+ expr->ts.derived->name, &(expr->where));
+ return FAILURE;
+ }
+
for (; comp; comp = comp->next, cons = cons->next)
{
+ int rank;
+
if (!cons->expr)
continue;
continue;
}
- if (cons->expr->expr_type != EXPR_NULL
- && comp->as && comp->as->rank != cons->expr->rank
- && (comp->allocatable || cons->expr->rank))
+ rank = comp->as ? comp->as->rank : 0;
+ if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
+ && (comp->attr.allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the derived type "
"constructor at %L does not match that of the "
"component (%d/%d)", &cons->expr->where,
- cons->expr->rank, comp->as ? comp->as->rank : 0);
+ cons->expr->rank, rank);
t = FAILURE;
}
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
+ if (comp->attr.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,
t = gfc_convert_type (cons->expr, &comp->ts, 1);
}
- if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
+ if (cons->expr->expr_type == EXPR_NULL
+ && !(comp->attr.pointer || comp->attr.allocatable))
+ {
+ t = FAILURE;
+ gfc_error ("The NULL in the derived type constructor at %L is "
+ "being applied to component '%s', which is neither "
+ "a POINTER nor ALLOCATABLE", &cons->expr->where,
+ comp->name);
+ }
+
+ if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
continue;
a = gfc_expr_attr (cons->expr);
return 0;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
+
+ if (s != NULL)
+ {
+ if (s == sym)
+ return 0;
+ else
+ return generic_sym (s);
+ }
- return (s == NULL) ? 0 : generic_sym (s);
+ return 0;
}
static bool
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 false;
- 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)
+ if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
+ && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+ && (e->ref->u.ar.type == DIMEN_ELEMENT))
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
that look like procedure arguments are really simple variable
references. */
-static try
+static gfc_try
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
+ int save_need_full_assumed_size;
for (; arg; arg = arg->next)
{
continue;
}
+ if (e->expr_type == FL_VARIABLE && e->symtree->ambiguous)
+ {
+ gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
+ &e->where);
+ return FAILURE;
+ }
+
if (e->ts.type != BT_PROCEDURE)
{
+ save_need_full_assumed_size = need_full_assumed_size;
+ if (e->expr_type != FL_VARIABLE)
+ need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
+ need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
if (!sym->attr.intrinsic
&& !(sym->attr.external || sym->attr.use_assoc
|| sym->attr.if_source == IFSRC_IFBODY)
- && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
}
if (p == NULL || e->symtree == NULL)
- gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
- &e->where);
+ gfc_error ("GENERIC procedure '%s' is not "
+ "allowed as an actual argument at %L", sym->name,
+ &e->where);
}
/* If the symbol is the function that names the current (or
goto got_variable;
/* If all else fails, see if we have a specific intrinsic. */
- if (sym->attr.function
- && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
+ if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
+
isym = gfc_find_function (sym->name);
if (isym == NULL || !isym->specific)
{
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&e->where);
+ return FAILURE;
}
sym->ts = isym->ts;
+ sym->attr.intrinsic = 1;
+ sym->attr.function = 1;
}
goto argument_list;
}
primary.c (match_actual_arg). If above code determines that it
is a variable instead, it needs to be resolved as it was not
done at the beginning of this function. */
+ save_need_full_assumed_size = need_full_assumed_size;
+ if (e->expr_type != FL_VARIABLE)
+ need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
+ need_full_assumed_size = save_need_full_assumed_size;
argument_list:
/* Check argument list functions %VAL, %LOC and %REF. There is
procedures. If called with c == NULL, we have a function, otherwise if
expr == NULL, we have a subroutine. */
-static try
+static gfc_try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
gfc_actual_arglist *arg0;
if (resolve_assumed_size_actual (arg->expr))
return FAILURE;
- if (expr)
- continue;
-
- /* Elemental subroutine array actual arguments must conform. */
+ /* Elemental procedure's array actual arguments must conform. */
if (e != NULL)
{
- if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
+ if (gfc_check_conformance ("elemental procedure", arg->expr, e)
== FAILURE)
return FAILURE;
}
e = arg->expr;
}
+ /* INTENT(OUT) is only allowed for subroutines; if any actual argument
+ is an array, the intent inout/out variable needs to be also an array. */
+ if (rank > 0 && esym && expr == NULL)
+ for (eformal = esym->formal, arg = arg0; arg && eformal;
+ arg = arg->next, eformal = eformal->next)
+ if ((eformal->sym->attr.intent == INTENT_OUT
+ || eformal->sym->attr.intent == INTENT_INOUT)
+ && arg->expr && arg->expr->rank == 0)
+ {
+ gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
+ "ELEMENTAL subroutine '%s' is a scalar, but another "
+ "actual argument is an array", &arg->expr->where,
+ (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
+ : "INOUT", eformal->sym->name, esym->name);
+ return FAILURE;
+ }
return SUCCESS;
}
gsym = gfc_get_gsymbol (sym->name);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
- global_used (gsym, where);
+ gfc_global_used (gsym, where);
if (gsym->type == GSYM_UNKNOWN)
{
else if (s->result != NULL && s->result->as != NULL)
expr->rank = s->result->as->rank;
+ gfc_set_sym_referenced (expr->value.function.esym);
+
return MATCH_YES;
}
}
-static try
+static gfc_try
resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
- if (sym && !gfc_intrinsic_name (sym->name, 0))
+ if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
{
gfc_error ("There is no specific function for the generic '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
{
match m;
+ /* See if we have an intrinsic interface. */
+
+ if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
+ {
+ gfc_intrinsic_sym *isym;
+ isym = gfc_find_function (sym->ts.interface->name);
+
+ /* Existence of isym should be checked already. */
+ gcc_assert (isym);
+
+ sym->ts.type = isym->ts.type;
+ sym->ts.kind = isym->ts.kind;
+ sym->attr.function = 1;
+ sym->attr.proc = PROC_EXTERNAL;
+ goto found;
+ }
+
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
}
-static try
+static gfc_try
resolve_specific_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* Resolve a procedure call not known to be generic nor specific. */
-static try
+static gfc_try
resolve_unknown_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* See if we have an intrinsic function reference. */
- if (gfc_intrinsic_name (sym->name, 0))
+ if (gfc_is_intrinsic (sym, 0, expr->where))
{
if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
return SUCCESS;
}
+/* Return true, if the symbol is an external procedure. */
+static bool
+is_external_proc (gfc_symbol *sym)
+{
+ if (!sym->attr.dummy && !sym->attr.contained
+ && !(sym->attr.intrinsic
+ || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
+ && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.use_assoc
+ && sym->name)
+ return true;
+
+ return false;
+}
+
+
/* Figure out if a function reference is pure or not. Also set the name
of the function for a potential error message. Return nonzero if the
function is PURE, zero if not. */
+static int
+pure_stmt_function (gfc_expr *, gfc_symbol *);
static int
pure_function (gfc_expr *e, const char **name)
if (e->symtree != NULL
&& e->symtree->n.sym != NULL
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
- return 1;
+ return pure_stmt_function (e, e->symtree->n.sym);
if (e->value.function.esym)
{
}
-static try
+static bool
+impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
+ int *f ATTRIBUTE_UNUSED)
+{
+ const char *name;
+
+ /* Don't bother recursing into other statement functions
+ since they will be checked individually for purity. */
+ if (e->expr_type != EXPR_FUNCTION
+ || !e->symtree
+ || e->symtree->n.sym == sym
+ || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
+ return false;
+
+ return pure_function (e, &name) ? false : true;
+}
+
+
+static int
+pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
+{
+ return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
+}
+
+
+static gfc_try
is_scalar_expr_ptr (gfc_expr *expr)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
gfc_ref *ref;
int start;
int end;
and, in the case of c_associated, set the binding label based on
the arguments. */
-static try
+static gfc_try
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
int optional_arg = 0;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
+ gfc_typespec *arg_ts;
+ gfc_ref *parent_ref;
+ gfc_ref *curr_ref;
+
+ if (args->expr->expr_type == EXPR_CONSTANT
+ || args->expr->expr_type == EXPR_OP
+ || args->expr->expr_type == EXPR_NULL)
+ {
+ gfc_error ("Argument to '%s' at %L is not a variable",
+ sym->name, &(args->expr->where));
+ return FAILURE;
+ }
args_sym = args->expr->symtree->n.sym;
-
+
+ /* The typespec for the actual arg should be that stored in the expr
+ and not necessarily that of the expr symbol (args_sym), because
+ the actual expression could be a part-ref of the expr symbol. */
+ arg_ts = &(args->expr->ts);
+
+ /* Get the parent reference (if any) for the expression. This happens for
+ cases such as a%b%c. */
+ parent_ref = args->expr->ref;
+ curr_ref = NULL;
+ if (parent_ref != NULL)
+ {
+ curr_ref = parent_ref->next;
+ while (curr_ref != NULL && curr_ref->next != NULL)
+ {
+ parent_ref = curr_ref;
+ curr_ref = curr_ref->next;
+ }
+ }
+
+ /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
+ is for a REF_COMPONENT, then we need to use it as the parent_ref for
+ the name, etc. Otherwise, the current parent_ref should be correct. */
+ if (curr_ref != NULL && curr_ref->type == REF_COMPONENT)
+ parent_ref = curr_ref;
+
+ if (parent_ref == args->expr->ref)
+ parent_ref = NULL;
+ else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT)
+ gfc_internal_error ("Unexpected expression reference type in "
+ "gfc_iso_c_func_interface");
+
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
/* If the user gave two args then they are providing something for
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
/* Make sure we have either the target or pointer attribute. */
- if (!(args->expr->symtree->n.sym->attr.target)
- && !(args->expr->symtree->n.sym->attr.pointer))
+ if (!(args_sym->attr.target)
+ && !(args_sym->attr.pointer)
+ && (parent_ref == NULL ||
+ !parent_ref->u.c.component->attr.pointer))
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
- args->expr->symtree->n.sym->name,
+ args_sym->name,
sym->name, &(args->expr->where));
retval = FAILURE;
}
/* See if we have interoperable type and type param. */
- if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
- args->expr->symtree->n.sym->name,
+ if (verify_c_interop (arg_ts,
+ (parent_ref ? parent_ref->u.c.component->name
+ : args_sym->name),
&(args->expr->where)) == SUCCESS
- || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
+ || gfc_check_any_c_kind (arg_ts) == SUCCESS)
{
if (args_sym->attr.target == 1)
{
}
}
else
- {
+ {
+ /* A non-allocatable target variable with C
+ interoperable type and type parameters must be
+ interoperable. */
+ if (args_sym && args_sym->attr.dimension)
+ {
+ if (args_sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Assumed-shape array '%s' at %L "
+ "cannot be an argument to the "
+ "procedure '%s' because "
+ "it is not C interoperable",
+ args_sym->name,
+ &(args->expr->where), sym->name);
+ retval = FAILURE;
+ }
+ else if (args_sym->as->type == AS_DEFERRED)
+ {
+ gfc_error ("Deferred-shape array '%s' at %L "
+ "cannot be an argument to the "
+ "procedure '%s' because "
+ "it is not C interoperable",
+ args_sym->name,
+ &(args->expr->where), sym->name);
+ retval = FAILURE;
+ }
+ }
+
/* Make sure it's not a character string. Arrays of
any type should be ok if the variable is of a C
interoperable type. */
- if (args_sym->ts.type == BT_CHARACTER
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- gfc_error_now ("CHARACTER argument '%s' to '%s' at "
- "%L must have a length of 1",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
+ if (arg_ts->type == BT_CHARACTER)
+ if (arg_ts->cl != NULL
+ && (arg_ts->cl->length == NULL
+ || arg_ts->cl->length->expr_type
+ != EXPR_CONSTANT
+ || mpz_cmp_si
+ (arg_ts->cl->length->value.integer, 1)
+ != 0)
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ gfc_error_now ("CHARACTER argument '%s' to '%s' "
+ "at %L must have a length of 1",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
}
}
- else if (args_sym->attr.pointer == 1
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ else if ((args_sym->attr.pointer == 1 ||
+ (parent_ref != NULL
+ && parent_ref->u.c.component->attr.pointer))
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
{
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
scalar pointer. */
with no length type parameters. It still must have either
the pointer or target attribute, and it can be
allocatable (but must be allocated when c_loc is called). */
- if (args_sym->attr.dimension != 0
+ if (args->expr->rank != 0
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
&(args->expr->where));
retval = FAILURE;
}
- else if (args_sym->ts.type == BT_CHARACTER
- && args_sym->ts.cl != NULL)
+ else if (arg_ts->type == BT_CHARACTER
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
{
- gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
- "cannot have a length type parameter",
+ gfc_error_now ("CHARACTER argument '%s' to '%s' at "
+ "%L must have a length of 1",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
- if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
+ if (args_sym->attr.flavor != FL_PROCEDURE)
{
/* TODO: Update this error message to allow for procedure
pointers once they are implemented. */
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
"procedure",
- args->expr->symtree->n.sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
- "interoperable",
- args->expr->symtree->n.sym->name, sym->name,
+ args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
+ else if (args_sym->attr.is_bind_c != 1)
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be "
+ "BIND(C)",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
}
/* for c_loc/c_funloc, the new symbol is the same as the old one */
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
to INTENT(OUT) or INTENT(INOUT). */
-static try
+static gfc_try
resolve_function (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_symbol *sym;
const char *name;
- try t;
+ gfc_try t;
int temp;
procedure_type p = PROC_INTRINSIC;
return FAILURE;
}
- /* If the procedure is not internal, a statement function or a module
- procedure,it must be external and should be checked for usage. */
- if (sym && !sym->attr.dummy && !sym->attr.contained
- && sym->attr.proc != PROC_ST_FUNCTION
- && !sym->attr.use_assoc
- && sym->name )
+ if (sym && sym->attr.abstract)
+ {
+ gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+ sym->name, &expr->where);
+ return FAILURE;
+ }
+
+ /* If the procedure is external, check for usage. */
+ if (sym && is_external_proc (sym))
resolve_global_procedure (sym, &expr->where, 0);
/* Switch off assumed size checking and do this again for certain kinds
gfc_expr_set_symbols_referenced (expr->ts.cl->length);
}
- if (t == SUCCESS)
+ if (t == SUCCESS
+ && !((expr->value.function.esym
+ && expr->value.function.esym->attr.elemental)
+ ||
+ (expr->value.function.isym
+ && expr->value.function.isym->elemental)))
find_noncopying_intrinsics (expr->value.function.esym,
expr->value.function.actual);
}
-static try
+static gfc_try
resolve_generic_s (gfc_code *c)
{
gfc_symbol *sym;
that possesses a matching interface. 14.1.2.4 */
sym = c->symtree->n.sym;
- if (!gfc_intrinsic_name (sym->name, 1))
+ if (!gfc_is_intrinsic (sym, 1, c->loc))
{
gfc_error ("There is no specific subroutine for the generic '%s' at %L",
sym->name, &c->loc);
type = gfc_type_letter (arg->ts.type);
kind = arg->ts.kind;
}
+
+ if (arg->ts.type == BT_CHARACTER)
+ /* Kind info for character strings not needed. */
+ kind = 0;
+
sprintf (name, "%s_%c%d", sym->name, type, kind);
/* Set up the binding label as the given symbol's label plus
the type and kind. */
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
/* default to success; will override if find error */
match m = MATCH_YES;
- gfc_symbol *tmp_sym;
+
+ /* Make sure the actual arguments are in the necessary order (based on the
+ formal args) before resolving. */
+ gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
{
- /* Make sure we got a third arg. The type/rank of it will
- be checked later if it's there (gfc_procedure_use()). */
- if (c->ext.actual->next->expr->rank != 0 &&
- c->ext.actual->next->next == NULL)
+ /* Make sure we got a third arg if the second arg has non-zero
+ rank. We must also check that the type and rank are
+ correct since we short-circuit this check in
+ gfc_procedure_use() (called above to sort actual args). */
+ if (c->ext.actual->next->expr->rank != 0)
{
- m = MATCH_ERROR;
- gfc_error ("Missing SHAPE parameter for call to %s "
- "at %L", sym->name, &(c->loc));
+ if(c->ext.actual->next->next == NULL
+ || c->ext.actual->next->next->expr == NULL)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Missing SHAPE parameter for call to %s "
+ "at %L", sym->name, &(c->loc));
+ }
+ else if (c->ext.actual->next->next->expr->ts.type
+ != BT_INTEGER
+ || c->ext.actual->next->next->expr->rank != 1)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("SHAPE parameter for call to %s at %L must "
+ "be a rank 1 INTEGER array", sym->name,
+ &(c->loc));
+ }
}
- /* Make sure the param is a POINTER. No need to make sure
- it does not have INTENT(IN) since it is a POINTER. */
- tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
- if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
- {
- gfc_error ("Argument '%s' to '%s' at %L "
- "must have the POINTER attribute",
- tmp_sym->name, sym->name, &(c->loc));
- m = MATCH_ERROR;
- }
}
}
new_sym->declared_at = sym->declared_at;
}
}
- else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
- {
- /* TODO: Figure out if this is even reacable; this part of the
- conditional may not be necessary. */
- int num_args = 0;
- if (c->ext.actual->next == NULL)
- {
- /* The user did not give two args, so resolve to the version
- of c_associated expecting one arg. */
- num_args = 1;
- /* get rid of the second arg */
- /* TODO!! Should free up the memory here! */
- sym->formal->next = NULL;
- }
- else
- {
- num_args = 2;
- }
-
- new_sym = sym;
- sprintf (name, "%s_%d", sym->name, num_args);
- sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
- sym->name = gfc_get_string (name);
- strcpy (sym->binding_label, binding_label);
- }
else
{
/* no differences for c_loc or c_funloc */
/* set the resolved symbol */
if (m != MATCH_ERROR)
- {
- gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
- c->resolved_sym = new_sym;
- }
+ c->resolved_sym = new_sym;
else
c->resolved_sym = sym;
{
match m;
+ /* See if we have an intrinsic interface. */
+ if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
+ && !sym->ts.interface->attr.subroutine)
+ {
+ gfc_intrinsic_sym *isym;
+
+ isym = gfc_find_function (sym->ts.interface->name);
+
+ /* Existence of isym should be checked already. */
+ gcc_assert (isym);
+
+ sym->ts.type = isym->ts.type;
+ sym->ts.kind = isym->ts.kind;
+ sym->attr.subroutine = 1;
+ goto found;
+ }
+
if(sym->attr.is_iso_c)
{
m = gfc_iso_c_sub_interface (c,sym);
}
-static try
+static gfc_try
resolve_specific_s (gfc_code *c)
{
gfc_symbol *sym;
/* Resolve a subroutine call not known to be generic nor specific. */
-static try
+static gfc_try
resolve_unknown_s (gfc_code *c)
{
gfc_symbol *sym;
/* See if we have an intrinsic function reference. */
- if (gfc_intrinsic_name (sym->name, 1))
+ if (gfc_is_intrinsic (sym, 1, c->loc))
{
if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
return SUCCESS;
for functions, subroutines and functions are stored differently and this
makes things awkward. */
-static try
+static gfc_try
resolve_call (gfc_code *c)
{
- try t;
+ gfc_try t;
procedure_type ptype = PROC_INTRINSIC;
if (c->symtree && c->symtree->n.sym
return FAILURE;
}
- /* If the procedure is not internal or module, it must be external and
- should be checked for usage. */
- if (c->symtree && c->symtree->n.sym
- && !c->symtree->n.sym->attr.dummy
- && !c->symtree->n.sym->attr.contained
- && !c->symtree->n.sym->attr.use_assoc)
+ /* If external, check for usage. */
+ if (c->symtree && is_external_proc (c->symtree->n.sym))
resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
/* Subroutines without the RECURSIVE attribution are not allowed to
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
- if (t == SUCCESS)
+ if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
if their shapes do not match. If either op1->shape or op2->shape is
NULL, return SUCCESS. */
-static try
+static gfc_try
compare_shapes (gfc_expr *op1, gfc_expr *op2)
{
- try t;
+ gfc_try t;
int i;
t = SUCCESS;
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
-static try
+static gfc_try
resolve_operator (gfc_expr *e)
{
gfc_expr *op1, *op2;
char msg[200];
bool dual_locus_error;
- try t;
+ gfc_try t;
/* Resolve all subnodes-- give them types. */
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
default:
if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
goto bad_op;
}
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
}
sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
goto bad_op;
case INTRINSIC_PLUS:
sprintf (msg,
_("Operands of binary numeric operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_CONCAT:
- if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && op1->ts.kind == op2->ts.kind)
{
e->ts.type = BT_CHARACTER;
e->ts.kind = op1->ts.kind;
}
sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
break;
}
- sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
+ sprintf (msg, _("Operand of .not. operator at %%L is %s"),
gfc_typename (&op1->ts));
goto bad_op;
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
/* Fall through... */
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
- if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
+ case INTRINSIC_NE_OS:
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && op1->ts.kind == op2->ts.kind)
{
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
sprintf (msg,
_("Logicals at %%L must be compared with %s instead of %s"),
- e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
- gfc_op2string (e->value.op.operator));
+ (e->value.op.op == INTRINSIC_EQ
+ || e->value.op.op == INTRINSIC_EQ_OS)
+ ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
else
sprintf (msg,
_("Operands of comparison operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_USER:
- if (e->value.op.uop->operator == NULL)
+ if (e->value.op.uop->op == NULL)
sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
goto bad_op;
case INTRINSIC_PARENTHESES:
+ e->ts = op1->ts;
+ if (e->ts.type == BT_CHARACTER)
+ e->ts.cl = op1->ts.cl;
break;
default:
t = SUCCESS;
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
if (op1->rank == 0 && op2->rank == 0)
e->rank = 0;
break;
+ case INTRINSIC_PARENTHESES:
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
- case INTRINSIC_PARENTHESES:
+ /* Simply copy arrayness attribute */
e->rank = op1->rank;
if (e->shape == NULL)
e->shape = gfc_copy_shape (op1->shape, op1->rank);
- /* Simply copy arrayness attribute */
break;
default:
{
t = gfc_simplify_expr (e, 0);
/* Some calls do not succeed in simplification and return FAILURE
- even though there is no error; eg. variable references to
+ even though there is no error; e.g. variable references to
PARAMETER arrays. */
if (!gfc_is_constant_expr (e))
t = SUCCESS;
|| b == NULL || b->expr_type != EXPR_CONSTANT)
return CMP_UNKNOWN;
+ /* If either of the types isn't INTEGER, we must have
+ raised an error earlier. */
+
if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
- gfc_internal_error ("compare_bound(): Bad expression");
+ return CMP_UNKNOWN;
i = mpz_cmp (a->value.integer, b->value.integer);
/* Compare a single dimension of an array reference to the array
specification. */
-static try
+static gfc_try
check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
{
mpz_t last_value;
/* Given start, end and stride values, calculate the minimum and
maximum referenced indexes. */
- switch (ar->type)
+ switch (ar->dimen_type[i])
{
- case AR_FULL:
+ case DIMEN_VECTOR:
break;
- case AR_ELEMENT:
+ case DIMEN_ELEMENT:
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
- goto bound;
+ {
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer), i+1);
+ return SUCCESS;
+ }
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
- goto bound;
+ {
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer), i+1);
+ return SUCCESS;
+ }
break;
- case AR_SECTION:
+ case DIMEN_RANGE:
{
#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
|| (compare_bound_int (ar->stride[i], 0) == CMP_LT
&& comp_start_end == CMP_GT))
{
- if (compare_bound (AR_START, as->lower[i]) == CMP_LT
- || compare_bound (AR_START, as->upper[i]) == CMP_GT)
- goto bound;
+ if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
+ {
+ gfc_warning ("Lower array reference at %L is out of bounds "
+ "(%ld < %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (AR_START->value.integer),
+ mpz_get_si (as->lower[i]->value.integer), i+1);
+ return SUCCESS;
+ }
+ if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
+ {
+ gfc_warning ("Lower array reference at %L is out of bounds "
+ "(%ld > %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (AR_START->value.integer),
+ mpz_get_si (as->upper[i]->value.integer), i+1);
+ return SUCCESS;
+ }
}
/* If we can compute the highest index of the array section,
if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
last_value))
{
- if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
- || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
+ if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
+ {
+ gfc_warning ("Upper array reference at %L is out of bounds "
+ "(%ld < %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (last_value),
+ mpz_get_si (as->lower[i]->value.integer), i+1);
+ mpz_clear (last_value);
+ return SUCCESS;
+ }
+ if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
{
+ gfc_warning ("Upper array reference at %L is out of bounds "
+ "(%ld > %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (last_value),
+ mpz_get_si (as->upper[i]->value.integer), i+1);
mpz_clear (last_value);
- goto bound;
+ return SUCCESS;
}
}
mpz_clear (last_value);
}
return SUCCESS;
-
-bound:
- gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
- return SUCCESS;
}
/* Compare an array reference with an array specification. */
-static try
+static gfc_try
compare_spec_to_ref (gfc_array_ref *ar)
{
gfc_array_spec *as;
/* Resolve one part of an array index. */
-try
+gfc_try
gfc_resolve_index (gfc_expr *index, int check_scalar)
{
gfc_typespec ts;
if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
{
- gfc_error ("Array index at %L must be of INTEGER type",
- &index->where);
+ gfc_error ("Array index at %L must be of INTEGER type, found %s",
+ &index->where, gfc_basic_typename (index->ts.type));
return FAILURE;
}
/* Resolve a dim argument to an intrinsic function. */
-try
+gfc_try
gfc_resolve_dim_arg (gfc_expr *dim)
{
if (dim == NULL)
return FAILURE;
}
+
if (dim->ts.type != BT_INTEGER)
{
gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
return FAILURE;
}
+
if (dim->ts.kind != gfc_index_integer_kind)
{
gfc_typespec ts;
if (c == NULL)
gfc_internal_error ("find_array_spec(): Component not found");
- if (c->dimension)
+ if (c->attr.dimension)
{
if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(1)");
/* Resolve an array reference. */
-static try
+static gfc_try
resolve_array_ref (gfc_array_ref *ar)
{
int i, check_scalar;
}
-static try
+static gfc_try
resolve_substring (gfc_ref *ref)
{
if (ref->u.ss.start != NULL)
}
+/* This function supplies missing substring charlens. */
+
+void
+gfc_resolve_substring_charlen (gfc_expr *e)
+{
+ gfc_ref *char_ref;
+ gfc_expr *start, *end;
+
+ for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
+ if (char_ref->type == REF_SUBSTRING)
+ break;
+
+ if (!char_ref)
+ return;
+
+ gcc_assert (char_ref->next == NULL);
+
+ if (e->ts.cl)
+ {
+ if (e->ts.cl->length)
+ gfc_free_expr (e->ts.cl->length);
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy)
+ return;
+ }
+
+ e->ts.type = BT_CHARACTER;
+ e->ts.kind = gfc_default_character_kind;
+
+ if (!e->ts.cl)
+ {
+ e->ts.cl = gfc_get_charlen ();
+ e->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = e->ts.cl;
+ }
+
+ if (char_ref->u.ss.start)
+ start = gfc_copy_expr (char_ref->u.ss.start);
+ else
+ start = gfc_int_expr (1);
+
+ if (char_ref->u.ss.end)
+ end = gfc_copy_expr (char_ref->u.ss.end);
+ else if (e->expr_type == EXPR_VARIABLE)
+ end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
+ else
+ end = NULL;
+
+ if (!start || !end)
+ return;
+
+ /* Length = (end - start +1). */
+ e->ts.cl->length = gfc_subtract (end, start);
+ e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
+
+ e->ts.cl->length->ts.type = BT_INTEGER;
+ e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+
+ /* Make sure that the length is simplified. */
+ gfc_simplify_expr (e->ts.cl->length, 1);
+ gfc_resolve_expr (e->ts.cl->length);
+}
+
+
/* Resolve subtype references. */
-static try
+static gfc_try
resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension;
case REF_COMPONENT:
if (current_part_dimension || seen_part_dimension)
{
- if (ref->u.c.component->pointer)
+ if (ref->u.c.component->attr.pointer)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the POINTER "
"attribute at %L", &expr->where);
return FAILURE;
}
- else if (ref->u.c.component->allocatable)
+ else if (ref->u.c.component->attr.allocatable)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the ALLOCATABLE "
/* Resolve a variable expression. */
-static try
+static gfc_try
resolve_variable (gfc_expr *e)
{
gfc_symbol *sym;
- try t;
+ gfc_try t;
t = SUCCESS;
bool seen;
/* If the symbol is a dummy... */
- if (sym->attr.dummy)
+ if (sym->attr.dummy && sym->ns == gfc_current_ns)
{
entry = gfc_current_ns->entries;
seen = false;
if (!seen)
{
if (specification_expr)
- gfc_error ("Variable '%s',used in a specification expression, "
- "is referenced at %L before the ENTRY statement "
+ gfc_error ("Variable '%s', used in a specification expression"
+ ", is referenced at %L before the ENTRY statement "
"in which it is a parameter",
sym->name, &cs_base->current->loc);
else
return retval;
if (gfc_current_ns->parent
- && gfc_current_ns->parent->parent
&& old_sym->ns != gfc_current_ns)
{
- gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
- if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
+ gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
+ if (sym && old_sym != sym
+ && sym->attr.flavor == FL_PROCEDURE
+ && sym->attr.contained)
{
temp_locus = gfc_current_locus;
gfc_current_locus = e->where;
}
-/* Resolve an expression. That is, make sure that types of operands agree
- with their operators, intrinsic operators are converted to function calls
- for overloaded types and unresolved function references are resolved. */
-
-try
-gfc_resolve_expr (gfc_expr *e)
+static void
+gfc_resolve_character_operator (gfc_expr *e)
{
- try t;
+ gfc_expr *op1 = e->value.op.op1;
+ gfc_expr *op2 = e->value.op.op2;
+ gfc_expr *e1 = NULL;
+ gfc_expr *e2 = NULL;
- if (e == NULL)
- return SUCCESS;
+ gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
+ if (op1->ts.cl && op1->ts.cl->length)
+ e1 = gfc_copy_expr (op1->ts.cl->length);
+ else if (op1->expr_type == EXPR_CONSTANT)
+ e1 = gfc_int_expr (op1->value.character.length);
+
+ if (op2->ts.cl && op2->ts.cl->length)
+ e2 = gfc_copy_expr (op2->ts.cl->length);
+ else if (op2->expr_type == EXPR_CONSTANT)
+ e2 = gfc_int_expr (op2->value.character.length);
+
+ e->ts.cl = gfc_get_charlen ();
+ e->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = e->ts.cl;
+
+ if (!e1 || !e2)
+ return;
+
+ e->ts.cl->length = gfc_add (e1, e2);
+ e->ts.cl->length->ts.type = BT_INTEGER;
+ e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+ gfc_simplify_expr (e->ts.cl->length, 0);
+ gfc_resolve_expr (e->ts.cl->length);
+
+ return;
+}
+
+
+/* Ensure that an character expression has a charlen and, if possible, a
+ length expression. */
+
+static void
+fixup_charlen (gfc_expr *e)
+{
+ /* The cases fall through so that changes in expression type and the need
+ for multiple fixes are picked up. In all circumstances, a charlen should
+ be available for the middle end to hang a backend_decl on. */
switch (e->expr_type)
{
case EXPR_OP:
- t = resolve_operator (e);
- break;
+ gfc_resolve_character_operator (e);
- case EXPR_FUNCTION:
+ case EXPR_ARRAY:
+ if (e->expr_type == EXPR_ARRAY)
+ gfc_resolve_character_array_constructor (e);
+
+ case EXPR_SUBSTRING:
+ if (!e->ts.cl && e->ref)
+ gfc_resolve_substring_charlen (e);
+
+ default:
+ if (!e->ts.cl)
+ {
+ e->ts.cl = gfc_get_charlen ();
+ e->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = e->ts.cl;
+ }
+
+ break;
+ }
+}
+
+
+/* Resolve an expression. That is, make sure that types of operands agree
+ with their operators, intrinsic operators are converted to function calls
+ for overloaded types and unresolved function references are resolved. */
+
+gfc_try
+gfc_resolve_expr (gfc_expr *e)
+{
+ gfc_try t;
+
+ if (e == NULL)
+ return SUCCESS;
+
+ switch (e->expr_type)
+ {
+ case EXPR_OP:
+ t = resolve_operator (e);
+ break;
+
+ case EXPR_FUNCTION:
case EXPR_VARIABLE:
if (check_host_association (e))
if (t == SUCCESS)
expression_rank (e);
}
+
+ if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
+ && e->ref->type != REF_SUBSTRING)
+ gfc_resolve_substring_charlen (e);
+
break;
case EXPR_SUBSTRING:
}
/* This provides the opportunity for the length of constructors with
- character valued function elements to propogate the string length
+ character valued function elements to propagate the string length
to the expression. */
- if (e->ts.type == BT_CHARACTER)
- gfc_resolve_character_array_constructor (e);
+ if (t == SUCCESS && e->ts.type == BT_CHARACTER)
+ t = gfc_resolve_character_array_constructor (e);
break;
gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
}
+ if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
+ fixup_charlen (e);
+
return t;
}
/* Resolve an expression from an iterator. They must be scalar and have
INTEGER or (optionally) REAL type. */
-static try
+static gfc_try
gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
const char *name_msgid)
{
/* Resolve the expressions in an iterator structure. If REAL_OK is
false allow only INTEGER type iterators, otherwise allow REAL types. */
-try
+gfc_try
gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
{
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
}
+/* Traversal function for find_forall_index. f == 2 signals that
+ that variable itself is not to be checked - only the references. */
+
+static bool
+forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
+{
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+
+ /* A scalar assignment */
+ if (!expr->ref || *f == 1)
+ {
+ if (expr->symtree->n.sym == sym)
+ return true;
+ else
+ return false;
+ }
+
+ if (*f == 2)
+ *f = 1;
+ return false;
+}
+
+
+/* Check whether the FORALL index appears in the expression or not.
+ Returns SUCCESS if SYM is found in EXPR. */
+
+gfc_try
+find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
+{
+ if (gfc_traverse_expr (expr, sym, forall_index, f))
+ return SUCCESS;
+ else
+ return FAILURE;
+}
+
+
/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
to be a scalar INTEGER variable. The subscripts and stride are scalar
- INTEGERs, and if stride is a constant it must be nonzero. */
+ INTEGERs, and if stride is a constant it must be nonzero.
+ Furthermore "A subscript or stride in a forall-triplet-spec shall
+ not contain a reference to any index-name in the
+ forall-triplet-spec-list in which it appears." (7.5.4.1) */
static void
-resolve_forall_iterators (gfc_forall_iterator *iter)
+resolve_forall_iterators (gfc_forall_iterator *it)
{
- while (iter)
+ gfc_forall_iterator *iter, *iter2;
+
+ for (iter = it; iter; iter = iter->next)
{
if (gfc_resolve_expr (iter->var) == SUCCESS
&& (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
}
if (iter->var->ts.kind != iter->stride->ts.kind)
gfc_convert_type (iter->stride, &iter->var->ts, 2);
-
- iter = iter->next;
- }
-}
-
-
-/* Given a pointer to a symbol that is a derived type, see if any components
- have the POINTER attribute. The search is recursive if necessary.
- Returns zero if no pointer components are found, nonzero otherwise. */
-
-static int
-derived_pointer (gfc_symbol *sym)
-{
- gfc_component *c;
-
- for (c = sym->components; c; c = c->next)
- {
- if (c->pointer)
- return 1;
-
- if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
- return 1;
}
- return 0;
+ for (iter = it; iter; iter = iter->next)
+ for (iter2 = iter; iter2; iter2 = iter2->next)
+ {
+ if (find_forall_index (iter2->start,
+ iter->var->symtree->n.sym, 0) == SUCCESS
+ || find_forall_index (iter2->end,
+ iter->var->symtree->n.sym, 0) == SUCCESS
+ || find_forall_index (iter2->stride,
+ iter->var->symtree->n.sym, 0) == SUCCESS)
+ gfc_error ("FORALL index '%s' may not appear in triplet "
+ "specification at %L", iter->var->symtree->name,
+ &iter2->start->where);
+ }
}
{
gfc_component *c;
- if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
+ if (sym->attr.use_assoc && sym->attr.private_comp)
return 1;
for (c = sym->components; c; c = c->next)
/* Resolve the argument of a deallocate expression. The expression must be
a pointer or a full array. */
-static try
+static gfc_try
resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
+ pointer = ref->u.c.component->attr.pointer;
break;
case REF_SUBSTRING:
}
-/* Returns true if the expression e contains a reference the symbol sym. */
+/* Returns true if the expression e contains a reference to the symbol sym. */
static bool
-find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{
- gfc_actual_arglist *arg;
- gfc_ref *ref;
- int i;
- bool rv = false;
-
- if (e == NULL)
- return rv;
-
- switch (e->expr_type)
- {
- case EXPR_FUNCTION:
- for (arg = e->value.function.actual; arg; arg = arg->next)
- rv = rv || find_sym_in_expr (sym, arg->expr);
- break;
-
- /* If the variable is not the same as the dependent, 'sym', and
- it is not marked as being declared and it is in the same
- namespace as 'sym', add it to the local declarations. */
- case EXPR_VARIABLE:
- if (sym == e->symtree->n.sym)
- return true;
- break;
-
- case EXPR_OP:
- rv = rv || find_sym_in_expr (sym, e->value.op.op1);
- rv = rv || find_sym_in_expr (sym, e->value.op.op2);
- break;
-
- default:
- break;
- }
+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
+ return true;
- if (e->ref)
- {
- for (ref = e->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- for (i = 0; i < ref->u.ar.dimen; i++)
- {
- rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
- rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
- rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
- }
- break;
-
- case REF_SUBSTRING:
- rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
- rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
- break;
-
- case REF_COMPONENT:
- if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl->length->expr_type
- != EXPR_CONSTANT)
- rv = rv
- || find_sym_in_expr (sym,
- ref->u.c.component->ts.cl->length);
+ return false;
+}
- if (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank; i++)
- {
- rv = rv
- || find_sym_in_expr (sym,
- ref->u.c.component->as->lower[i]);
- rv = rv
- || find_sym_in_expr (sym,
- ref->u.c.component->as->upper[i]);
- }
- break;
- }
- }
- }
- return rv;
+bool
+gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+{
+ return gfc_traverse_expr (e, sym, sym_in_expr, 0);
}
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
-static try
+static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in;
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
- dimension = ref->u.c.component->dimension;
+ pointer = ref->u.c.component->attr.pointer;
+ dimension = ref->u.c.component->attr.dimension;
break;
case REF_SUBSTRING:
if (sym->ts.type == BT_DERIVED)
continue;
- if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
- || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
+ if ((ar->start[i] != NULL
+ && gfc_find_sym_in_expr (sym, ar->start[i]))
+ || (ar->end[i] != NULL
+ && gfc_find_sym_in_expr (sym, ar->end[i])))
{
- gfc_error ("'%s' must not appear an the array specification at "
+ gfc_error ("'%s' must not appear in the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
return FAILURE;
return SUCCESS;
}
+static void
+resolve_allocate_deallocate (gfc_code *code, const char *fcn)
+{
+ gfc_symbol *s = NULL;
+ gfc_alloc *a;
+
+ if (code->expr)
+ s = code->expr->symtree->n.sym;
+
+ if (s)
+ {
+ if (s->attr.intent == INTENT_IN)
+ gfc_error ("STAT variable '%s' of %s statement at %C cannot "
+ "be INTENT(IN)", s->name, fcn);
+
+ if (gfc_pure (NULL) && gfc_impure_variable (s))
+ gfc_error ("Illegal STAT variable in %s statement at %C "
+ "for a PURE procedure", fcn);
+ }
+
+ if (s && code->expr->ts.type != BT_INTEGER)
+ gfc_error ("STAT tag in %s statement at %L must be "
+ "of type INTEGER", fcn, &code->expr->where);
+
+ if (strcmp (fcn, "ALLOCATE") == 0)
+ {
+ for (a = code->ext.alloc_list; a; a = a->next)
+ resolve_allocate_expr (a->expr, code);
+ }
+ else
+ {
+ for (a = code->ext.alloc_list; a; a = a->next)
+ resolve_deallocate_expr (a->expr);
+ }
+}
/************ SELECT CASE resolution subroutines ************/
retval = 0;
/* op2 = (M:) or (M:N), L < M */
if (op2->low != NULL
- && gfc_compare_expr (op1->high, op2->low) < 0)
+ && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1;
}
else if (op1->high == NULL) /* op1 = (K:) */
retval = 0;
/* op2 = (:N) or (M:N), K > N */
if (op2->high != NULL
- && gfc_compare_expr (op1->low, op2->high) > 0)
+ && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
retval = 1;
}
else /* op1 = (K:L) */
{
if (op2->low == NULL) /* op2 = (:N), K > N */
- retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
+ retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
+ ? 1 : 0;
else if (op2->high == NULL) /* op2 = (M:), L < M */
- retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
+ retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
+ ? -1 : 0;
else /* op2 = (M:N) */
{
retval = 0;
/* L < M */
- if (gfc_compare_expr (op1->high, op2->low) < 0)
+ if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1;
/* K > N */
- else if (gfc_compare_expr (op1->low, op2->high) > 0)
+ else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
retval = 1;
}
}
Makes sure that all case expressions are scalar constants of the same
type. Return FAILURE if anything is wrong. */
-static try
+static gfc_try
validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
{
if (e == NULL) return SUCCESS;
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
- gfc_error("Expression in CASE statement at %L must be kind %d",
- &e->where, case_expr->ts.kind);
+ gfc_error ("Expression in CASE statement at %L must be of kind %d",
+ &e->where, case_expr->ts.kind);
return FAILURE;
}
int seen_logical;
int ncases;
bt type;
- try t;
+ gfc_try t;
if (code->expr == NULL)
{
/* Unreachable case ranges are discarded, so ignore. */
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
- && gfc_compare_expr (cp->low, cp->high) > 0)
+ && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
continue;
/* FIXME: Should a warning be issued? */
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
- && gfc_compare_expr (cp->low, cp->high) > 0)
+ && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
{
if (gfc_option.warn_surprising)
gfc_warning ("Range specification at %L can never "
{
/* Check that transferred derived type doesn't contain POINTER
components. */
- if (derived_pointer (ts->derived))
+ if (ts->derived->attr.pointer_comp)
{
gfc_error ("Data transfer element at %L cannot have "
"POINTER components", &code->loc);
if (code->here == label)
{
- gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
+ gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
return;
}
/* Check whether EXPR1 has the same shape as EXPR2. */
-static try
+static gfc_try
resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
mpz_t shape2[GFC_MAX_DIMENSIONS];
- try result = FAILURE;
+ gfc_try result = FAILURE;
int i;
/* Compare the rank. */
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
+ if (!cnext->resolved_sym->attr.elemental)
+ gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
+ &cnext->ext.actual->expr->where);
break;
/* WHERE or WHERE construct is part of a where-body-construct */
}
-/* Check whether the FORALL index appears in the expression or not. */
-
-static try
-gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
-{
- gfc_array_ref ar;
- gfc_ref *tmp;
- gfc_actual_arglist *args;
- int i;
-
- switch (expr->expr_type)
- {
- case EXPR_VARIABLE:
- gcc_assert (expr->symtree->n.sym);
-
- /* A scalar assignment */
- if (!expr->ref)
- {
- if (expr->symtree->n.sym == symbol)
- return SUCCESS;
- else
- return FAILURE;
- }
-
- /* the expr is array ref, substring or struct component. */
- tmp = expr->ref;
- while (tmp != NULL)
- {
- switch (tmp->type)
- {
- case REF_ARRAY:
- /* Check if the symbol appears in the array subscript. */
- ar = tmp->u.ar;
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
- {
- if (ar.start[i])
- if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
- return SUCCESS;
-
- if (ar.end[i])
- if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
- return SUCCESS;
-
- if (ar.stride[i])
- if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
- return SUCCESS;
- } /* end for */
- break;
-
- case REF_SUBSTRING:
- if (expr->symtree->n.sym == symbol)
- return SUCCESS;
- tmp = expr->ref;
- /* Check if the symbol appears in the substring section. */
- if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
- return SUCCESS;
- if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
- return SUCCESS;
- break;
-
- case REF_COMPONENT:
- break;
-
- default:
- gfc_error("expression reference type error at %L", &expr->where);
- }
- tmp = tmp->next;
- }
- break;
-
- /* If the expression is a function call, then check if the symbol
- appears in the actual arglist of the function. */
- case EXPR_FUNCTION:
- for (args = expr->value.function.actual; args; args = args->next)
- {
- if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
- return SUCCESS;
- }
- break;
-
- /* It seems not to happen. */
- case EXPR_SUBSTRING:
- if (expr->ref)
- {
- tmp = expr->ref;
- gcc_assert (expr->ref->type == REF_SUBSTRING);
- if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
- return SUCCESS;
- if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
- return SUCCESS;
- }
- break;
-
- /* It seems not to happen. */
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- gfc_error ("Unsupported statement while finding forall index in "
- "expression");
- break;
-
- case EXPR_OP:
- /* Find the FORALL index in the first operand. */
- if (expr->value.op.op1)
- {
- if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
- return SUCCESS;
- }
-
- /* Find the FORALL index in the second operand. */
- if (expr->value.op.op2)
- {
- if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
- return SUCCESS;
- }
- break;
-
- default:
- break;
- }
-
- return FAILURE;
-}
-
-
/* Resolve assignment in FORALL construct.
NVAR is the number of FORALL index variables, and VAR_EXPR records the
FORALL index variables. */
/* If one of the FORALL index variables doesn't appear in the
assignment target, then there will be a many-to-one
assignment. */
- if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
+ if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
gfc_error ("The FORALL with index '%s' cause more than one "
"assignment to this object at %L",
var_expr[n]->symtree->name, &code->expr->where);
/* WHERE operator assignment statement */
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
+ if (!cnext->resolved_sym->attr.elemental)
+ gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
+ &cnext->ext.actual->expr->where);
break;
/* WHERE or WHERE construct is part of a where-body-construct */
static int total_var = 0;
static int nvar = 0;
gfc_forall_iterator *fa;
- gfc_symbol *forall_index;
gfc_code *next;
int i;
/* Record the current FORALL index. */
var_expr[nvar] = gfc_copy_expr (fa->var);
- forall_index = fa->var->symtree->n.sym;
-
- /* Check if the FORALL index appears in start, end or stride. */
- if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->start->where);
- if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->end->where);
- if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->stride->where);
nvar++;
}
void
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
- try t;
+ gfc_try t;
for (; b; b = b->block)
{
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
+ case EXEC_WAIT:
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKWAIT:
case EXEC_OMP_WORKSHARE:
break;
}
+/* Does everything to resolve an ordinary assignment. Returns true
+ if this is an interface assignment. */
+static bool
+resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
+{
+ bool rval = false;
+ gfc_expr *lhs;
+ gfc_expr *rhs;
+ int llen = 0;
+ int rlen = 0;
+ int n;
+ gfc_ref *ref;
+
+ if (gfc_extend_assign (code, ns) == SUCCESS)
+ {
+ lhs = code->ext.actual->expr;
+ rhs = code->ext.actual->next->expr;
+ if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
+ {
+ gfc_error ("Subroutine '%s' called instead of assignment at "
+ "%L must be PURE", code->symtree->n.sym->name,
+ &code->loc);
+ return rval;
+ }
+
+ /* Make a temporary rhs when there is a default initializer
+ and rhs is the same symbol as the lhs. */
+ if (rhs->expr_type == EXPR_VARIABLE
+ && rhs->symtree->n.sym->ts.type == BT_DERIVED
+ && has_default_initializer (rhs->symtree->n.sym->ts.derived)
+ && (lhs->symtree->n.sym == rhs->symtree->n.sym))
+ code->ext.actual->next->expr = gfc_get_parentheses (rhs);
+
+ return true;
+ }
+
+ lhs = code->expr;
+ rhs = code->expr2;
+
+ if (rhs->is_boz
+ && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
+ "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+ &code->loc) == FAILURE)
+ return false;
+
+ /* Handle the case of a BOZ literal on the RHS. */
+ if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
+ {
+ int rc;
+ if (gfc_option.warn_surprising)
+ gfc_warning ("BOZ literal at %L is bitwise transferred "
+ "non-integer symbol '%s'", &code->loc,
+ lhs->symtree->n.sym->name);
+
+ if (!gfc_convert_boz (rhs, &lhs->ts))
+ 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);
+ return false;
+ }
+ }
+
+
+ if (lhs->ts.type == BT_CHARACTER
+ && gfc_option.warn_character_truncation)
+ {
+ if (lhs->ts.cl != NULL
+ && lhs->ts.cl->length != NULL
+ && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
+ llen = mpz_get_si (lhs->ts.cl->length->value.integer);
+
+ if (rhs->expr_type == EXPR_CONSTANT)
+ rlen = rhs->value.character.length;
+
+ else if (rhs->ts.cl != NULL
+ && rhs->ts.cl->length != NULL
+ && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
+ rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
+
+ if (rlen && llen && rlen > llen)
+ gfc_warning_now ("CHARACTER expression will be truncated "
+ "in assignment (%d/%d) at %L",
+ llen, rlen, &code->loc);
+ }
+
+ /* Ensure that a vector index expression for the lvalue is evaluated
+ to a temporary if the lvalue symbol is referenced in it. */
+ if (lhs->rank)
+ {
+ for (ref = lhs->ref; ref; ref= ref->next)
+ if (ref->type == REF_ARRAY)
+ {
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
+ && gfc_find_sym_in_expr (lhs->symtree->n.sym,
+ ref->u.ar.start[n]))
+ ref->u.ar.start[n]
+ = gfc_get_parentheses (ref->u.ar.start[n]);
+ }
+ }
+
+ if (gfc_pure (NULL))
+ {
+ if (gfc_impure_variable (lhs->symtree->n.sym))
+ {
+ gfc_error ("Cannot assign to variable '%s' in PURE "
+ "procedure at %L",
+ lhs->symtree->n.sym->name,
+ &lhs->where);
+ return rval;
+ }
+
+ if (lhs->ts.type == BT_DERIVED
+ && lhs->expr_type == EXPR_VARIABLE
+ && lhs->ts.derived->attr.pointer_comp
+ && gfc_impure_variable (rhs->symtree->n.sym))
+ {
+ gfc_error ("The impure variable at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure (12.6)",
+ &rhs->where);
+ return rval;
+ }
+ }
+
+ gfc_check_assign (lhs, rhs, 1);
+ return false;
+}
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
int omp_workshare_save;
int forall_save;
code_stack frame;
- gfc_alloc *a;
- try t;
+ gfc_try t;
frame.prev = cs_base;
frame.head = code;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_parallel_blocks (code, ns);
if (t == FAILURE)
break;
- if (gfc_extend_assign (code, ns) == SUCCESS)
- {
- if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
- {
- gfc_error ("Subroutine '%s' called instead of assignment at "
- "%L must be PURE", code->symtree->n.sym->name,
- &code->loc);
- break;
- }
- goto call;
- }
-
- if (code->expr->ts.type == BT_CHARACTER
- && gfc_option.warn_character_truncation)
- {
- int llen = 0, rlen = 0;
-
- if (code->expr->ts.cl != NULL
- && code->expr->ts.cl->length != NULL
- && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
- llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
-
- if (code->expr2->expr_type == EXPR_CONSTANT)
- rlen = code->expr2->value.character.length;
-
- else if (code->expr2->ts.cl != NULL
- && code->expr2->ts.cl->length != NULL
- && code->expr2->ts.cl->length->expr_type
- == EXPR_CONSTANT)
- rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
-
- if (rlen && llen && rlen > llen)
- gfc_warning_now ("CHARACTER expression will be truncated "
- "in assignment (%d/%d) at %L",
- llen, rlen, &code->loc);
- }
-
- if (gfc_pure (NULL))
- {
- if (gfc_impure_variable (code->expr->symtree->n.sym))
- {
- gfc_error ("Cannot assign to variable '%s' in PURE "
- "procedure at %L",
- code->expr->symtree->n.sym->name,
- &code->expr->where);
- break;
- }
-
- if (code->expr->ts.type == BT_DERIVED
- && code->expr->expr_type == EXPR_VARIABLE
- && derived_pointer (code->expr->ts.derived)
- && gfc_impure_variable (code->expr2->symtree->n.sym))
- {
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
- &code->expr2->where);
- break;
- }
- }
+ if (resolve_ordinary_assign (code, ns))
+ goto call;
- gfc_check_assign (code->expr, code->expr2, 1);
break;
case EXEC_LABEL_ASSIGN:
break;
case EXEC_ALLOCATE:
- if (t == SUCCESS && code->expr != NULL
- && code->expr->ts.type != BT_INTEGER)
- gfc_error ("STAT tag in ALLOCATE statement at %L must be "
- "of type INTEGER", &code->expr->where);
-
- for (a = code->ext.alloc_list; a; a = a->next)
- resolve_allocate_expr (a->expr, code);
+ if (t == SUCCESS)
+ resolve_allocate_deallocate (code, "ALLOCATE");
break;
case EXEC_DEALLOCATE:
- if (t == SUCCESS && code->expr != NULL
- && code->expr->ts.type != BT_INTEGER)
- gfc_error
- ("STAT tag in DEALLOCATE statement at %L must be of type "
- "INTEGER", &code->expr->where);
-
- for (a = code->ext.alloc_list; a; a = a->next)
- resolve_deallocate_expr (a->expr);
+ if (t == SUCCESS)
+ resolve_allocate_deallocate (code, "DEALLOCATE");
break;
resolve_branch (code->ext.inquire->err, code);
break;
+ case EXEC_WAIT:
+ if (gfc_resolve_wait (code->ext.wait) == FAILURE)
+ break;
+
+ resolve_branch (code->ext.wait->err, code);
+ resolve_branch (code->ext.wait->end, code);
+ resolve_branch (code->ext.wait->eor, code);
+ break;
+
case EXEC_READ:
case EXEC_WRITE:
if (gfc_resolve_dt (code->ext.dt) == FAILURE)
case EXEC_OMP_ORDERED:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASKWAIT:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_directive (code, ns);
has_error = 1;
}
else if (sym->attr.contained == 0
- && (sym->attr.if_source == IFSRC_UNKNOWN))
- if ((sym->attr.use_assoc
- && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
- || sym->attr.use_assoc == 0)
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ if ((sym->attr.use_assoc && bind_c_sym->mod_name
+ && strcmp (bind_c_sym->mod_name, sym->module) != 0)
+ || sym->attr.use_assoc == 0)
{
gfc_error ("Binding label '%s' at %L collides with global "
"entity '%s' at %L", sym->binding_label,
/* Resolve an index expression. */
-static try
+static gfc_try
resolve_index_expr (gfc_expr *e)
{
if (gfc_resolve_expr (e) == FAILURE)
/* Resolve a charlen structure. */
-static try
+static gfc_try
resolve_charlen (gfc_charlen *cl)
{
int i;
/* "If the character length parameter value evaluates to a negative
value, the length of character entities declared is zero." */
- if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
+ if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
{
gfc_warning_now ("CHARACTER variable has zero length at %L",
&cl->length->where);
return not_constant;
}
-
-/* Assign the default initializer to a derived type variable or result. */
-
+/* Given a symbol and an initialization expression, add code to initialize
+ the symbol to the function entry. */
static void
-apply_default_init (gfc_symbol *sym)
+build_init_assign (gfc_symbol *sym, gfc_expr *init)
{
gfc_expr *lval;
- gfc_expr *init = NULL;
gfc_code *init_st;
gfc_namespace *ns = sym->ns;
- if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
- return;
-
- if (sym->ts.type == BT_DERIVED && sym->ts.derived)
- init = gfc_default_initializer (&sym->ts);
-
- if (init == NULL)
- return;
-
/* Search for the function namespace if this is a contained
function without an explicit result. */
if (sym->attr.function && sym == sym->result
}
/* Build an l-value expression for the result. */
- lval = gfc_get_expr ();
- lval->expr_type = EXPR_VARIABLE;
- lval->where = sym->declared_at;
- lval->ts = sym->ts;
- lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
-
- /* It will always be a full array. */
- lval->rank = sym->as ? sym->as->rank : 0;
- if (lval->rank)
- {
- lval->ref = gfc_get_ref ();
- lval->ref->type = REF_ARRAY;
- lval->ref->u.ar.type = AR_FULL;
- lval->ref->u.ar.dimen = lval->rank;
- lval->ref->u.ar.where = sym->declared_at;
- lval->ref->u.ar.as = sym->as;
- }
+ lval = gfc_lval_expr_from_sym (sym);
/* Add the code at scope entry. */
init_st = gfc_get_code ();
init_st->expr2 = init;
}
+/* Assign the default initializer to a derived type variable or result. */
+
+static void
+apply_default_init (gfc_symbol *sym)
+{
+ gfc_expr *init = NULL;
+
+ if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
+ return;
+
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived)
+ init = gfc_default_initializer (&sym->ts);
+
+ if (init == NULL)
+ return;
+
+ build_init_assign (sym, init);
+}
+
+/* Build an initializer for a local integer, real, complex, logical, or
+ character variable, based on the command line flags finit-local-zero,
+ finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
+ null if the symbol should not have a default initialization. */
+static gfc_expr *
+build_default_init_expr (gfc_symbol *sym)
+{
+ int char_len;
+ gfc_expr *init_expr;
+ int i;
+
+ /* These symbols should never have a default initialization. */
+ if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
+ || sym->attr.external
+ || sym->attr.dummy
+ || sym->attr.pointer
+ || sym->attr.in_equivalence
+ || sym->attr.in_common
+ || sym->attr.data
+ || sym->module
+ || sym->attr.cray_pointee
+ || sym->attr.cray_pointer)
+ return NULL;
+
+ /* Now we'll try to build an initializer expression. */
+ init_expr = gfc_get_expr ();
+ init_expr->expr_type = EXPR_CONSTANT;
+ init_expr->ts.type = sym->ts.type;
+ init_expr->ts.kind = sym->ts.kind;
+ init_expr->where = sym->declared_at;
+
+ /* We will only initialize integers, reals, complex, logicals, and
+ characters, and only if the corresponding command-line flags
+ were set. Otherwise, we free init_expr and return null. */
+ switch (sym->ts.type)
+ {
+ case BT_INTEGER:
+ if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
+ mpz_init_set_si (init_expr->value.integer,
+ gfc_option.flag_init_integer_value);
+ else
+ {
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+ break;
+
+ case BT_REAL:
+ mpfr_init (init_expr->value.real);
+ switch (gfc_option.flag_init_real)
+ {
+ case GFC_INIT_REAL_NAN:
+ mpfr_set_nan (init_expr->value.real);
+ break;
+
+ case GFC_INIT_REAL_INF:
+ mpfr_set_inf (init_expr->value.real, 1);
+ break;
+
+ case GFC_INIT_REAL_NEG_INF:
+ mpfr_set_inf (init_expr->value.real, -1);
+ break;
+
+ case GFC_INIT_REAL_ZERO:
+ mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
+ break;
+
+ default:
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ break;
+ }
+ break;
+
+ case BT_COMPLEX:
+ mpfr_init (init_expr->value.complex.r);
+ mpfr_init (init_expr->value.complex.i);
+ switch (gfc_option.flag_init_real)
+ {
+ case GFC_INIT_REAL_NAN:
+ mpfr_set_nan (init_expr->value.complex.r);
+ mpfr_set_nan (init_expr->value.complex.i);
+ break;
+
+ case GFC_INIT_REAL_INF:
+ mpfr_set_inf (init_expr->value.complex.r, 1);
+ mpfr_set_inf (init_expr->value.complex.i, 1);
+ break;
+
+ case GFC_INIT_REAL_NEG_INF:
+ mpfr_set_inf (init_expr->value.complex.r, -1);
+ mpfr_set_inf (init_expr->value.complex.i, -1);
+ break;
+
+ case GFC_INIT_REAL_ZERO:
+ mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
+ mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
+ break;
+
+ default:
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ break;
+ }
+ break;
+
+ case BT_LOGICAL:
+ if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
+ init_expr->value.logical = 0;
+ else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
+ init_expr->value.logical = 1;
+ else
+ {
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+ break;
+
+ case BT_CHARACTER:
+ /* For characters, the length must be constant in order to
+ create a default initializer. */
+ if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+ && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ char_len = mpz_get_si (sym->ts.cl->length->value.integer);
+ init_expr->value.character.length = char_len;
+ init_expr->value.character.string = gfc_get_wide_string (char_len+1);
+ for (i = 0; i < char_len; i++)
+ init_expr->value.character.string[i]
+ = (unsigned char) gfc_option.flag_init_character_value;
+ }
+ else
+ {
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+ break;
+
+ default:
+ gfc_free_expr (init_expr);
+ init_expr = NULL;
+ }
+ return init_expr;
+}
+
+/* Add an initialization expression to a local variable. */
+static void
+apply_default_init_local (gfc_symbol *sym)
+{
+ gfc_expr *init = NULL;
+
+ /* The symbol should be a variable or a function return value. */
+ if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
+ || (sym->attr.function && sym->result != sym))
+ return;
+
+ /* Try to build the initializer expression. If we can't initialize
+ this symbol, then init will be NULL. */
+ init = build_default_init_expr (sym);
+ if (init == NULL)
+ return;
+
+ /* For saved variables, we don't want to add an initializer at
+ function entry, so we just add a static initializer. */
+ if (sym->attr.save || sym->ns->save_all)
+ {
+ /* Don't clobber an existing initializer! */
+ gcc_assert (sym->value == NULL);
+ sym->value = init;
+ return;
+ }
+
+ build_init_assign (sym, init);
+}
/* Resolution of common features of flavors variable and procedure. */
-static try
+static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
/* Constraints on deferred shape variable. */
}
-static gfc_component *
-has_default_initializer (gfc_symbol *der)
+/* Additional checks for symbols with flavor variable and derived
+ type. To be called from resolve_fl_variable. */
+
+static gfc_try
+resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
{
- gfc_component *c;
- for (c = der->components; c; c = c->next)
- if ((c->ts.type != BT_DERIVED && c->initializer)
- || (c->ts.type == BT_DERIVED
- && !c->pointer
- && has_default_initializer (c->ts.derived)))
- break;
+ gcc_assert (sym->ts.type == BT_DERIVED);
+
+ /* Check to see if a derived type is blocked from being host
+ associated by the presence of another class I symbol in the same
+ namespace. 14.6.1.3 of the standard and the discussion on
+ comp.lang.fortran. */
+ if (sym->ns != sym->ts.derived->ns
+ && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
+ {
+ gfc_symbol *s;
+ gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
+ if (s && (s->attr.flavor != FL_DERIVED
+ || !gfc_compare_derived_types (s, sym->ts.derived)))
+ {
+ gfc_error ("The type '%s' cannot be host associated at %L "
+ "because it is blocked by an incompatible object "
+ "of the same name declared at %L",
+ sym->ts.derived->name, &sym->declared_at,
+ &s->declared_at);
+ return FAILURE;
+ }
+ }
+
+ /* 4th constraint in section 11.3: "If an object of a type for which
+ component-initialization is specified (R429) appears in the
+ specification-part of a module and does not have the ALLOCATABLE
+ or POINTER attribute, the object shall have the SAVE attribute."
+
+ The check for initializers is performed with
+ has_default_initializer because gfc_default_initializer generates
+ a hidden default for allocatable components. */
+ if (!(sym->value || no_init_flag) && sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && !sym->ns->save_all && !sym->attr.save
+ && !sym->attr.pointer && !sym->attr.allocatable
+ && has_default_initializer (sym->ts.derived))
+ {
+ gfc_error("Object '%s' at %L must have the SAVE attribute for "
+ "default initialization of a component",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* Assign default initializer. */
+ if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
+ && (!no_init_flag || sym->attr.intent == INTENT_OUT))
+ {
+ sym->value = gfc_default_initializer (&sym->ts);
+ }
- return c;
+ return SUCCESS;
}
/* Resolve symbols with flavor variable. */
-static try
+static gfc_try
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
- int flag;
- int i;
+ int no_init_flag, automatic_flag;
gfc_expr *e;
- gfc_component *c;
const char *auto_save_msg;
- auto_save_msg = "automatic object '%s' at %L cannot have the "
+ auto_save_msg = "Automatic object '%s' at %L cannot have the "
"SAVE attribute";
if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
is_non_constant_shape_array. */
specification_expr = 1;
- if (!sym->attr.use_assoc
+ if (sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc
&& !sym->attr.allocatable
&& !sym->attr.pointer
&& is_non_constant_shape_array (sym))
{
- /* The shape of a main program or module array needs to be
- constant. */
- if (sym->ns->proc_name
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program))
- {
- gfc_error ("The module or main program array '%s' at %L must "
- "have constant shape", sym->name, &sym->declared_at);
- specification_expr = 0;
- return FAILURE;
- }
+ /* The shape of a main program or module array needs to be
+ constant. */
+ gfc_error ("The module or main program array '%s' at %L must "
+ "have constant shape", sym->name, &sym->declared_at);
+ specification_expr = 0;
+ return FAILURE;
}
if (sym->ts.type == BT_CHARACTER)
}
}
- /* Can the symbol have an initializer? */
- flag = 0;
+ if (sym->value == NULL && sym->attr.referenced)
+ 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;
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
- || sym->attr.intrinsic || sym->attr.result)
- flag = 1;
- else if (sym->attr.dimension && !sym->attr.pointer)
+ || sym->attr.intrinsic || sym->attr.result)
+ no_init_flag = 1;
+ else if (sym->attr.dimension && !sym->attr.pointer
+ && is_non_constant_shape_array (sym))
{
- /* Don't allow initialization of automatic arrays. */
- for (i = 0; i < sym->as->rank; i++)
- {
- if (sym->as->lower[i] == NULL
- || sym->as->lower[i]->expr_type != EXPR_CONSTANT
- || sym->as->upper[i] == NULL
- || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
- {
- flag = 2;
- break;
- }
- }
+ no_init_flag = automatic_flag = 1;
- /* Also, they must not have the SAVE attribute. */
- if (flag && sym->attr.save)
+ /* Also, they must not have the SAVE attribute.
+ SAVE_IMPLICIT is checked below. */
+ if (sym->attr.save == SAVE_EXPLICIT)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
}
- }
+ }
/* Reject illegal initializers. */
- if (sym->value && flag)
+ if (!sym->mark && sym->value)
{
if (sym->attr.allocatable)
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
else if (sym->attr.result)
gfc_error ("Function result '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
- else if (flag == 2)
+ else if (automatic_flag)
gfc_error ("Automatic array '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else
}
no_init_error:
- /* Check to see if a derived type is blocked from being host associated
- by the presence of another class I symbol in the same namespace.
- 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
- if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
- && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
- {
- gfc_symbol *s;
- gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
- if (s && (s->attr.flavor != FL_DERIVED
- || !gfc_compare_derived_types (s, sym->ts.derived)))
- {
- gfc_error ("The type %s cannot be host associated at %L because "
- "it is blocked by an incompatible object of the same "
- "name at %L", sym->ts.derived->name, &sym->declared_at,
- &s->declared_at);
- return FAILURE;
- }
- }
-
- /* Do not use gfc_default_initializer to test for a default initializer
- in the fortran because it generates a hidden default for allocatable
- components. */
- c = NULL;
- if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
- c = has_default_initializer (sym->ts.derived);
-
- /* 4th constraint in section 11.3: "If an object of a type for which
- component-initialization is specified (R429) appears in the
- specification-part of a module and does not have the ALLOCATABLE
- or POINTER attribute, the object shall have the SAVE attribute." */
- if (c && sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE
- && !sym->ns->save_all && !sym->attr.save
- && !sym->attr.pointer && !sym->attr.allocatable)
- {
- gfc_error("Object '%s' at %L must have the SAVE attribute %s",
- sym->name, &sym->declared_at,
- "for default initialization of a component");
- return FAILURE;
- }
-
- /* Assign default initializer. */
- if (sym->ts.type == BT_DERIVED
- && !sym->value
- && !sym->attr.pointer
- && !sym->attr.allocatable
- && (!flag || sym->attr.intent == INTENT_OUT))
- sym->value = gfc_default_initializer (&sym->ts);
+ if (sym->ts.type == BT_DERIVED)
+ return resolve_fl_variable_derived (sym, no_init_flag);
return SUCCESS;
}
/* Resolve a procedure. */
-static try
+static gfc_try
resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
gfc_formal_arglist *arg;
}
/* Ensure that derived type for are not of a private type. Internal
- module procedures are excluded by 2.2.3.3 - ie. they are not
+ 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
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
{
+ gfc_interface *iface;
+
for (arg = sym->formal; arg; arg = arg->next)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.derived->attr.use_assoc
&& !gfc_check_access (arg->sym->ts.derived->attr.access,
- arg->sym->ts.derived->ns->default_access))
+ arg->sym->ts.derived->ns->default_access)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
+ "PRIVATE type and cannot be a dummy argument"
+ " of '%s', which is PUBLIC at %L",
+ arg->sym->name, sym->name, &sym->declared_at)
+ == FAILURE)
{
- gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
- "a dummy argument of '%s', which is "
- "PUBLIC at %L", arg->sym->name, sym->name,
- &sym->declared_at);
/* Stop this message from recurring. */
arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
return FAILURE;
}
}
+
+ /* PUBLIC interfaces may expose PRIVATE procedures that take types
+ PRIVATE to the containing module. */
+ for (iface = sym->generic; iface; iface = iface->next)
+ {
+ for (arg = iface->sym->formal; arg; arg = arg->next)
+ {
+ if (arg->sym
+ && arg->sym->ts.type == BT_DERIVED
+ && !arg->sym->ts.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
+ "'%s' in PUBLIC interface '%s' at %L "
+ "takes dummy arguments of '%s' which is "
+ "PRIVATE", iface->sym->name, sym->name,
+ &iface->sym->declared_at,
+ gfc_typename (&arg->sym->ts)) == FAILURE)
+ {
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return FAILURE;
+ }
+ }
+ }
+
+ /* PUBLIC interfaces may expose PRIVATE procedures that take types
+ PRIVATE to the containing module. */
+ for (iface = sym->generic; iface; iface = iface->next)
+ {
+ for (arg = iface->sym->formal; arg; arg = arg->next)
+ {
+ if (arg->sym
+ && arg->sym->ts.type == BT_DERIVED
+ && !arg->sym->ts.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
+ "'%s' in PUBLIC interface '%s' at %L "
+ "takes dummy arguments of '%s' which is "
+ "PRIVATE", iface->sym->name, sym->name,
+ &iface->sym->declared_at,
+ gfc_typename (&arg->sym->ts)) == FAILURE)
+ {
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return FAILURE;
+ }
+ }
+ }
+ }
+
+ if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.proc_pointer)
+ {
+ gfc_error ("Function '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ return FAILURE;
}
/* An external symbol may not have an initializer because it is taken to be
- a procedure. */
- if (sym->attr.external && sym->value)
+ a procedure. Exception: Procedure Pointers. */
+ if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
{
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
{
gfc_formal_arglist *curr_arg;
+ int has_non_interop_arg = 0;
if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
sym->common_block) == FAILURE)
while (curr_arg != NULL)
{
/* Skip implicitly typed dummy args here. */
- if (curr_arg->sym->attr.implicit_type == 0
- && verify_c_interop_param (curr_arg->sym) == FAILURE)
- {
- /* If something is found to fail, mark the symbol for the
- procedure as not being BIND(C) to try and prevent multiple
- errors being reported. */
- sym->attr.is_c_interop = 0;
- sym->ts.is_c_interop = 0;
- sym->attr.is_bind_c = 0;
- }
+ if (curr_arg->sym->attr.implicit_type == 0)
+ if (verify_c_interop_param (curr_arg->sym) == FAILURE)
+ /* If something is found to fail, record the fact so we
+ can mark the symbol for the procedure as not being
+ BIND(C) to try and prevent multiple errors being
+ reported. */
+ has_non_interop_arg = 1;
+
curr_arg = curr_arg->next;
}
+
+ /* See if any of the arguments were not interoperable and if so, clear
+ the procedure symbol to prevent duplicate error messages. */
+ if (has_non_interop_arg != 0)
+ {
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ sym->attr.is_bind_c = 0;
+ }
}
+ if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
+ "in '%s' at %L", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (sym->attr.intent && !sym->attr.proc_pointer)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
+ "in '%s' at %L", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
return SUCCESS;
}
+/* Resolve a list of finalizer procedures. That is, after they have hopefully
+ been defined and we now know their defined arguments, check that they fulfill
+ the requirements of the standard for procedures used as finalizers. */
+
+static gfc_try
+gfc_resolve_finalizers (gfc_symbol* derived)
+{
+ gfc_finalizer* list;
+ gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
+ gfc_try result = SUCCESS;
+ bool seen_scalar = false;
+
+ if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+ return SUCCESS;
+
+ /* Walk over the list of finalizer-procedures, check them, and if any one
+ does not fit in with the standard's definition, print an error and remove
+ it from the list. */
+ prev_link = &derived->f2k_derived->finalizers;
+ for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
+ {
+ gfc_symbol* arg;
+ gfc_finalizer* i;
+ int my_rank;
+
+ /* Skip this finalizer if we already resolved it. */
+ if (list->proc_tree)
+ {
+ prev_link = &(list->next);
+ continue;
+ }
+
+ /* Check this exists and is a SUBROUTINE. */
+ if (!list->proc_sym->attr.subroutine)
+ {
+ gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
+ list->proc_sym->name, &list->where);
+ goto error;
+ }
+
+ /* We should have exactly one argument. */
+ if (!list->proc_sym->formal || list->proc_sym->formal->next)
+ {
+ gfc_error ("FINAL procedure at %L must have exactly one argument",
+ &list->where);
+ goto error;
+ }
+ arg = list->proc_sym->formal->sym;
+
+ /* This argument must be of our type. */
+ if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
+ &arg->declared_at, derived->name);
+ goto error;
+ }
+
+ /* It must neither be a pointer nor allocatable nor optional. */
+ if (arg->attr.pointer)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
+ &arg->declared_at);
+ goto error;
+ }
+ if (arg->attr.allocatable)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " ALLOCATABLE", &arg->declared_at);
+ goto error;
+ }
+ if (arg->attr.optional)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
+ &arg->declared_at);
+ goto error;
+ }
+
+ /* It must not be INTENT(OUT). */
+ if (arg->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " INTENT(OUT)", &arg->declared_at);
+ goto error;
+ }
+
+ /* Warn if the procedure is non-scalar and not assumed shape. */
+ if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+ && arg->as->type != AS_ASSUMED_SHAPE)
+ gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
+ " shape argument", &arg->declared_at);
+
+ /* Check that it does not match in kind and rank with a FINAL procedure
+ defined earlier. To really loop over the *earlier* declarations,
+ we need to walk the tail of the list as new ones were pushed at the
+ front. */
+ /* TODO: Handle kind parameters once they are implemented. */
+ my_rank = (arg->as ? arg->as->rank : 0);
+ for (i = list->next; i; i = i->next)
+ {
+ /* Argument list might be empty; that is an error signalled earlier,
+ but we nevertheless continued resolving. */
+ if (i->proc_sym->formal)
+ {
+ gfc_symbol* i_arg = i->proc_sym->formal->sym;
+ const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
+ if (i_rank == my_rank)
+ {
+ gfc_error ("FINAL procedure '%s' declared at %L has the same"
+ " rank (%d) as '%s'",
+ list->proc_sym->name, &list->where, my_rank,
+ i->proc_sym->name);
+ goto error;
+ }
+ }
+ }
+
+ /* Is this the/a scalar finalizer procedure? */
+ if (!arg->as || arg->as->rank == 0)
+ seen_scalar = true;
+
+ /* Find the symtree for this procedure. */
+ gcc_assert (!list->proc_tree);
+ list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
+
+ prev_link = &list->next;
+ continue;
+
+ /* Remove wrong nodes immediately from the list so we don't risk any
+ troubles in the future when they might fail later expectations. */
+error:
+ result = FAILURE;
+ i = list;
+ *prev_link = list->next;
+ gfc_free_finalizer (i);
+ }
+
+ /* Warn if we haven't seen a scalar finalizer procedure (but we know there
+ were nodes in the list, must have been for arrays. It is surely a good
+ idea to have a scalar version there if there's something to finalize. */
+ if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
+ gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
+ " defined at %L, suggest also scalar one",
+ derived->name, &derived->declared_at);
+
+ /* TODO: Remove this error when finalization is finished. */
+ gfc_error ("Finalization at %L is not yet implemented",
+ &derived->declared_at);
+
+ return result;
+}
+
+
+/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
+ to give all identical derived types the same backend_decl. */
+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)
+ break;
+
+ if (dt_list == NULL)
+ {
+ dt_list = gfc_get_dt_list ();
+ dt_list->next = gfc_derived_types;
+ dt_list->derived = derived;
+ gfc_derived_types = dt_list;
+ }
+}
+
+
/* Resolve the components of a derived type. */
-static try
+static gfc_try
resolve_fl_derived (gfc_symbol *sym)
{
gfc_component *c;
- gfc_dt_list * dt_list;
int i;
for (c = sym->components; c != NULL; c = c->next)
}
}
- if (c->ts.type == BT_DERIVED && c->pointer
- && c->ts.derived->components == NULL)
+ if (c->ts.type == BT_DERIVED && c->attr.pointer
+ && c->ts.derived->components == NULL
+ && !c->ts.derived->attr.zero_comp)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
return FAILURE;
}
- if (c->pointer || c->allocatable || c->as == NULL)
+ /* Ensure that all the derived type components are put on the
+ derived type list; even in formal namespaces, where derived type
+ pointer components might not have been declared. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.derived
+ && c->ts.derived->components
+ && c->attr.pointer
+ && sym != c->ts.derived)
+ add_dt_to_dt_list (c->ts.derived);
+
+ if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
{
if (c->as->lower[i] == NULL
- || !gfc_is_constant_expr (c->as->lower[i])
|| (resolve_index_expr (c->as->lower[i]) == FAILURE)
+ || !gfc_is_constant_expr (c->as->lower[i])
|| c->as->upper[i] == NULL
|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
|| !gfc_is_constant_expr (c->as->upper[i]))
}
}
- /* Add derived type to the derived type list. */
- for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
- if (sym == dt_list->derived)
- break;
+ /* Resolve the finalizer procedures. */
+ if (gfc_resolve_finalizers (sym) == FAILURE)
+ return FAILURE;
- if (dt_list == NULL)
- {
- dt_list = gfc_get_dt_list ();
- dt_list->next = gfc_derived_types;
- dt_list->derived = sym;
- gfc_derived_types = dt_list;
- }
+ /* Add derived type to the derived type list. */
+ add_dt_to_dt_list (sym);
return SUCCESS;
}
-static try
+static gfc_try
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
{
if (!nl->sym->attr.use_assoc
&& !(sym->ns->parent == nl->sym->ns)
+ && !(sym->ns->parent
+ && sym->ns->parent->parent == nl->sym->ns)
&& !gfc_check_access(nl->sym->attr.access,
- nl->sym->ns->default_access))
+ nl->sym->ns->default_access))
{
- gfc_error ("PRIVATE symbol '%s' cannot be member of "
- "PUBLIC namelist at %L", nl->sym->name,
- &sym->declared_at);
+ gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
+ "cannot be member of PUBLIC namelist '%s' at %L",
+ nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* Types with private components that came here by USE-association. */
+ if (nl->sym->ts.type == BT_DERIVED
+ && derived_inaccessible (nl->sym->ts.derived))
+ {
+ gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
+ "components and cannot be member of namelist '%s' at %L",
+ nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* Types with private components that are defined in the same module. */
+ if (nl->sym->ts.type == BT_DERIVED
+ && !(sym->ns->parent == nl->sym->ts.derived->ns)
+ && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
+ ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
+ nl->sym->ns->default_access))
+ {
+ gfc_error ("NAMELIST object '%s' has PRIVATE components and "
+ "cannot be a member of PUBLIC namelist '%s' at %L",
+ nl->sym->name, sym->name, &sym->declared_at);
return FAILURE;
}
}
}
- /* Reject namelist arrays that are not constant shape. */
for (nl = sym->namelist; nl; nl = nl->next)
{
+ /* Reject namelist arrays of assumed shape. */
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
+ && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
+ "must not have assumed shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* Reject namelist arrays that are not constant shape. */
if (is_non_constant_shape_array (nl->sym))
{
- gfc_error ("The array '%s' must have constant shape to be "
- "a NAMELIST object at %L", nl->sym->name,
- &sym->declared_at);
+ gfc_error ("NAMELIST array object '%s' must have constant "
+ "shape in namelist '%s' at %L", nl->sym->name,
+ sym->name, &sym->declared_at);
return FAILURE;
}
- }
- /* Namelist objects cannot have allocatable components. */
- for (nl = sym->namelist; nl; nl = nl->next)
- {
- if (nl->sym->ts.type == BT_DERIVED
- && nl->sym->ts.derived->attr.alloc_comp)
+ /* Namelist objects cannot have allocatable or pointer components. */
+ if (nl->sym->ts.type != BT_DERIVED)
+ continue;
+
+ if (nl->sym->ts.derived->attr.alloc_comp)
{
- gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
- "components", nl->sym->name, &sym->declared_at);
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
+ "have ALLOCATABLE components",
+ nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (nl->sym->ts.derived->attr.pointer_comp)
+ {
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
+ "have POINTER components",
+ nl->sym->name, sym->name, &sym->declared_at);
return FAILURE;
}
}
+
/* 14.1.2 A module or internal procedure represent local entities
of the same type as a namelist member and so are not allowed. */
for (nl = sym->namelist; nl; nl = nl->next)
}
-static try
+static gfc_try
resolve_fl_parameter (gfc_symbol *sym)
{
/* A parameter array's shape needs to be constant. */
- if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
+ if (sym->as != NULL
+ && (sym->as->type == AS_DEFERRED
+ || is_non_constant_shape_array (sym)))
{
gfc_error ("Parameter array '%s' at %L cannot be automatic "
- "or assumed shape", sym->name, &sym->declared_at);
+ "or of deferred shape", sym->name, &sym->declared_at);
return FAILURE;
}
}
}
+ if (sym->attr.procedure && sym->ts.interface
+ && sym->attr.if_source != IFSRC_DECL)
+ {
+ if (sym->ts.interface->attr.procedure)
+ gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
+ "in a later PROCEDURE statement", sym->ts.interface->name,
+ sym->name,&sym->declared_at);
+
+ /* Get the attributes from the interface (now resolved). */
+ if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+ {
+ gfc_symbol *ifc = sym->ts.interface;
+ sym->ts = ifc->ts;
+ sym->ts.interface = ifc;
+ sym->attr.function = ifc->attr.function;
+ sym->attr.subroutine = ifc->attr.subroutine;
+ sym->attr.allocatable = ifc->attr.allocatable;
+ sym->attr.pointer = ifc->attr.pointer;
+ sym->attr.pure = ifc->attr.pure;
+ sym->attr.elemental = ifc->attr.elemental;
+ sym->attr.dimension = ifc->attr.dimension;
+ sym->attr.recursive = ifc->attr.recursive;
+ sym->attr.always_explicit = ifc->attr.always_explicit;
+ sym->as = gfc_copy_array_spec (ifc->as);
+ copy_formal_args (sym, ifc);
+ }
+ else if (sym->ts.interface->name[0] != '\0')
+ {
+ gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
+ sym->ts.interface->name, sym->name, &sym->declared_at);
+ return;
+ }
+ }
+
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
type to avoid spurious warnings. */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
{
- if (gfc_intrinsic_name (sym->name, 0))
+ gfc_intrinsic_sym* isym;
+ const char* symstd;
+
+ /* We already know this one is an intrinsic, so we don't call
+ gfc_is_intrinsic for full checking but rather use gfc_find_function and
+ gfc_find_subroutine directly to check whether it is a function or
+ subroutine. */
+
+ if ((isym = gfc_find_function (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
- gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
- sym->name, &sym->declared_at);
+ gfc_warning ("Type specified for intrinsic function '%s' at %L is"
+ " ignored", sym->name, &sym->declared_at);
}
- else if (gfc_intrinsic_name (sym->name, 1))
+ else if ((isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
- sym->name, &sym->declared_at);
+ gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
+ " specifier", sym->name, &sym->declared_at);
return;
}
}
else
{
- gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
+ gfc_error ("'%s' declared INTRINSIC at %L does not exist",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
+ /* Check it is actually available in the standard settings. */
+ if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
+ == FAILURE)
+ {
+ gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
+ " available in the current standard settings but %s. Use"
+ " an appropriate -std=* option or enable -fall-intrinsics"
+ " in order to use it.",
+ sym->name, &sym->declared_at, symstd);
return;
}
}
sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
{
- try t = SUCCESS;
+ gfc_try t = SUCCESS;
/* First, make sure the variable is declared at the
module-level scope (J3/04-007, Section 15.3). */
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
- if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL
+ && !sym->ts.derived->attr.zero_comp)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined", sym->name,
return;
}
+ /* Make sure that the derived type has been resolved and that the
+ derived type is visible in the symbol's namespace, if it is a
+ module function and is not PRIVATE. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.use_assoc
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ gfc_symbol *ds;
+
+ if (resolve_fl_derived (sym->ts.derived) == FAILURE)
+ return;
+
+ gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
+ if (!ds && sym->attr.function
+ && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ {
+ symtree = gfc_new_symtree (&sym->ns->sym_root,
+ sym->ts.derived->name);
+ symtree->n.sym = sym->ts.derived;
+ sym->ts.derived->refs++;
+ }
+ }
+
+ /* Unless the derived-type declaration is use associated, Fortran 95
+ does not allow public entries of private derived types.
+ See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
+ 161 in 95-006r3. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && !sym->ts.derived->attr.use_assoc
+ && gfc_check_access (sym->attr.access, sym->ns->default_access)
+ && !gfc_check_access (sym->ts.derived->attr.access,
+ sym->ts.derived->ns->default_access)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
+ "of PRIVATE derived type '%s'",
+ (sym->attr.flavor == FL_PARAMETER) ? "parameter"
+ : "variable", sym->name, &sym->declared_at,
+ sym->ts.derived->name) == FAILURE)
+ return;
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
gfc_resolve (sym->formal_ns);
/* Check threadprivate restrictions. */
- if (sym->attr.threadprivate && !sym->attr.save
+ if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
&& (!sym->attr.in_common
&& sym->module == NULL
&& (sym->ns->proc_name == NULL
static struct
{
gfc_data_value *vnode;
- unsigned int left;
+ mpz_t left;
}
values;
/* Advance the values structure to point to the next value in the data list. */
-static try
+static gfc_try
next_data_value (void)
{
- while (values.left == 0)
+
+ while (mpz_cmp_ui (values.left, 0) == 0)
{
if (values.vnode->next == NULL)
return FAILURE;
values.vnode = values.vnode->next;
- values.left = values.vnode->repeat;
+ mpz_set (values.left, values.vnode->repeat);
}
return SUCCESS;
}
-static try
+static gfc_try
check_data_variable (gfc_data_variable *var, locus *where)
{
gfc_expr *e;
mpz_t size;
mpz_t offset;
- try t;
+ gfc_try t;
ar_type mark = AR_UNKNOWN;
int i;
mpz_t section_index[GFC_MAX_DIMENSIONS];
e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
}
+ if (e->ref == NULL && e->symtree->n.sym->as)
+ {
+ gfc_error ("DATA array '%s' at %L must be specified in a previous"
+ " declaration", e->symtree->n.sym->name, where);
+ return FAILURE;
+ }
+
if (e->rank == 0)
{
mpz_init_set_ui (size, 1);
/* If we have more than one element left in the repeat count,
and we have more than one element left in the target variable,
then create a range assignment. */
- /* ??? Only done for full arrays for now, since array sections
+ /* FIXME: Only done for full arrays for now, since array sections
seem tricky. */
if (mark == AR_FULL && ref && ref->next == NULL
- && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
+ && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
{
mpz_t range;
- if (mpz_cmp_ui (size, values.left) >= 0)
+ if (mpz_cmp (size, values.left) >= 0)
{
- mpz_init_set_ui (range, values.left);
- mpz_sub_ui (size, size, values.left);
- values.left = 0;
+ mpz_init_set (range, values.left);
+ mpz_sub (size, size, values.left);
+ mpz_set_ui (values.left, 0);
}
else
{
mpz_init_set (range, size);
- values.left -= mpz_get_ui (size);
+ mpz_sub (values.left, values.left, size);
mpz_set_ui (size, 0);
}
/* Assign initial value to symbol. */
else
{
- values.left -= 1;
+ mpz_sub_ui (values.left, values.left, 1);
mpz_sub_ui (size, size, 1);
- gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ if (t == FAILURE)
+ break;
if (mark == AR_FULL)
mpz_add_ui (offset, offset, 1);
}
-static try traverse_data_var (gfc_data_variable *, locus *);
+static gfc_try traverse_data_var (gfc_data_variable *, locus *);
/* Iterate over a list of elements in a DATA statement. */
-static try
+static gfc_try
traverse_data_list (gfc_data_variable *var, locus *where)
{
mpz_t trip;
iterator_stack frame;
gfc_expr *e, *start, *end, *step;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
mpz_init (frame.value);
/* Type resolve variables in the variable list of a DATA statement. */
-static try
+static gfc_try
traverse_data_var (gfc_data_variable *var, locus *where)
{
- try t;
+ gfc_try t;
for (; var; var = var->next)
{
This is separate from the assignment checking because data lists should
only be resolved once. */
-static try
+static gfc_try
resolve_data_variables (gfc_data_variable *d)
{
for (; d; d = d->next)
variables list, expanding iterators and such. */
static void
-resolve_data (gfc_data * d)
+resolve_data (gfc_data *d)
{
+
if (resolve_data_variables (d->var) == FAILURE)
return;
values.vnode = d->value;
- values.left = (d->value == NULL) ? 0 : d->value->repeat;
+ if (d->value == NULL)
+ mpz_set_ui (values.left, 0);
+ else
+ mpz_set (values.left, d->value->repeat);
if (traverse_data_var (d->var, &d->where) == FAILURE)
return;
is storage associated with any such variable, shall not be used in the
following contexts: (clients of this function). */
-/* Determines if a variable is not 'pure', ie not assignable within a pure
+/* Determines if a variable is not 'pure', i.e., not assignable within a pure
procedure. Returns zero if assignment is OK, nonzero if there is a
problem. */
int
/* Resolve derived type EQUIVALENCE object. */
-static try
+static gfc_try
resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
{
gfc_symbol *d;
return FAILURE;
}
+ if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
+ {
+ gfc_error ("Derived type variable '%s' at %L with default "
+ "initialization cannot be in EQUIVALENCE with a variable "
+ "in COMMON", sym->name, &e->where);
+ return FAILURE;
+ }
+
for (; c ; c = c->next)
{
d = c->ts.derived;
/* Shall not be an object of sequence derived type containing a pointer
in the structure. */
- if (c->pointer)
+ if (c->attr.pointer)
{
gfc_error ("Derived type variable '%s' at %L with pointer "
"component(s) cannot be an EQUIVALENCE object",
sym = e->symtree->n.sym;
- if (sym->attr.protected)
+ if (sym->attr.is_protected)
cnt_protected++;
if (cnt_protected > 0 && cnt_protected != object)
{
gfc_resolve_uops (symtree->left);
gfc_resolve_uops (symtree->right);
- for (itr = symtree->n.uop->operator; itr; itr = itr->next)
+ for (itr = symtree->n.uop->op; itr; itr = itr->next)
{
sym = itr->sym;
if (!sym->attr.function)
resolve_entries (ns);
+ resolve_common_vars (ns->blank_common.head, false);
+ resolve_common_blocks (ns->common_root);
+
resolve_contained_functions (ns);
gfc_traverse_ns (ns, resolve_bind_c_derived_types);
OSDN Git Service
