/* Perform type resolution on the various stuctures.
- Copyright (C) 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
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, 59 Temple Place - Suite 330,Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
+02110-1301, USA. */
+
#include "config.h"
+#include "system.h"
#include "gfortran.h"
#include "arith.h" /* For gfc_compare_expr(). */
-#include <assert.h>
-#include <string.h>
+
+/* Types used in equivalence statements. */
+
+typedef enum seq_type
+{
+ SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
+}
+seq_type;
/* Stack to push the current if we descend into a block during
resolution. See resolve_branch() and resolve_code(). */
static int forall_flag;
+/* Nonzero if we are processing a formal arglist. The corresponding function
+ resets the flag each time that it is read. */
+static int formal_arg_flag = 0;
+
+int
+gfc_is_formal_arg (void)
+{
+ return formal_arg_flag;
+}
+
/* Resolve types of formal argument lists. These have to be done early so that
the formal argument lists of module procedures can be copied to the
containing module before the individual procedures are resolved
|| (sym->as && sym->as->rank > 0))
proc->attr.always_explicit = 1;
+ formal_arg_flag = 1;
+
for (f = proc->formal; f; f = f->next)
{
sym = f->sym;
A procedure specification would have already set the type. */
if (sym->attr.flavor == FL_UNKNOWN)
- gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at);
+ gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
if (gfc_pure (proc))
{
}
}
}
+ formal_arg_flag = 0;
}
}
-/* 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.
-
- The good news is that if a function doesn't already have a type, the only
- way it can get one is through an IMPLICIT type or a RESULT variable, because
- by definition contained functions are contained namespace they're contained
- in, not in a sibling or parent namespace. */
-
static void
-resolve_contained_functions (gfc_namespace * ns)
+resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
{
- gfc_symbol *contained_sym, *sym_lower;
- gfc_namespace *child;
try t;
+
+ /* If this namespace is not a function, ignore it. */
+ if (! sym
+ || !(sym->attr.function
+ || sym->attr.flavor == FL_VARIABLE))
+ return;
- resolve_formal_arglists (ns);
+ /* Try to find out of what the return type is. */
+ if (sym->result != NULL)
+ sym = sym->result;
- for (child = ns->contained; child; child = child->sibling)
+ if (sym->ts.type == BT_UNKNOWN)
{
- sym_lower = child->proc_name;
+ t = gfc_set_default_type (sym, 0, ns);
- /* If this namespace is not a function, ignore it. */
- if (! sym_lower
- || !( sym_lower->attr.function
- || sym_lower->attr.flavor == FL_VARIABLE))
- continue;
+ if (t == FAILURE && !sym->attr.untyped)
+ {
+ gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at); /* FIXME */
+ sym->attr.untyped = 1;
+ }
+ }
+}
- /* Find the contained symbol in the current namespace. */
- gfc_find_symbol (sym_lower->name, ns, 0, &contained_sym);
- if (contained_sym == NULL)
- gfc_internal_error ("resolve_contained_functions(): Contained "
- "function not found in parent namespace");
+/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
+ introduce duplicates. */
- /* Try to find out of what type the function is. If there was an
- explicit RESULT clause, try to get the type from it. If the
- function is never defined, set it to the implicit type. If
- even that fails, give up. */
- if (sym_lower->result != NULL)
- sym_lower = sym_lower->result;
+static void
+merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
+{
+ gfc_formal_arglist *f, *new_arglist;
+ gfc_symbol *new_sym;
- if (sym_lower->ts.type == BT_UNKNOWN)
+ for (; new_args != NULL; new_args = new_args->next)
+ {
+ new_sym = new_args->sym;
+ /* See if ths arg is already in the formal argument list. */
+ for (f = proc->formal; f; f = f->next)
{
- /* Assume we can find an implicit type. */
- t = SUCCESS;
+ if (new_sym == f->sym)
+ break;
+ }
- if (sym_lower->result == NULL)
- t = gfc_set_default_type (sym_lower, 0, child);
- else
- {
- if (sym_lower->result->ts.type == BT_UNKNOWN)
- t = gfc_set_default_type (sym_lower->result, 0, NULL);
+ if (f)
+ continue;
- sym_lower->ts = sym_lower->result->ts;
- }
+ /* Add a new argument. Argument order is not important. */
+ new_arglist = gfc_get_formal_arglist ();
+ new_arglist->sym = new_sym;
+ new_arglist->next = proc->formal;
+ proc->formal = new_arglist;
+ }
+}
- if (t == FAILURE)
- gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
- sym_lower->name, &sym_lower->declared_at); /* FIXME */
+
+/* Resolve alternate entry points. If a symbol has multiple entry points we
+ create a new master symbol for the main routine, and turn the existing
+ symbol into an entry point. */
+
+static void
+resolve_entries (gfc_namespace * ns)
+{
+ gfc_namespace *old_ns;
+ gfc_code *c;
+ gfc_symbol *proc;
+ gfc_entry_list *el;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ static int master_count = 0;
+
+ if (ns->proc_name == NULL)
+ return;
+
+ /* No need to do anything if this procedure doesn't have alternate entry
+ points. */
+ if (!ns->entries)
+ return;
+
+ /* We may already have resolved alternate entry points. */
+ if (ns->proc_name->attr.entry_master)
+ return;
+
+ /* If this isn't a procedure something has gone horribly wrong. */
+ gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
+
+ /* Remember the current namespace. */
+ old_ns = gfc_current_ns;
+
+ gfc_current_ns = ns;
+
+ /* Add the main entry point to the list of entry points. */
+ el = gfc_get_entry_list ();
+ el->sym = ns->proc_name;
+ el->id = 0;
+ el->next = ns->entries;
+ ns->entries = el;
+ ns->proc_name->attr.entry = 1;
+
+ /* Add an entry statement for it. */
+ c = gfc_get_code ();
+ c->op = EXEC_ENTRY;
+ c->ext.entry = el;
+ c->next = ns->code;
+ ns->code = c;
+
+ /* Create a new symbol for the master function. */
+ /* Give the internal function a unique name (within this file).
+ Also include the function name so the user has some hope of figuring
+ out what is going on. */
+ snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
+ master_count++, ns->proc_name->name);
+ gfc_get_ha_symbol (name, &proc);
+ gcc_assert (proc != NULL);
+
+ gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
+ if (ns->proc_name->attr.subroutine)
+ gfc_add_subroutine (&proc->attr, proc->name, NULL);
+ else
+ {
+ gfc_symbol *sym;
+ gfc_typespec *ts, *fts;
+
+ gfc_add_function (&proc->attr, proc->name, NULL);
+ proc->result = proc;
+ fts = &ns->entries->sym->result->ts;
+ if (fts->type == BT_UNKNOWN)
+ fts = gfc_get_default_type (ns->entries->sym->result, NULL);
+ for (el = ns->entries->next; el; el = el->next)
+ {
+ ts = &el->sym->result->ts;
+ if (ts->type == BT_UNKNOWN)
+ ts = gfc_get_default_type (el->sym->result, NULL);
+ if (! gfc_compare_types (ts, fts)
+ || (el->sym->result->attr.dimension
+ != ns->entries->sym->result->attr.dimension)
+ || (el->sym->result->attr.pointer
+ != ns->entries->sym->result->attr.pointer))
+ break;
}
- /* If the symbol in the parent of the contained namespace is not
- the same as the one in contained namespace itself, copy over
- the type information. */
- /* ??? Shouldn't we replace the symbol with the parent symbol instead? */
- if (contained_sym != sym_lower)
+ if (el == NULL)
+ {
+ sym = ns->entries->sym->result;
+ /* All result types the same. */
+ proc->ts = *fts;
+ if (sym->attr.dimension)
+ gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
+ if (sym->attr.pointer)
+ gfc_add_pointer (&proc->attr, NULL);
+ }
+ else
{
- contained_sym->ts = sym_lower->ts;
- contained_sym->as = gfc_copy_array_spec (sym_lower->as);
+ /* Otherwise the result will be passed through a union by
+ reference. */
+ proc->attr.mixed_entry_master = 1;
+ for (el = ns->entries; el; el = el->next)
+ {
+ sym = el->sym->result;
+ if (sym->attr.dimension)
+ {
+ if (el == ns->entries)
+ gfc_error
+ ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
+ sym->name, ns->entries->sym->name, &sym->declared_at);
+ else
+ gfc_error
+ ("ENTRY result %s can't be an array in FUNCTION %s at %L",
+ sym->name, ns->entries->sym->name, &sym->declared_at);
+ }
+ else if (sym->attr.pointer)
+ {
+ if (el == ns->entries)
+ gfc_error
+ ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
+ sym->name, ns->entries->sym->name, &sym->declared_at);
+ else
+ gfc_error
+ ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
+ sym->name, ns->entries->sym->name, &sym->declared_at);
+ }
+ else
+ {
+ ts = &sym->ts;
+ if (ts->type == BT_UNKNOWN)
+ ts = gfc_get_default_type (sym, NULL);
+ switch (ts->type)
+ {
+ case BT_INTEGER:
+ if (ts->kind == gfc_default_integer_kind)
+ sym = NULL;
+ break;
+ case BT_REAL:
+ if (ts->kind == gfc_default_real_kind
+ || ts->kind == gfc_default_double_kind)
+ sym = NULL;
+ break;
+ case BT_COMPLEX:
+ if (ts->kind == gfc_default_complex_kind)
+ sym = NULL;
+ break;
+ case BT_LOGICAL:
+ if (ts->kind == gfc_default_logical_kind)
+ sym = NULL;
+ break;
+ case BT_UNKNOWN:
+ /* We will issue error elsewhere. */
+ sym = NULL;
+ break;
+ default:
+ break;
+ }
+ if (sym)
+ {
+ if (el == ns->entries)
+ gfc_error
+ ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
+ sym->name, gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ else
+ gfc_error
+ ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
+ sym->name, gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ }
+ }
+ }
}
}
+ proc->attr.access = ACCESS_PRIVATE;
+ proc->attr.entry_master = 1;
+
+ /* Merge all the entry point arguments. */
+ for (el = ns->entries; el; el = el->next)
+ merge_argument_lists (proc, el->sym->formal);
+
+ /* Use the master function for the function body. */
+ ns->proc_name = proc;
+
+ /* Finalize the new symbols. */
+ gfc_commit_symbols ();
+
+ /* Restore the original namespace. */
+ gfc_current_ns = old_ns;
+}
+
+
+/* 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.
+
+ The good news is that if a function doesn't already have a type, the only
+ way it can get one is through an IMPLICIT type or a RESULT variable, because
+ by definition contained functions are contained namespace they're contained
+ in, not in a sibling or parent namespace. */
+
+static void
+resolve_contained_functions (gfc_namespace * ns)
+{
+ gfc_namespace *child;
+ gfc_entry_list *el;
+
+ resolve_formal_arglists (ns);
+
+ for (child = ns->contained; child; child = child->sibling)
+ {
+ /* Resolve alternate entry points first. */
+ resolve_entries (child);
+
+ /* Then check function return types. */
+ resolve_contained_fntype (child->proc_name, child);
+ for (el = child->entries; el; el = el->next)
+ resolve_contained_fntype (el->sym, child);
+ }
}
/* Resolve all of the elements of a structure constructor and make sure that
- the types are correct. */
+ the types are correct. */
static try
resolve_structure_cons (gfc_expr * expr)
/****************** Expression name resolution ******************/
/* Returns 0 if a symbol was not declared with a type or
- or attribute declaration statement, nonzero otherwise. */
+ attribute declaration statement, nonzero otherwise. */
static int
was_declared (gfc_symbol * sym)
if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
return 1;
- if (a.allocatable || a.dimension || a.external || a.intrinsic
+ if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target
|| a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
|| sym->attr.external)
{
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ {
+ gfc_error ("Statement function '%s' at %L is not allowed as an "
+ "actual argument", sym->name, &e->where);
+ }
+
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function '%s' at %L has no implicit type",
+ gfc_error ("Function '%s' at %L has no IMPLICIT type",
sym->name, &expr->where);
return FAILURE;
}
}
-/* Figure out if if a function reference is pure or not. Also sets the name
- of the function for a potential error message. Returns nonzero if the
+/* 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_function (gfc_expr * e, char **name)
+pure_function (gfc_expr * e, const char **name)
{
int pure;
resolve_function (gfc_expr * expr)
{
gfc_actual_arglist *arg;
- char *name;
+ const char *name;
try t;
if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
return t;
}
+/* Compare the shapes of two arrays that have non-NULL shapes. If both
+ op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
+ match. If both op1->shape and op2->shape are non-NULL return FAILURE
+ if their shapes do not match. If either op1->shape or op2->shape is
+ NULL, return SUCCESS. */
+
+static try
+compare_shapes (gfc_expr * op1, gfc_expr * op2)
+{
+ try t;
+ int i;
+
+ t = SUCCESS;
+
+ if (op1->shape != NULL && op2->shape != NULL)
+ {
+ for (i = 0; i < op1->rank; i++)
+ {
+ if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
+ {
+ gfc_error ("Shapes for operands at %L and %L are not conformable",
+ &op1->where, &op2->where);
+ t = FAILURE;
+ break;
+ }
+ }
+ }
+
+ return t;
+}
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
/* Resolve all subnodes-- give them types. */
- switch (e->operator)
+ switch (e->value.op.operator)
{
default:
- if (gfc_resolve_expr (e->op2) == FAILURE)
+ if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
return FAILURE;
/* Fall through... */
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
- if (gfc_resolve_expr (e->op1) == FAILURE)
+ if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
return FAILURE;
break;
}
/* Typecheck the new node. */
- op1 = e->op1;
- op2 = e->op2;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
break;
}
- sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
- gfc_op2string (e->operator), gfc_typename (&e->ts));
+ sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
+ gfc_op2string (e->value.op.operator), 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->operator), gfc_typename (&op1->ts),
+ _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
}
sprintf (msg,
- "Operands of string concatenation operator at %%L are %s/%s",
+ _("Operands of string concatenation operator at %%L are %s/%s"),
gfc_typename (&op1->ts), gfc_typename (&op2->ts));
goto bad_op;
break;
}
- sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
+ gfc_op2string (e->value.op.operator), 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_LE:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
- strcpy (msg, "COMPLEX quantities cannot be compared at %L");
+ strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
goto bad_op;
}
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
e->ts.type = BT_LOGICAL;
- e->ts.kind = gfc_default_logical_kind ();
+ e->ts.kind = gfc_default_logical_kind;
break;
}
gfc_type_convert_binary (e);
e->ts.type = BT_LOGICAL;
- e->ts.kind = gfc_default_logical_kind ();
+ e->ts.kind = gfc_default_logical_kind;
break;
}
- sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ 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));
+ else
+ sprintf (msg,
+ _("Operands of comparison operator '%s' at %%L are %s/%s"),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_USER:
if (op2 == NULL)
- sprintf (msg, "Operand of user operator '%s' at %%L is %s",
- e->uop->ns->proc_name->name, gfc_typename (&op1->ts));
+ sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
+ e->value.op.uop->name, gfc_typename (&op1->ts));
else
- sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
- e->uop->ns->proc_name->name, gfc_typename (&op1->ts),
+ sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
+ e->value.op.uop->name, gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
t = SUCCESS;
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
if (op1->rank == op2->rank)
{
e->rank = op1->rank;
-
if (e->shape == NULL)
+ {
+ t = compare_shapes(op1, op2);
+ if (t == FAILURE)
+ e->shape = NULL;
+ else
e->shape = gfc_copy_shape (op1->shape, op1->rank);
-
+ }
}
else
{
return t;
bad_op:
+
if (gfc_extend_expr (e) == SUCCESS)
return SUCCESS;
gfc_error (msg, &e->where);
+
return FAILURE;
}
{
/* Given start, end and stride values, calculate the minimum and
- maximum referenced indexes. */
+ maximum referenced indexes. */
switch (ar->type)
{
goto bound;
/* TODO: Possibly, we could warn about end[i] being out-of-bound although
- it is legal (see 6.2.2.3.1). */
+ it is legal (see 6.2.2.3.1). */
break;
if (gfc_resolve_expr (index) == FAILURE)
return FAILURE;
- if (index->ts.type != BT_INTEGER)
+ if (check_scalar && index->rank != 0)
{
- gfc_error ("Array index at %L must be of INTEGER type", &index->where);
+ gfc_error ("Array index at %L must be scalar", &index->where);
return FAILURE;
}
- if (check_scalar && index->rank != 0)
+ if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
{
- gfc_error ("Array index at %L must be scalar", &index->where);
+ gfc_error ("Array index at %L must be of INTEGER type",
+ &index->where);
return FAILURE;
}
- if (index->ts.kind != gfc_index_integer_kind)
+ if (index->ts.type == BT_REAL)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
+ &index->where) == FAILURE)
+ return FAILURE;
+
+ if (index->ts.kind != gfc_index_integer_kind
+ || index->ts.type != BT_INTEGER)
{
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
return SUCCESS;
}
+/* Resolve a dim argument to an intrinsic function. */
+
+try
+gfc_resolve_dim_arg (gfc_expr *dim)
+{
+ if (dim == NULL)
+ return SUCCESS;
+
+ if (gfc_resolve_expr (dim) == FAILURE)
+ return FAILURE;
+
+ if (dim->rank != 0)
+ {
+ gfc_error ("Argument dim at %L must be scalar", &dim->where);
+ 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;
+
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_index_integer_kind;
+
+ gfc_convert_type_warn (dim, &ts, 2, 0);
+ }
+
+ return SUCCESS;
+}
/* Given an expression that contains array references, update those array
references to point to the right array specifications. While this is
gfc_ref *ref;
as = e->symtree->n.sym->as;
- c = e->symtree->n.sym->components;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
break;
case REF_COMPONENT:
- for (; c; c = c->next)
+ for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
if (c == ref->u.c.component)
break;
as = c->as;
}
- c = c->ts.derived->components;
break;
case REF_SUBSTRING:
}
}
- if (compare_spec_to_ref (ar) == FAILURE)
+ if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
return SUCCESS;
/* Given an expression, determine its shape. This is easier than it sounds.
- Leaves the shape array NULL if it is not possible to determine the shape. */
+ Leaves the shape array NULL if it is not possible to determine the shape. */
static void
expression_shape (gfc_expr * e)
{
if (e->expr_type == EXPR_ARRAY)
goto done;
- /* Constructors can have a rank different from one via RESHAPE(). */
+ /* Constructors can have a rank different from one via RESHAPE(). */
if (e->symtree == NULL)
{
if (e->ref && resolve_ref (e) == FAILURE)
return FAILURE;
+ if (e->symtree == NULL)
+ return FAILURE;
+
sym = e->symtree->n.sym;
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
{
}
-/* Resolve the expressions in an iterator structure and require that they all
- be of integer type. */
+/* Resolve an expression from an iterator. They must be scalar and have
+ INTEGER or (optionally) REAL type. */
-try
-gfc_resolve_iterator (gfc_iterator * iter)
+static try
+gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
+ const char * name_msgid)
{
-
- if (gfc_resolve_expr (iter->var) == FAILURE)
+ if (gfc_resolve_expr (expr) == FAILURE)
return FAILURE;
- if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)
+ if (expr->rank != 0)
{
- gfc_error ("Loop variable at %L must be a scalar INTEGER",
- &iter->var->where);
+ gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
return FAILURE;
}
- if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
+ if (!(expr->ts.type == BT_INTEGER
+ || (expr->ts.type == BT_REAL && real_ok)))
{
- gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
- &iter->var->where);
+ if (real_ok)
+ gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
+ &expr->where);
+ else
+ gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
return FAILURE;
}
+ return SUCCESS;
+}
+
+
+/* Resolve the expressions in an iterator structure. If REAL_OK is
+ false allow only INTEGER type iterators, otherwise allow REAL types. */
+
+try
+gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
+{
- if (gfc_resolve_expr (iter->start) == FAILURE)
+ if (iter->var->ts.type == BT_REAL)
+ gfc_notify_std (GFC_STD_F95_DEL,
+ "Obsolete: REAL DO loop iterator at %L",
+ &iter->var->where);
+
+ if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
+ == FAILURE)
return FAILURE;
- if (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)
+ if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
{
- gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER",
- &iter->start->where);
+ gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
+ &iter->var->where);
return FAILURE;
}
- if (gfc_resolve_expr (iter->end) == FAILURE)
+ if (gfc_resolve_iterator_expr (iter->start, real_ok,
+ "Start expression in DO loop") == FAILURE)
return FAILURE;
- if (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)
- {
- gfc_error ("End expression in DO loop at %L must be a scalar INTEGER",
- &iter->end->where);
- return FAILURE;
- }
+ if (gfc_resolve_iterator_expr (iter->end, real_ok,
+ "End expression in DO loop") == FAILURE)
+ return FAILURE;
- if (gfc_resolve_expr (iter->step) == FAILURE)
+ if (gfc_resolve_iterator_expr (iter->step, real_ok,
+ "Step expression in DO loop") == FAILURE)
return FAILURE;
- if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0)
+ if (iter->step->expr_type == EXPR_CONSTANT)
{
- gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER",
- &iter->step->where);
- return FAILURE;
+ if ((iter->step->ts.type == BT_INTEGER
+ && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
+ || (iter->step->ts.type == BT_REAL
+ && mpfr_sgn (iter->step->value.real) == 0))
+ {
+ gfc_error ("Step expression in DO loop at %L cannot be zero",
+ &iter->step->where);
+ return FAILURE;
+ }
}
- if (iter->step->expr_type == EXPR_CONSTANT
- && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
- {
- gfc_error ("Step expression in DO loop at %L cannot be zero",
- &iter->step->where);
- return FAILURE;
- }
+ /* Convert start, end, and step to the same type as var. */
+ if (iter->start->ts.kind != iter->var->ts.kind
+ || iter->start->ts.type != iter->var->ts.type)
+ gfc_convert_type (iter->start, &iter->var->ts, 2);
+
+ if (iter->end->ts.kind != iter->var->ts.kind
+ || iter->end->ts.type != iter->var->ts.type)
+ gfc_convert_type (iter->end, &iter->var->ts, 2);
+
+ if (iter->step->ts.kind != iter->var->ts.kind
+ || iter->step->ts.type != iter->var->ts.type)
+ gfc_convert_type (iter->step, &iter->var->ts, 2);
return SUCCESS;
}
}
+/* Given a pointer to a symbol that is a derived type, see if it's
+ inaccessible, i.e. if it's defined in another module and the components are
+ PRIVATE. The search is recursive if necessary. Returns zero if no
+ inaccessible components are found, nonzero otherwise. */
+
+static int
+derived_inaccessible (gfc_symbol *sym)
+{
+ gfc_component *c;
+
+ if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
+ return 1;
+
+ for (c = sym->components; c; c = c->next)
+ {
+ if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
+ return 1;
+ }
+
+ return 0;
+}
+
+
/* Resolve the argument of a deallocate expression. The expression must be
a pointer or a full array. */
}
+/* Given the expression node e for an allocatable/pointer of derived type to be
+ allocated, get the expression node to be initialized afterwards (needed for
+ derived types with default initializers). */
+
+static gfc_expr *
+expr_to_initialize (gfc_expr * e)
+{
+ gfc_expr *result;
+ gfc_ref *ref;
+ int i;
+
+ result = gfc_copy_expr (e);
+
+ /* Change the last array reference from AR_ELEMENT to AR_FULL. */
+ for (ref = result->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->next == NULL)
+ {
+ ref->u.ar.type = AR_FULL;
+
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+
+ result->rank = ref->u.ar.dimen;
+ break;
+ }
+
+ return result;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
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
-resolve_allocate_expr (gfc_expr * e)
+resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
int i, pointer, allocatable, dimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
+ gfc_code *init_st;
+ gfc_expr *init_e;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
return FAILURE;
}
+ /* Add default initializer for those derived types that need them. */
+ if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
+ {
+ init_st = gfc_get_code ();
+ init_st->loc = code->loc;
+ init_st->op = EXEC_ASSIGN;
+ init_st->expr = expr_to_initialize (e);
+ init_st->expr2 = init_e;
+
+ init_st->next = code->next;
+ code->next = init_st;
+ }
+
if (pointer && dimension == 0)
return SUCCESS;
/* Callback function for our mergesort variant. Determines interval
overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
- op1 > op2. Assumes we're not dealing with the default case. */
+ op1 > op2. Assumes we're not dealing with the default case.
+ We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
+ There are nine situations to check. */
static int
-compare_cases (const void * _op1, const void * _op2)
+compare_cases (const gfc_case * op1, const gfc_case * op2)
{
- const gfc_case *op1, *op2;
+ int retval;
- op1 = (const gfc_case *) _op1;
- op2 = (const gfc_case *) _op2;
-
- if (op1->low == NULL) /* op1 = (:N) */
+ if (op1->low == NULL) /* op1 = (:L) */
{
- if (op2->low == NULL) /* op2 = (:M), so overlap. */
- return 0;
-
- else if (op2->high == NULL) /* op2 = (M:) */
- {
- if (gfc_compare_expr (op1->high, op2->low) < 0)
- return -1; /* N < M */
- else
- return 0;
- }
-
- else /* op2 = (L:M) */
+ /* op2 = (:N), so overlap. */
+ retval = 0;
+ /* op2 = (M:) or (M:N), L < M */
+ if (op2->low != NULL
+ && gfc_compare_expr (op1->high, op2->low) < 0)
+ retval = -1;
+ }
+ else if (op1->high == NULL) /* op1 = (K:) */
+ {
+ /* op2 = (M:), so overlap. */
+ retval = 0;
+ /* op2 = (:N) or (M:N), K > N */
+ if (op2->high != NULL
+ && gfc_compare_expr (op1->low, op2->high) > 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;
+ else if (op2->high == NULL) /* op2 = (M:), L < M */
+ retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
+ else /* op2 = (M:N) */
{
+ retval = 0;
+ /* L < M */
if (gfc_compare_expr (op1->high, op2->low) < 0)
- return -1; /* N < L */
- else
- return 0;
+ retval = -1;
+ /* K > N */
+ else if (gfc_compare_expr (op1->low, op2->high) > 0)
+ retval = 1;
}
}
- else if (op1->high == NULL) /* op1 = (N:) */
- {
- if (op2->low == NULL) /* op2 = (:M) */
- {
- if (gfc_compare_expr (op1->low, op2->high) > 0)
- return 1; /* N > M */
- else
- return 0;
- }
-
- else if (op2->high == NULL) /* op2 = (M:), so overlap. */
- return 0;
-
- else /* op2 = (L:M) */
- {
- if (gfc_compare_expr (op1->low, op2->high) > 0)
- return 1; /* N > M */
- else
- return 0;
- }
- }
-
- else /* op1 = (N:P) */
- {
- if (op2->low == NULL) /* op2 = (:M) */
- {
- if (gfc_compare_expr (op1->low, op2->high) > 0)
- return 1; /* N > M */
- else
- return 0;
- }
-
- else if (op2->high == NULL) /* op2 = (M:) */
- {
- if (gfc_compare_expr (op1->high, op2->low) < 0)
- return -1; /* P < M */
- else
- return 0;
- }
-
- else /* op2 = (L:M) */
- {
- if (gfc_compare_expr (op1->high, op2->low) < 0)
- return -1; /* P < L */
-
- if (gfc_compare_expr (op1->low, op2->high) > 0)
- return 1; /* N > M */
-
- return 0;
- }
- }
+ return retval;
}
/* Count this merge. */
nmerges++;
- /* Cut the list in two pieces by steppin INSIZE places
+ /* Cut the list in two pieces by stepping INSIZE places
forward in the list, starting from P. */
psize = 0;
q = p;
}
-/* Check to see if an expression is suitable for use in a CASE
- statement. Makes sure that all case expressions are scalar
- constants of the same type/kind. Return FAILURE if anything
- is wrong. */
+/* Check to see if an expression is suitable for use in a CASE statement.
+ Makes sure that all case expressions are scalar constants of the same
+ type. Return FAILURE if anything is wrong. */
static try
validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
{
- gfc_typespec case_ts = case_expr->ts;
-
if (e == NULL) return SUCCESS;
- if (e->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Expression in CASE statement at %L must be a constant",
- &e->where);
- return FAILURE;
- }
-
- if (e->ts.type != case_ts.type)
+ if (e->ts.type != case_expr->ts.type)
{
gfc_error ("Expression in CASE statement at %L must be of type %s",
- &e->where, gfc_basic_typename (case_ts.type));
+ &e->where, gfc_basic_typename (case_expr->ts.type));
return FAILURE;
}
- if (e->ts.kind != case_ts.kind)
+ /* C805 (R808) For a given case-construct, each case-value shall be of
+ the same type as case-expr. For character type, length differences
+ are allowed, but the kind type parameters shall be the same. */
+
+ 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_ts.kind);
+ &e->where, case_expr->ts.kind);
return FAILURE;
}
+ /* Convert the case value kind to that of case expression kind, if needed.
+ FIXME: Should a warning be issued? */
+ if (e->ts.kind != case_expr->ts.kind)
+ gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
+
if (e->rank != 0)
{
gfc_error ("Expression in CASE statement at %L must be scalar",
because they are illegal and we never even try to generate code.
We have the additional caveat that a SELECT construct could have
- been a computed GOTO in the source code. Furtunately we can fairly
+ been a computed GOTO in the source code. Fortunately we can fairly
easily work around that here: The case_expr for a "real" SELECT CASE
is in code->expr1, but for a computed GOTO it is in code->expr2. All
we have to do is make sure that the case_expr is a scalar integer
return;
}
+ /* PR 19168 has a long discussion concerning a mismatch of the kinds
+ of the SELECT CASE expression and its CASE values. Walk the lists
+ of case values, and if we find a mismatch, promote case_expr to
+ the appropriate kind. */
+
+ if (type == BT_LOGICAL || type == BT_INTEGER)
+ {
+ for (body = code->block; body; body = body->block)
+ {
+ /* Walk the case label list. */
+ for (cp = body->ext.case_list; cp; cp = cp->next)
+ {
+ /* Intercept the DEFAULT case. It does not have a kind. */
+ if (cp->low == NULL && cp->high == NULL)
+ continue;
+
+ /* 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)
+ continue;
+
+ /* FIXME: Should a warning be issued? */
+ if (cp->low != NULL
+ && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
+ gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
+
+ if (cp->high != NULL
+ && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
+ gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
+ }
+ }
+ }
+
/* Assume there is no DEFAULT case. */
default_case = NULL;
head = tail = NULL;
}
+/* Resolve a transfer statement. This is making sure that:
+ -- a derived type being transferred has only non-pointer components
+ -- a derived type being transferred doesn't have private components, unless
+ it's being transferred from the module where the type was defined
+ -- we're not trying to transfer a whole assumed size array. */
+
+static void
+resolve_transfer (gfc_code * code)
+{
+ gfc_typespec *ts;
+ gfc_symbol *sym;
+ gfc_ref *ref;
+ gfc_expr *exp;
+
+ exp = code->expr;
+
+ if (exp->expr_type != EXPR_VARIABLE)
+ return;
+
+ sym = exp->symtree->n.sym;
+ ts = &sym->ts;
+
+ /* Go to actual component transferred. */
+ for (ref = code->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ ts = &ref->u.c.component->ts;
+
+ if (ts->type == BT_DERIVED)
+ {
+ /* Check that transferred derived type doesn't contain POINTER
+ components. */
+ if (derived_pointer (ts->derived))
+ {
+ gfc_error ("Data transfer element at %L cannot have "
+ "POINTER components", &code->loc);
+ return;
+ }
+
+ if (derived_inaccessible (ts->derived))
+ {
+ gfc_error ("Data transfer element at %L cannot have "
+ "PRIVATE components",&code->loc);
+ return;
+ }
+ }
+
+ if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
+ && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
+ {
+ gfc_error ("Data transfer element at %L cannot be a full reference to "
+ "an assumed-size array", &code->loc);
+ return;
+ }
+}
+
+
/*********** Toplevel code resolution subroutines ***********/
/* Given a branch to a label and a namespace, if the branch is conforming.
switch (expr->expr_type)
{
case EXPR_VARIABLE:
- assert (expr->symtree->n.sym);
+ gcc_assert (expr->symtree->n.sym);
/* A scalar assignment */
if (!expr->ref)
if (expr->ref)
{
tmp = expr->ref;
- assert(expr->ref->type == REF_SUBSTRING);
+ 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)
gfc_error ("Unsupported statement while finding forall index in "
"expression");
break;
- default:
+
+ 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;
- }
- /* Find the FORALL index in the first operand. */
- if (expr->op1)
- {
- if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS)
- return SUCCESS;
+ default:
+ break;
}
- /* Find the FORALL index in the second operand. */
- if (expr->op2)
- {
- if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS)
- return SUCCESS;
- }
return FAILURE;
}
forall_index = var_expr[n]->symtree->n.sym;
/* Check whether the assignment target is one of the FORALL index
- variable. */
+ variable. */
if ((code->expr->expr_type == EXPR_VARIABLE)
&& (code->expr->symtree->n.sym == forall_index))
gfc_error ("Assignment to a FORALL index variable at %L",
if (forall_save == 0)
{
/* Count the total number of FORALL index in the nested FORALL
- construct in order to allocate the VAR_EXPR with proper size. */
+ construct in order to allocate the VAR_EXPR with proper size. */
next = code;
while ((next != NULL) && (next->op == EXEC_FORALL))
{
next = next->block->next;
}
- /* allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
+ /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
}
{
case EXEC_NOP:
case EXEC_CYCLE:
- case EXEC_IOLENGTH:
case EXEC_PAUSE:
case EXEC_STOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
- case EXEC_TRANSFER:
+ case EXEC_ENTRY:
break;
case EXEC_WHERE:
break;
case EXEC_GOTO:
- if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
+ if (code->expr != NULL)
+ {
+ if (code->expr->ts.type != BT_INTEGER)
+ gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
"variable", &code->expr->where);
- else
+ else if (code->expr->symtree->n.sym->attr.assign != 1)
+ gfc_error ("Variable '%s' has not been assigned a target label "
+ "at %L", code->expr->symtree->n.sym->name,
+ &code->expr->where);
+ }
+ else
resolve_branch (code->label, code);
break;
if (code->label->defined == ST_LABEL_UNKNOWN)
gfc_error ("Label %d referenced at %L is never defined",
code->label->value, &code->label->where);
- if (t == SUCCESS && code->expr->ts.type != BT_INTEGER)
- gfc_error ("ASSIGN statement at %L requires an INTEGER "
- "variable", &code->expr->where);
+ if (t == SUCCESS
+ && (code->expr->expr_type != EXPR_VARIABLE
+ || code->expr->symtree->n.sym->ts.type != BT_INTEGER
+ || code->expr->symtree->n.sym->ts.kind
+ != gfc_default_integer_kind
+ || code->expr->symtree->n.sym->as != NULL))
+ gfc_error ("ASSIGN statement at %L requires a scalar "
+ "default INTEGER variable", &code->expr->where);
break;
case EXEC_POINTER_ASSIGN:
case EXEC_DO:
if (code->ext.iterator != NULL)
- gfc_resolve_iterator (code->ext.iterator);
+ gfc_resolve_iterator (code->ext.iterator, true);
break;
case EXEC_DO_WHILE:
"of type INTEGER", &code->expr->where);
for (a = code->ext.alloc_list; a; a = a->next)
- resolve_allocate_expr (a->expr);
+ resolve_allocate_expr (a->expr, code);
break;
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
+ case EXEC_FLUSH:
if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
break;
case EXEC_INQUIRE:
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
+ break;
+
+ resolve_branch (code->ext.inquire->err, code);
+ break;
+
+ case EXEC_IOLENGTH:
+ gcc_assert (code->ext.inquire != NULL);
+ if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
break;
resolve_branch (code->ext.inquire->err, code);
resolve_branch (code->ext.dt->eor, code);
break;
+ case EXEC_TRANSFER:
+ resolve_transfer (code);
+ break;
+
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
+ int i, flag;
+ gfc_namelist *nl;
+ gfc_symtree * symtree;
+ gfc_symtree * this_symtree;
+ gfc_namespace * ns;
+ gfc_component * c;
+ gfc_formal_arglist * arg;
if (sym->attr.flavor == FL_UNKNOWN)
{
+
+ /* If we find that a flavorless symbol is an interface in one of the
+ parent namespaces, find its symtree in this namespace, free the
+ symbol and set the symtree to point to the interface symbol. */
+ for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
+ {
+ symtree = gfc_find_symtree (ns->sym_root, sym->name);
+ if (symtree && symtree->n.sym->generic)
+ {
+ this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+ sym->name);
+ sym->refs--;
+ if (!sym->refs)
+ gfc_free_symbol (sym);
+ symtree->n.sym->refs++;
+ this_symtree->n.sym = symtree->n.sym;
+ return;
+ }
+ }
+
+ /* Otherwise give it a flavor according to such attributes as
+ it has. */
if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
sym->attr.flavor = FL_VARIABLE;
else
if (sym->ts.type == BT_UNKNOWN)
{
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
- gfc_set_default_type (sym, 0, NULL);
+ gfc_set_default_type (sym, 1, NULL);
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
{
+ /* The specific case of an external procedure should emit an error
+ in the case that there is no implicit type. */
if (!mp_flag)
- gfc_set_default_type (sym, 0, NULL);
+ gfc_set_default_type (sym, sym->attr.external, NULL);
else
{
/* Result may be in another namespace. */
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
+ sym->attr.dimension = sym->result->attr.dimension;
+ sym->attr.pointer = sym->result->attr.pointer;
}
}
}
+ /* Assumed size arrays and assumed shape arrays must be dummy
+ arguments. */
+
if (sym->as != NULL
&& (sym->as->type == AS_ASSUMED_SIZE
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
- gfc_error("Assumed %s array at %L must be a dummy argument",
- sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
- &sym->declared_at);
+ if (sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array at %L must be a dummy argument",
+ &sym->declared_at);
+ else
+ gfc_error ("Assumed shape array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
+
+ /* A parameter array's shape needs to be constant. */
+
+ if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
+ && !gfc_is_compile_time_shape (sym->as))
+ {
+ gfc_error ("Parameter array '%s' at %L cannot be automatic "
+ "or assumed shape", sym->name, &sym->declared_at);
+ return;
+ }
+
+ /* A module array's shape needs to be constant. */
+
+ if (sym->ns->proc_name
+ && sym->attr.flavor == FL_VARIABLE
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && !sym->attr.use_assoc
+ && !sym->attr.allocatable
+ && !sym->attr.pointer
+ && sym->as != NULL
+ && !gfc_is_compile_time_shape (sym->as))
+ {
+ gfc_error ("Module array '%s' at %L cannot be automatic "
+ "or assumed shape", sym->name, &sym->declared_at);
return;
}
/* Make sure that character string variables with assumed length are
- dummy argument. */
+ dummy arguments. */
if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
&& sym->ts.type == BT_CHARACTER
}
}
+ /* If a derived type symbol has reached this point, without its
+ type being declared, we have an error. Notice that most
+ conditions that produce undefined derived types have already
+ been dealt with. However, the likes of:
+ implicit type(t) (t) ..... call foo (t) will get us here if
+ 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)
+ {
+ gfc_error ("The derived type '%s' at %L is of type '%s', "
+ "which has not been defined.", sym->name,
+ &sym->declared_at, sym->ts.derived->name);
+ sym->ts.type = BT_UNKNOWN;
+ return;
+ }
+
+ /* If a component of a derived type is of a type declared to be private,
+ either the derived type definition must contain the PRIVATE statement,
+ or the derived type must be private. (4.4.1 just after R427) */
+ if (sym->attr.flavor == FL_DERIVED
+ && sym->component_access != ACCESS_PRIVATE
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (c = sym->components; c; c = c->next)
+ {
+ if (c->ts.type == BT_DERIVED
+ && !c->ts.derived->attr.use_assoc
+ && !gfc_check_access(c->ts.derived->attr.access,
+ c->ts.derived->ns->default_access))
+ {
+ gfc_error ("The component '%s' is a PRIVATE type and cannot be "
+ "a component of '%s', which is PUBLIC at %L",
+ c->name, sym->name, &sym->declared_at);
+ 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
+ && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT
+ && sym->as
+ && sym->as->type == AS_ASSUMED_SIZE)
+ {
+ for (c = sym->ts.derived->components; c; c = c->next)
+ {
+ if (c->initializer)
+ {
+ gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
+ "ASSUMED SIZE and so cannot have a default initializer",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ }
+ }
+
+
+ /* Ensure that derived type formal arguments of a public procedure
+ are not of a private type. */
+ if (sym->attr.flavor == FL_PROCEDURE
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ 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))
+ {
+ gfc_error_now ("'%s' is 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;
+ }
+ }
+ }
+
/* Constraints on deferred shape variable. */
if (sym->attr.flavor == FL_VARIABLE
|| (sym->attr.flavor == FL_PROCEDURE
if (sym->attr.allocatable)
{
if (sym->attr.dimension)
- gfc_error ("Allocatable array at %L must have a deferred shape",
- &sym->declared_at);
+ gfc_error ("Allocatable array '%s' at %L must have "
+ "a deferred shape", sym->name, &sym->declared_at);
else
- gfc_error ("Object at %L may not be ALLOCATABLE",
- &sym->declared_at);
+ gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
+ sym->name, &sym->declared_at);
return;
}
if (sym->attr.pointer && sym->attr.dimension)
{
- gfc_error ("Pointer to array at %L must have a deferred shape",
- &sym->declared_at);
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape",
+ sym->name, &sym->declared_at);
return;
}
if (!mp_flag && !sym->attr.allocatable
&& !sym->attr.pointer && !sym->attr.dummy)
{
- gfc_error ("Array at %L cannot have a deferred shape",
- &sym->declared_at);
+ gfc_error ("Array '%s' at %L cannot have a deferred shape",
+ sym->name, &sym->declared_at);
return;
}
}
}
+ switch (sym->attr.flavor)
+ {
+ case FL_VARIABLE:
+ /* Can the symbol have an initializer? */
+ 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)
+ {
+ /* 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 = 1;
+ break;
+ }
+ }
+ }
+
+ /* Reject illegal initializers. */
+ if (sym->value && flag)
+ {
+ if (sym->attr.allocatable)
+ gfc_error ("Allocatable '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.external)
+ gfc_error ("External '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.dummy)
+ gfc_error ("Dummy '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.intrinsic)
+ gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else if (sym->attr.result)
+ gfc_error ("Function result '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ else
+ gfc_error ("Automatic array '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
+ /* Assign default initializer. */
+ if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
+ && !sym->attr.pointer)
+ sym->value = gfc_default_initializer (&sym->ts);
+ break;
+
+ case FL_NAMELIST:
+ /* Reject PRIVATE objects in a PUBLIC namelist. */
+ if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ if (!nl->sym->attr.use_assoc
+ &&
+ !(sym->ns->parent == nl->sym->ns)
+ &&
+ !gfc_check_access(nl->sym->attr.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);
+ }
+ }
+ break;
+
+ default:
+
+ /* An external symbol falls through to here if it is not referenced. */
+ if (sym->attr.external && sym->value)
+ {
+ gfc_error ("External object '%s' at %L may not have an initializer",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
+ break;
+ }
+
+
/* Make sure that intrinsic exist */
if (sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)
gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
/* Resolve array specifier. Check as well some constraints
- on COMMON blocks. */
+ on COMMON blocks. */
check_constant = sym->attr.in_common && !sym->attr.pointer;
gfc_resolve_array_spec (sym->as, check_constant);
static struct
{
gfc_data_value *vnode;
- int left;
+ unsigned int left;
}
values;
static try
next_data_value (void)
{
-
while (values.left == 0)
{
if (values.vnode->next == NULL)
values.left = values.vnode->repeat;
}
- values.left--;
return SUCCESS;
}
mpz_t size;
mpz_t offset;
try t;
- int mark = 0;
+ ar_type mark = AR_UNKNOWN;
int i;
mpz_t section_index[GFC_MAX_DIMENSIONS];
gfc_ref *ref;
gfc_internal_error ("check_data_variable(): Bad expression");
if (e->rank == 0)
- mpz_init_set_ui (size, 1);
+ {
+ mpz_init_set_ui (size, 1);
+ ref = NULL;
+ }
else
{
ref = e->ref;
continue;
break;
}
- assert (ref);
+ gcc_assert (ref);
- /* Set marks asscording to the reference pattern. */
+ /* Set marks according to the reference pattern. */
switch (ref->u.ar.type)
{
case AR_FULL:
- mark = 1;
+ mark = AR_FULL;
break;
case AR_SECTION:
ar = &ref->u.ar;
/* Get the start position of array section. */
gfc_get_section_index (ar, section_index, &offset);
- mark = 2;
+ mark = AR_SECTION;
break;
default:
- abort();
+ gcc_unreachable ();
}
if (gfc_array_size (e, &size) == FAILURE)
if (t == FAILURE)
break;
+ /* 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
+ seem tricky. */
+ if (mark == AR_FULL && ref && ref->next == NULL
+ && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
+ {
+ mpz_t range;
+
+ if (mpz_cmp_ui (size, values.left) >= 0)
+ {
+ mpz_init_set_ui (range, values.left);
+ mpz_sub_ui (size, size, values.left);
+ values.left = 0;
+ }
+ else
+ {
+ mpz_init_set (range, size);
+ values.left -= mpz_get_ui (size);
+ mpz_set_ui (size, 0);
+ }
+
+ gfc_assign_data_value_range (var->expr, values.vnode->expr,
+ offset, range);
+
+ mpz_add (offset, offset, range);
+ mpz_clear (range);
+ }
+
/* Assign initial value to symbol. */
- gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ else
+ {
+ values.left -= 1;
+ mpz_sub_ui (size, size, 1);
- if (mark == 1)
- mpz_add_ui (offset, offset, 1);
+ gfc_assign_data_value (var->expr, values.vnode->expr, offset);
- /* Modify the array section indexes and recalculate the offset for
- next element. */
- else if (mark == 2)
- gfc_advance_section (section_index, ar, &offset);
+ if (mark == AR_FULL)
+ mpz_add_ui (offset, offset, 1);
- mpz_sub_ui (size, size, 1);
+ /* Modify the array section indexes and recalculate the offset
+ for next element. */
+ else if (mark == AR_SECTION)
+ gfc_advance_section (section_index, ar, &offset);
+ }
}
- if (mark == 2)
+
+ if (mark == AR_SECTION)
{
for (i = 0; i < ar->dimen; i++)
mpz_clear (section_index[i]);
static try
resolve_data_variables (gfc_data_variable * d)
{
-
for (; d; d = d->next)
{
if (d->list == NULL)
}
else
{
- if (gfc_resolve_iterator (&d->iter) == FAILURE)
+ if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
return FAILURE;
if (d->iter.start->expr_type != EXPR_CONSTANT
static void
resolve_data (gfc_data * d)
{
-
if (resolve_data_variables (d->var) == FAILURE)
return;
int
gfc_impure_variable (gfc_symbol * sym)
{
-
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
}
+/* Returns the sequence type of a symbol or sequence. */
+
+static seq_type
+sequence_type (gfc_typespec ts)
+{
+ seq_type result;
+ gfc_component *c;
+
+ switch (ts.type)
+ {
+ case BT_DERIVED:
+
+ if (ts.derived->components == NULL)
+ return SEQ_NONDEFAULT;
+
+ result = sequence_type (ts.derived->components->ts);
+ for (c = ts.derived->components->next; c; c = c->next)
+ if (sequence_type (c->ts) != result)
+ return SEQ_MIXED;
+
+ return result;
+
+ case BT_CHARACTER:
+ if (ts.kind != gfc_default_character_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_CHARACTER;
+
+ case BT_INTEGER:
+ if (ts.kind != gfc_default_integer_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_REAL:
+ if (!(ts.kind == gfc_default_real_kind
+ || ts.kind == gfc_default_double_kind))
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_COMPLEX:
+ if (ts.kind != gfc_default_complex_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_LOGICAL:
+ if (ts.kind != gfc_default_logical_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ default:
+ return SEQ_NONDEFAULT;
+ }
+}
+
+
/* Resolve derived type EQUIVALENCE object. */
static try
in the structure. */
if (c->pointer)
{
- gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
+ gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
+ "cannot be an EQUIVALENCE object", sym->name, &e->where);
+ return FAILURE;
+ }
+
+ if (c->initializer)
+ {
+ gfc_error ("Derived type variable '%s' at %L with default initializer "
"cannot be an EQUIVALENCE object", sym->name, &e->where);
return FAILURE;
}
/* Resolve equivalence object.
- An EQUIVALENCE object shall not be a dummy argument, a pointer, an
- allocatable array, an object of nonsequence derived type, an object of
+ An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
+ an allocatable array, an object of nonsequence derived type, an object of
sequence derived type containing a pointer at any level of component
selection, an automatic object, a function name, an entry name, a result
name, a named constant, a structure component, or a subobject of any of
- the preceding objects. */
+ the preceding objects. A substring shall not have length zero. A
+ derived type shall not have components with default initialization nor
+ shall two objects of an equivalence group be initialized.
+ The simple constraints are done in symbol.c(check_conflict) and the rest
+ are implemented here. */
static void
resolve_equivalence (gfc_equiv *eq)
{
gfc_symbol *sym;
gfc_symbol *derived;
+ gfc_symbol *first_sym;
gfc_expr *e;
gfc_ref *r;
+ locus *last_where = NULL;
+ seq_type eq_type, last_eq_type;
+ gfc_typespec *last_ts;
+ int object;
+ const char *value_name;
+ const char *msg;
+
+ value_name = NULL;
+ last_ts = &eq->expr->symtree->n.sym->ts;
+
+ first_sym = eq->expr->symtree->n.sym;
- for (; eq; eq = eq->eq)
+ for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
+
+ e->ts = e->symtree->n.sym->ts;
+ /* match_varspec might not know yet if it is seeing
+ array reference or substring reference, as it doesn't
+ know the types. */
+ if (e->ref && e->ref->type == REF_ARRAY)
+ {
+ gfc_ref *ref = e->ref;
+ sym = e->symtree->n.sym;
+
+ if (sym->attr.dimension)
+ {
+ ref->u.ar.as = sym->as;
+ ref = ref->next;
+ }
+
+ /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
+ if (e->ts.type == BT_CHARACTER
+ && ref
+ && ref->type == REF_ARRAY
+ && ref->u.ar.dimen == 1
+ && ref->u.ar.dimen_type[0] == DIMEN_RANGE
+ && ref->u.ar.stride[0] == NULL)
+ {
+ gfc_expr *start = ref->u.ar.start[0];
+ gfc_expr *end = ref->u.ar.end[0];
+ void *mem = NULL;
+
+ /* Optimize away the (:) reference. */
+ if (start == NULL && end == NULL)
+ {
+ if (e->ref == ref)
+ e->ref = ref->next;
+ else
+ e->ref->next = ref->next;
+ mem = ref;
+ }
+ else
+ {
+ ref->type = REF_SUBSTRING;
+ if (start == NULL)
+ start = gfc_int_expr (1);
+ ref->u.ss.start = start;
+ if (end == NULL && e->ts.cl)
+ end = gfc_copy_expr (e->ts.cl->length);
+ ref->u.ss.end = end;
+ ref->u.ss.length = e->ts.cl;
+ e->ts.cl = NULL;
+ }
+ ref = ref->next;
+ gfc_free (mem);
+ }
+
+ /* Any further ref is an error. */
+ if (ref)
+ {
+ gcc_assert (ref->type == REF_ARRAY);
+ gfc_error ("Syntax error in EQUIVALENCE statement at %L",
+ &ref->u.ar.where);
+ continue;
+ }
+ }
+
if (gfc_resolve_expr (e) == FAILURE)
continue;
sym = e->symtree->n.sym;
-
- /* Shall not be a dummy argument. */
- if (sym->attr.dummy)
- {
- gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
- /* Shall not be an allocatable array. */
- if (sym->attr.allocatable)
- {
- gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
+ /* An equivalence statement cannot have more than one initialized
+ object. */
+ if (sym->value)
+ {
+ if (value_name != NULL)
+ {
+ gfc_error ("Initialized objects '%s' and '%s' cannot both "
+ "be in the EQUIVALENCE statement at %L",
+ value_name, sym->name, &e->where);
+ continue;
+ }
+ else
+ value_name = sym->name;
+ }
- /* Shall not be a pointer. */
- if (sym->attr.pointer)
- {
- gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
- sym->name, &e->where);
- continue;
- }
-
- /* Shall not be a function name, ... */
- if (sym->attr.function || sym->attr.result || sym->attr.entry
- || sym->attr.subroutine)
+ /* Shall not equivalence common block variables in a PURE procedure. */
+ if (sym->ns->proc_name
+ && sym->ns->proc_name->attr.pure
+ && sym->attr.in_common)
{
- gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
- sym->name, &e->where);
- continue;
+ gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
+ "object in the pure procedure '%s'",
+ sym->name, &e->where, sym->ns->proc_name->name);
+ break;
}
-
+
/* Shall not be a named constant. */
if (e->expr_type == EXPR_CONSTANT)
{
if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
continue;
+ /* Check that the types correspond correctly:
+ Note 5.28:
+ A numeric sequence structure may be equivalenced to another sequence
+ structure, an object of default integer type, default real type, double
+ precision real type, default logical type such that components of the
+ structure ultimately only become associated to objects of the same
+ kind. A character sequence structure may be equivalenced to an object
+ of default character kind or another character sequence structure.
+ Other objects may be equivalenced only to objects of the same type and
+ kind parameters. */
+
+ /* Identical types are unconditionally OK. */
+ if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
+ goto identical_types;
+
+ last_eq_type = sequence_type (*last_ts);
+ eq_type = sequence_type (sym->ts);
+
+ /* Since the pair of objects is not of the same type, mixed or
+ non-default sequences can be rejected. */
+
+ msg = "Sequence %s with mixed components in EQUIVALENCE "
+ "statement at %L with different type objects";
+ if ((object ==2
+ && last_eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
+ &e->where) == FAILURE))
+ continue;
+
+ msg = "Non-default type object or sequence %s in EQUIVALENCE "
+ "statement at %L with objects of different type";
+ if ((object ==2
+ && last_eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE))
+ continue;
+
+ msg ="Non-CHARACTER object '%s' in default CHARACTER "
+ "EQUIVALENCE statement at %L";
+ if (last_eq_type == SEQ_CHARACTER
+ && eq_type != SEQ_CHARACTER
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
+ continue;
+
+ msg ="Non-NUMERIC object '%s' in default NUMERIC "
+ "EQUIVALENCE statement at %L";
+ if (last_eq_type == SEQ_NUMERIC
+ && eq_type != SEQ_NUMERIC
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
+ continue;
+
+ identical_types:
+ last_ts =&sym->ts;
+ last_where = &e->where;
+
if (!e->ref)
continue;
continue;
}
- /* Shall not be a structure component. */
r = e->ref;
while (r)
{
- if (r->type == REF_COMPONENT)
- {
- gfc_error ("Structure component '%s' at %L cannot be an "
- "EQUIVALENCE object",
- r->u.c.component->name, &e->where);
- break;
- }
- r = r->next;
- }
+ /* Shall not be a structure component. */
+ if (r->type == REF_COMPONENT)
+ {
+ gfc_error ("Structure component '%s' at %L cannot be an "
+ "EQUIVALENCE object",
+ r->u.c.component->name, &e->where);
+ break;
+ }
+
+ /* A substring shall not have length zero. */
+ if (r->type == REF_SUBSTRING)
+ {
+ if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
+ {
+ gfc_error ("Substring at %L has length zero",
+ &r->u.ss.start->where);
+ break;
+ }
+ }
+ r = r->next;
+ }
}
}
-
-
+
+
+/* Resolve function and ENTRY types, issue diagnostics if needed. */
+
+static void
+resolve_fntype (gfc_namespace * ns)
+{
+ gfc_entry_list *el;
+ gfc_symbol *sym;
+
+ if (ns->proc_name == NULL || !ns->proc_name->attr.function)
+ return;
+
+ /* If there are any entries, ns->proc_name is the entry master
+ synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
+ if (ns->entries)
+ sym = ns->entries->sym;
+ else
+ sym = ns->proc_name;
+ if (sym->result == sym
+ && sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (sym, 0, NULL) == FAILURE
+ && !sym->attr.untyped)
+ {
+ gfc_error ("Function '%s' at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
+ sym->attr.untyped = 1;
+ }
+
+ if (ns->entries)
+ for (el = ns->entries->next; el; el = el->next)
+ {
+ if (el->sym->result == el->sym
+ && el->sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
+ && !el->sym->attr.untyped)
+ {
+ gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
+ el->sym->name, &el->sym->declared_at);
+ el->sym->attr.untyped = 1;
+ }
+ }
+}
+
+
/* This function is called after a complete program unit has been compiled.
Its purpose is to examine all of the expressions associated with a program
unit, assign types to all intermediate expressions, make sure that all
old_ns = gfc_current_ns;
gfc_current_ns = ns;
+ resolve_entries (ns);
+
resolve_contained_functions (ns);
gfc_traverse_ns (ns, resolve_symbol);
+ resolve_fntype (ns);
+
for (n = ns->contained; n; n = n->sibling)
{
if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
continue;
- if (cl->length->ts.type != BT_INTEGER)
- gfc_error
- ("Character length specification at %L must be of type INTEGER",
- &cl->length->where);
+ if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+ continue;
+
+ if (gfc_specification_expr (cl->length) == FAILURE)
+ continue;
}
gfc_traverse_ns (ns, resolve_values);
gfc_current_ns = old_ns;
}
-
OSDN Git Service
