/* 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.
Software Foundation, 59 Temple Place - Suite 330,Boston, MA
02111-1307, USA. */
+
#include "config.h"
+#include "system.h"
#include "gfortran.h"
#include "arith.h" /* For gfc_compare_expr(). */
-#include <assert.h>
-#include <string.h>
+
/* Stack to push the current if we descend into a block during
resolution. See resolve_branch() and resolve_code(). */
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))
{
|| sym->attr.flavor == FL_VARIABLE))
return;
- /* 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. */
+ /* Try to find out of what the return type is. */
if (sym->result != NULL)
sym = sym->result;
if (sym->ts.type == BT_UNKNOWN)
{
- /* Assume we can find an implicit type. */
- t = SUCCESS;
-
- if (sym->result == NULL)
- t = gfc_set_default_type (sym, 0, ns);
- else
- {
- if (sym->result->ts.type == BT_UNKNOWN)
- t = gfc_set_default_type (sym->result, 0, NULL);
-
- sym->ts = sym->result->ts;
- }
+ t = gfc_set_default_type (sym, 0, ns);
if (t == FAILURE)
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
- introduce duplicates. */
+ introduce duplicates. */
static void
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
if (ns->proc_name->attr.entry_master)
return;
- /* If this isn't a procedure something has gone horribly wrong. */
- assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
+ /* 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;
out what is going on. */
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
master_count++, ns->proc_name->name);
- name[GFC_MAX_SYMBOL_LEN] = '\0';
gfc_get_ha_symbol (name, &proc);
- assert (proc != NULL);
+ gcc_assert (proc != NULL);
- gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL);
+ gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
if (ns->proc_name->attr.subroutine)
- gfc_add_subroutine (&proc->attr, NULL);
+ gfc_add_subroutine (&proc->attr, proc->name, NULL);
else
{
- gfc_add_function (&proc->attr, NULL);
- gfc_internal_error ("TODO: Functions with alternate entry points");
+ 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 (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
+ {
+ /* Otherwise the result will be passed through an 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)
+ gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
+ el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ else if (sym->attr.pointer)
+ gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
+ el == ns->entries ? "FUNCTION" : "ENTRY", 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;
+ default:
+ break;
+ }
+ if (sym)
+ gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
+ el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+ gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ }
+ }
+ }
}
proc->attr.access = ACCESS_PRIVATE;
proc->attr.entry_master = 1;
/* 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)
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. */
}
-/* 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:
}
sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
- gfc_op2string (e->operator), gfc_typename (&e->ts));
+ 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),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
}
sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
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_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));
+ 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),
+ 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;
/* 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)
{
-
- 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, &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);
+ gfc_error ("%s at %L must be INTEGER%s",
+ name,
+ &expr->where,
+ real_ok ? " or REAL" : "");
return FAILURE;
}
+ return SUCCESS;
+}
+
- if (gfc_resolve_expr (iter->start) == FAILURE)
+/* 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 (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;
}
/* 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;
-
- op1 = (const gfc_case *) _op1;
- op2 = (const gfc_case *) _op2;
+ int retval;
- 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) */
- {
- if (gfc_compare_expr (op1->high, op2->low) < 0)
- return -1; /* N < L */
- else
- return 0;
- }
+ /* 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 = (N:) */
+ else if (op1->high == NULL) /* op1 = (K:) */
{
- 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;
- }
+ /* 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 = (N:P) */
+ else /* op1 = (K:L) */
{
- 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 (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; /* 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;
+ retval = -1;
+ /* K > N */
+ else if (gfc_compare_expr (op1->low, op2->high) > 0)
+ retval = 1;
}
}
+
+ 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->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
+ -- 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 (ts->derived->component_access == ACCESS_PRIVATE)
+ {
+ 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_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
- case EXEC_TRANSFER:
case EXEC_ENTRY:
break;
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:
break;
case EXEC_IOLENGTH:
- assert(code->ext.inquire != NULL);
+ gcc_assert (code->ext.inquire != NULL);
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
break;
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);
int formal_ns_save, check_constant, mp_flag;
int i;
const char *whynot;
-
+ gfc_namelist *nl;
if (sym->attr.flavor == FL_UNKNOWN)
{
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;
}
}
}
}
}
- if (sym->attr.flavor == FL_VARIABLE)
+ switch (sym->attr.flavor)
{
+ case FL_VARIABLE:
/* Can the sybol have an initializer? */
whynot = NULL;
if (sym->attr.allocatable)
/* Assign default initializer. */
if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
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 (!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:
+ break;
}
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);
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:
break;
default:
- abort();
+ gcc_unreachable ();
}
if (gfc_array_size (e, &size) == FAILURE)
}
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
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);
OSDN Git Service
