/* 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 <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;
+ t = gfc_set_default_type (sym, 0, ns);
- if (sym->result == NULL)
- t = gfc_set_default_type (sym, 0, ns);
- else
+ if (t == FAILURE && !sym->attr.untyped)
{
- if (sym->result->ts.type == BT_UNKNOWN)
- t = gfc_set_default_type (sym->result, 0, NULL);
-
- sym->ts = sym->result->ts;
+ gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at); /* FIXME */
+ sym->attr.untyped = 1;
}
-
- if (t == FAILURE)
- gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
- sym->name, &sym->declared_at); /* FIXME */
}
}
/* 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. */
+ /* If this isn't a procedure something has gone horribly wrong. */
gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
/* Remember the current namespace. */
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);
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 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;
/* 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. */
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;
}
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->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->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
/* 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;
+}
+
- 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;
}
}
+/* 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. */
/* 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) */
- {
- 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 (gfc_compare_expr (op1->high, op2->low) < 0)
- return -1; /* P < M */
- else
- return 0;
- }
-
- else /* op2 = (L: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 < 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",
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
+ -- 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
return;
}
- if (ts->derived->component_access == ACCESS_PRIVATE)
+ if (derived_inaccessible (ts->derived))
{
gfc_error ("Data transfer element at %L cannot have "
"PRIVATE components",&code->loc);
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 *));
}
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:
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
+ case EXEC_FLUSH:
if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
break;
int formal_ns_save, check_constant, mp_flag;
int i;
const char *whynot;
-
+ gfc_namelist *nl;
+ gfc_symtree * symtree;
+ gfc_symtree * this_symtree;
+ gfc_namespace * ns;
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
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;
}
}
}
|| 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;
}
}
}
- 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)
- whynot = "Allocatable";
+ whynot = _("Allocatable");
else if (sym->attr.external)
- whynot = "External";
+ whynot = _("External");
else if (sym->attr.dummy)
- whynot = "Dummy";
+ whynot = _("Dummy");
else if (sym->attr.intrinsic)
- whynot = "Intrinsic";
+ whynot = _("Intrinsic");
else if (sym->attr.result)
- whynot = "Function Result";
+ whynot = _("Function Result");
else if (sym->attr.dimension && !sym->attr.pointer)
{
/* Don't allow initialization of automatic arrays. */
|| sym->as->upper[i] == NULL
|| sym->as->upper[i]->expr_type != EXPR_CONSTANT)
{
- whynot = "Automatic array";
+ whynot = _("Automatic array");
break;
}
}
}
/* Assign default initializer. */
- if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
+ if (sym->ts.type == BT_DERIVED && !(sym->value || whynot)
+ && !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 (!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);
}
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
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. */
static void
resolve_equivalence (gfc_equiv *eq)
for (; eq; eq = eq->eq)
{
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;
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
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);
OSDN Git Service
