X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fresolve.c;h=192a18c372c3dea6bf50c7ae327b35055b4faf6f;hb=9e25b302b728aeda854b69c0fc95971e4f3b0980;hp=08f08da0cf255dde2d43e1e73e72b9a433a84694;hpb=6f6743faa7dd8ab9e8497ef45eb6d6cc002fb7ba;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 08f08da0cf2..192a18c372c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1,5 +1,5 @@ /* 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. @@ -16,13 +16,22 @@ for more details. You should have received a copy of the GNU General Public License along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 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 + +/* 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(). */ @@ -149,7 +158,7 @@ resolve_formal_arglist (gfc_symbol * proc) 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)) { @@ -257,37 +266,26 @@ resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns) || 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) @@ -343,7 +341,7 @@ resolve_entries (gfc_namespace * ns) 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. */ @@ -372,17 +370,122 @@ resolve_entries (gfc_namespace * 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); 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; @@ -433,7 +536,7 @@ resolve_contained_functions (gfc_namespace * ns) /* 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) @@ -493,7 +596,7 @@ 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; @@ -616,6 +719,12 @@ resolve_actual_arglist (gfc_actual_arglist * arg) || 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. */ @@ -884,7 +993,7 @@ set_type: 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; } @@ -896,12 +1005,12 @@ set_type: } -/* 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; @@ -936,7 +1045,7 @@ static try 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) @@ -1261,6 +1370,36 @@ resolve_call (gfc_code * c) 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. */ @@ -1274,10 +1413,10 @@ resolve_operator (gfc_expr * e) /* 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... */ @@ -1285,17 +1424,17 @@ resolve_operator (gfc_expr * e) 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: @@ -1307,8 +1446,8 @@ resolve_operator (gfc_expr * e) 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: @@ -1323,8 +1462,8 @@ resolve_operator (gfc_expr * e) } 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; @@ -1337,7 +1476,7 @@ resolve_operator (gfc_expr * e) } 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; @@ -1356,8 +1495,8 @@ resolve_operator (gfc_expr * e) 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; @@ -1370,7 +1509,7 @@ resolve_operator (gfc_expr * e) 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; @@ -1380,7 +1519,7 @@ resolve_operator (gfc_expr * e) 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; } @@ -1404,19 +1543,26 @@ resolve_operator (gfc_expr * e) 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; @@ -1429,7 +1575,7 @@ resolve_operator (gfc_expr * e) t = SUCCESS; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_PLUS: case INTRINSIC_MINUS: @@ -1472,10 +1618,14 @@ resolve_operator (gfc_expr * e) 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 { @@ -1511,10 +1661,12 @@ resolve_operator (gfc_expr * e) return t; bad_op: + if (gfc_extend_expr (e) == SUCCESS) return SUCCESS; gfc_error (msg, &e->where); + return FAILURE; } @@ -1581,7 +1733,7 @@ check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as) { /* Given start, end and stride values, calculate the minimum and - maximum referenced indexes. */ + maximum referenced indexes. */ switch (ar->type) { @@ -1609,7 +1761,7 @@ check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as) 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; @@ -1677,19 +1829,26 @@ gfc_resolve_index (gfc_expr * index, int check_scalar) 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; @@ -1700,6 +1859,40 @@ gfc_resolve_index (gfc_expr * index, int check_scalar) 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 @@ -1982,7 +2175,7 @@ resolve_ref (gfc_expr * expr) /* 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) @@ -2022,7 +2215,7 @@ expression_rank (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) { @@ -2080,6 +2273,9 @@ resolve_variable (gfc_expr * e) 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) { @@ -2173,67 +2369,96 @@ gfc_resolve_expr (gfc_expr * e) } -/* 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 (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_expr (iter->start) == FAILURE) + 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; } @@ -2300,6 +2525,29 @@ derived_pointer (gfc_symbol * sym) } +/* 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. */ @@ -2464,89 +2712,52 @@ resolve_allocate_expr (gfc_expr * e) /* 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; } @@ -2587,7 +2798,7 @@ check_case_overlap (gfc_case * list) /* 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; @@ -2684,32 +2895,38 @@ check_case_overlap (gfc_case * list) } -/* 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", @@ -2792,6 +3009,40 @@ resolve_select (gfc_code * code) 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; @@ -2963,7 +3214,8 @@ resolve_select (gfc_code * code) /* 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 @@ -2998,7 +3250,7 @@ resolve_transfer (gfc_code * code) 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); @@ -3309,23 +3561,27 @@ gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol) 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; } @@ -3346,7 +3602,7 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) 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", @@ -3461,7 +3717,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) 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)) { @@ -3470,7 +3726,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) 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 *)); } @@ -3630,10 +3886,17 @@ resolve_code (gfc_code * code, gfc_namespace * ns) 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; @@ -3678,9 +3941,14 @@ resolve_code (gfc_code * code, gfc_namespace * ns) 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: @@ -3723,7 +3991,7 @@ resolve_code (gfc_code * code, gfc_namespace * ns) 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: @@ -3776,6 +4044,7 @@ resolve_code (gfc_code * code, gfc_namespace * ns) case EXEC_BACKSPACE: case EXEC_ENDFILE: case EXEC_REWIND: + case EXEC_FLUSH: if (gfc_resolve_filepos (code->ext.filepos) == FAILURE) break; @@ -3858,10 +4127,37 @@ resolve_symbol (gfc_symbol * sym) 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; + 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 @@ -3896,6 +4192,8 @@ resolve_symbol (gfc_symbol * sym) 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; } } } @@ -3908,9 +4206,12 @@ resolve_symbol (gfc_symbol * sym) || 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; } @@ -3982,6 +4283,48 @@ resolve_symbol (gfc_symbol * sym) } } + /* Ensure that derived type components of a public derived type + are not of a private type. */ + if (sym->attr.flavor == FL_DERIVED + && 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; + } + } + } + + /* 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 + && !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 @@ -4020,20 +4363,21 @@ resolve_symbol (gfc_symbol * sym) } } - 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. */ @@ -4044,7 +4388,7 @@ resolve_symbol (gfc_symbol * sym) || sym->as->upper[i] == NULL || sym->as->upper[i]->expr_type != EXPR_CONSTANT) { - whynot = "Automatic array"; + whynot = _("Automatic array"); break; } } @@ -4059,8 +4403,28 @@ resolve_symbol (gfc_symbol * sym) } /* 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; } @@ -4071,7 +4435,7 @@ resolve_symbol (gfc_symbol * sym) 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); @@ -4355,7 +4719,7 @@ resolve_data_variables (gfc_data_variable * d) } 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 @@ -4489,6 +4853,65 @@ warn_unused_label (gfc_namespace * ns) } +/* 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 @@ -4518,7 +4941,14 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) 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; } @@ -4528,60 +4958,132 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) /* 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; - for (; eq; eq = eq->eq) + value_name = NULL; + last_ts = &eq->expr->symtree->n.sym->ts; + + first_sym = eq->expr->symtree->n.sym; + + 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) + /* 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 ("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) - { - 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. */ @@ -4596,6 +5098,69 @@ resolve_equivalence (gfc_equiv *eq) 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; @@ -4608,23 +5173,77 @@ resolve_equivalence (gfc_equiv *eq) 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 @@ -4648,6 +5267,8 @@ gfc_resolve (gfc_namespace * 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)) @@ -4666,10 +5287,11 @@ gfc_resolve (gfc_namespace * ns) 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);