X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fresolve.c;h=5f7a76a57a4712fff4168d0eb514bf86333870d4;hb=4442ee19a9cf127c216c9751394a7c7f8530623d;hp=00d9e3daa6347c79c1ad927b66b672dba48d0fc1;hpb=1089cf271985c32459caede3146341e98f58cad4;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 00d9e3daa63..5f7a76a57a4 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. @@ -19,11 +19,12 @@ 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. */ + #include "config.h" +#include "system.h" #include "gfortran.h" #include "arith.h" /* For gfc_compare_expr(). */ -#include -#include + /* Stack to push the current if we descend into a block during resolution. See resolve_branch() and resolve_code(). */ @@ -150,7 +151,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)) { @@ -247,83 +248,259 @@ resolve_formal_arglists (gfc_namespace * ns) } -/* Resolve contained function types. Because contained functions can call one - another, they have to be worked out before any of the contained procedures - can be resolved. - - The good news is that if a function doesn't already have a type, the only - way it can get one is through an IMPLICIT type or a RESULT variable, because - by definition contained functions are contained namespace they're contained - in, not in a sibling or parent namespace. */ - static void -resolve_contained_functions (gfc_namespace * ns) +resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns) { - gfc_symbol *contained_sym, *sym_lower; - gfc_namespace *child; try t; + + /* If this namespace is not a function, ignore it. */ + if (! sym + || !(sym->attr.function + || sym->attr.flavor == FL_VARIABLE)) + return; - resolve_formal_arglists (ns); + /* Try to find out of what the return type is. */ + if (sym->result != NULL) + sym = sym->result; - for (child = ns->contained; child; child = child->sibling) + if (sym->ts.type == BT_UNKNOWN) { - sym_lower = child->proc_name; + t = gfc_set_default_type (sym, 0, ns); - /* If this namespace is not a function, ignore it. */ - if (! sym_lower - || !( sym_lower->attr.function - || sym_lower->attr.flavor == FL_VARIABLE)) - continue; + if (t == FAILURE) + gfc_error ("Contained function '%s' at %L has no IMPLICIT type", + sym->name, &sym->declared_at); /* FIXME */ + } +} - /* Find the contained symbol in the current namespace. */ - gfc_find_symbol (sym_lower->name, ns, 0, &contained_sym); - if (contained_sym == NULL) - gfc_internal_error ("resolve_contained_functions(): Contained " - "function not found in parent namespace"); +/* Add NEW_ARGS to the formal argument list of PROC, taking care not to + introduce duplicates. */ - /* Try to find out of what type the function is. If there was an - explicit RESULT clause, try to get the type from it. If the - function is never defined, set it to the implicit type. If - even that fails, give up. */ - if (sym_lower->result != NULL) - sym_lower = sym_lower->result; +static void +merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) +{ + gfc_formal_arglist *f, *new_arglist; + gfc_symbol *new_sym; - if (sym_lower->ts.type == BT_UNKNOWN) + for (; new_args != NULL; new_args = new_args->next) + { + new_sym = new_args->sym; + /* See if ths arg is already in the formal argument list. */ + for (f = proc->formal; f; f = f->next) { - /* Assume we can find an implicit type. */ - t = SUCCESS; + if (new_sym == f->sym) + break; + } - if (sym_lower->result == NULL) - t = gfc_set_default_type (sym_lower, 0, child); - else - { - if (sym_lower->result->ts.type == BT_UNKNOWN) - t = gfc_set_default_type (sym_lower->result, 0, NULL); + if (f) + continue; - sym_lower->ts = sym_lower->result->ts; - } + /* Add a new argument. Argument order is not important. */ + new_arglist = gfc_get_formal_arglist (); + new_arglist->sym = new_sym; + new_arglist->next = proc->formal; + proc->formal = new_arglist; + } +} - if (t == FAILURE) - gfc_error ("Contained function '%s' at %L has no IMPLICIT type", - sym_lower->name, &sym_lower->declared_at); /* FIXME */ + +/* Resolve alternate entry points. If a symbol has multiple entry points we + create a new master symbol for the main routine, and turn the existing + symbol into an entry point. */ + +static void +resolve_entries (gfc_namespace * ns) +{ + gfc_namespace *old_ns; + gfc_code *c; + gfc_symbol *proc; + gfc_entry_list *el; + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int master_count = 0; + + if (ns->proc_name == NULL) + return; + + /* No need to do anything if this procedure doesn't have alternate entry + points. */ + if (!ns->entries) + return; + + /* We may already have resolved alternate entry points. */ + if (ns->proc_name->attr.entry_master) + return; + + /* If this isn't a procedure something has gone horribly wrong. */ + gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE); + + /* Remember the current namespace. */ + old_ns = gfc_current_ns; + + gfc_current_ns = ns; + + /* Add the main entry point to the list of entry points. */ + el = gfc_get_entry_list (); + el->sym = ns->proc_name; + el->id = 0; + el->next = ns->entries; + ns->entries = el; + ns->proc_name->attr.entry = 1; + + /* Add an entry statement for it. */ + c = gfc_get_code (); + c->op = EXEC_ENTRY; + c->ext.entry = el; + c->next = ns->code; + ns->code = c; + + /* Create a new symbol for the master function. */ + /* Give the internal function a unique name (within this file). + Also include the function name so the user has some hope of figuring + out what is going on. */ + snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", + master_count++, ns->proc_name->name); + gfc_get_ha_symbol (name, &proc); + gcc_assert (proc != NULL); + + gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL); + if (ns->proc_name->attr.subroutine) + gfc_add_subroutine (&proc->attr, proc->name, NULL); + else + { + gfc_symbol *sym; + gfc_typespec *ts, *fts; + + gfc_add_function (&proc->attr, proc->name, NULL); + proc->result = proc; + fts = &ns->entries->sym->result->ts; + if (fts->type == BT_UNKNOWN) + fts = gfc_get_default_type (ns->entries->sym->result, NULL); + for (el = ns->entries->next; el; el = el->next) + { + ts = &el->sym->result->ts; + if (ts->type == BT_UNKNOWN) + ts = gfc_get_default_type (el->sym->result, NULL); + if (! gfc_compare_types (ts, fts) + || (el->sym->result->attr.dimension + != ns->entries->sym->result->attr.dimension) + || (el->sym->result->attr.pointer + != ns->entries->sym->result->attr.pointer)) + break; } - /* If the symbol in the parent of the contained namespace is not - the same as the one in contained namespace itself, copy over - the type information. */ - /* ??? Shouldn't we replace the symbol with the parent symbol instead? */ - if (contained_sym != sym_lower) + if (el == NULL) + { + sym = ns->entries->sym->result; + /* All result types the same. */ + proc->ts = *fts; + if (sym->attr.dimension) + gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); + if (sym->attr.pointer) + gfc_add_pointer (&proc->attr, NULL); + } + else { - contained_sym->ts = sym_lower->ts; - contained_sym->as = gfc_copy_array_spec (sym_lower->as); + /* Otherwise the result will be passed through 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; + + /* Merge all the entry point arguments. */ + for (el = ns->entries; el; el = el->next) + merge_argument_lists (proc, el->sym->formal); + + /* Use the master function for the function body. */ + ns->proc_name = proc; + + /* Finalize the new symbols. */ + gfc_commit_symbols (); + + /* Restore the original namespace. */ + gfc_current_ns = old_ns; +} + + +/* Resolve contained function types. Because contained functions can call one + another, they have to be worked out before any of the contained procedures + can be resolved. + + The good news is that if a function doesn't already have a type, the only + way it can get one is through an IMPLICIT type or a RESULT variable, because + by definition contained functions are contained namespace they're contained + in, not in a sibling or parent namespace. */ + +static void +resolve_contained_functions (gfc_namespace * ns) +{ + gfc_namespace *child; + gfc_entry_list *el; + + resolve_formal_arglists (ns); + + for (child = ns->contained; child; child = child->sibling) + { + /* Resolve alternate entry points first. */ + resolve_entries (child); + + /* Then check function return types. */ + resolve_contained_fntype (child->proc_name, child); + for (el = child->entries; el; el = el->next) + resolve_contained_fntype (el->sym, child); + } } /* Resolve all of the elements of a structure constructor and make sure that - the types are correct. */ + the types are correct. */ static try resolve_structure_cons (gfc_expr * expr) @@ -383,7 +560,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; @@ -506,6 +683,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. */ @@ -786,12 +969,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; @@ -826,7 +1009,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) @@ -1151,6 +1334,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. */ @@ -1164,10 +1377,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... */ @@ -1175,17 +1388,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: @@ -1198,7 +1411,7 @@ resolve_operator (gfc_expr * e) } 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: @@ -1214,7 +1427,7 @@ 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), + gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1247,7 +1460,7 @@ resolve_operator (gfc_expr * e) } 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; @@ -1281,7 +1494,7 @@ resolve_operator (gfc_expr * e) 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; } @@ -1290,12 +1503,12 @@ resolve_operator (gfc_expr * e) 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; @@ -1303,10 +1516,10 @@ resolve_operator (gfc_expr * e) 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; @@ -1319,7 +1532,7 @@ resolve_operator (gfc_expr * e) t = SUCCESS; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_PLUS: case INTRINSIC_MINUS: @@ -1362,10 +1575,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 { @@ -1401,10 +1618,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; } @@ -1471,7 +1690,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) { @@ -1499,7 +1718,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; @@ -1567,19 +1786,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; @@ -1872,7 +2098,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) @@ -1912,7 +2138,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) { @@ -1970,6 +2196,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) { @@ -2063,67 +2292,94 @@ 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) { - - 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; } @@ -2354,89 +2610,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; } @@ -2477,7 +2696,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; @@ -2574,32 +2793,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", @@ -2625,7 +2850,7 @@ validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr) 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 @@ -2682,6 +2907,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; @@ -2851,6 +3110,61 @@ 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 + -- 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. @@ -3058,7 +3372,7 @@ gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol) switch (expr->expr_type) { case EXPR_VARIABLE: - assert (expr->symtree->n.sym); + gcc_assert (expr->symtree->n.sym); /* A scalar assignment */ if (!expr->ref) @@ -3130,7 +3444,7 @@ gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol) 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) @@ -3144,23 +3458,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; } @@ -3181,7 +3499,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", @@ -3296,7 +3614,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)) { @@ -3305,7 +3623,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 *)); } @@ -3457,7 +3775,7 @@ resolve_code (gfc_code * code, gfc_namespace * ns) case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: - case EXEC_TRANSFER: + case EXEC_ENTRY: break; case EXEC_WHERE: @@ -3465,10 +3783,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; @@ -3513,9 +3838,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: @@ -3558,7 +3888,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: @@ -3625,7 +3955,7 @@ resolve_code (gfc_code * code, gfc_namespace * ns) break; case EXEC_IOLENGTH: - assert(code->ext.inquire != NULL); + gcc_assert (code->ext.inquire != NULL); if (gfc_resolve_inquire (code->ext.inquire) == FAILURE) break; @@ -3642,6 +3972,10 @@ resolve_code (gfc_code * code, gfc_namespace * ns) 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); @@ -3689,7 +4023,7 @@ resolve_symbol (gfc_symbol * sym) int formal_ns_save, check_constant, mp_flag; int i; const char *whynot; - + gfc_namelist *nl; if (sym->attr.flavor == FL_UNKNOWN) { @@ -3727,6 +4061,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; } } } @@ -3851,8 +4187,9 @@ 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) @@ -3892,6 +4229,25 @@ resolve_symbol (gfc_symbol * sym) /* 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; } @@ -3902,7 +4258,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); @@ -3925,7 +4281,7 @@ resolve_symbol (gfc_symbol * sym) static struct { gfc_data_value *vnode; - int left; + unsigned int left; } values; @@ -3935,7 +4291,6 @@ values; static try next_data_value (void) { - while (values.left == 0) { if (values.vnode->next == NULL) @@ -3945,7 +4300,6 @@ next_data_value (void) values.left = values.vnode->repeat; } - values.left--; return SUCCESS; } @@ -3974,7 +4328,10 @@ check_data_variable (gfc_data_variable * var, locus * where) gfc_internal_error ("check_data_variable(): Bad expression"); if (e->rank == 0) - mpz_init_set_ui (size, 1); + { + mpz_init_set_ui (size, 1); + ref = NULL; + } else { ref = e->ref; @@ -3988,9 +4345,9 @@ check_data_variable (gfc_data_variable * var, locus * where) 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: @@ -4005,7 +4362,7 @@ check_data_variable (gfc_data_variable * var, locus * where) break; default: - abort(); + gcc_unreachable (); } if (gfc_array_size (e, &size) == FAILURE) @@ -4033,19 +4390,54 @@ check_data_variable (gfc_data_variable * var, locus * where) if (t == FAILURE) break; + /* If we have more than one element left in the repeat count, + and we have more than one element left in the target variable, + then create a range assignment. */ + /* ??? Only done for full arrays for now, since array sections + seem tricky. */ + if (mark == AR_FULL && ref && ref->next == NULL + && values.left > 1 && mpz_cmp_ui (size, 1) > 0) + { + mpz_t range; + + if (mpz_cmp_ui (size, values.left) >= 0) + { + mpz_init_set_ui (range, values.left); + mpz_sub_ui (size, size, values.left); + values.left = 0; + } + else + { + mpz_init_set (range, size); + values.left -= mpz_get_ui (size); + mpz_set_ui (size, 0); + } + + gfc_assign_data_value_range (var->expr, values.vnode->expr, + offset, range); + + mpz_add (offset, offset, range); + mpz_clear (range); + } + /* Assign initial value to symbol. */ - gfc_assign_data_value (var->expr, values.vnode->expr, offset); + else + { + values.left -= 1; + mpz_sub_ui (size, size, 1); - if (mark == AR_FULL) - mpz_add_ui (offset, offset, 1); + gfc_assign_data_value (var->expr, values.vnode->expr, offset); - /* Modify the array section indexes and recalculate the offset for - next element. */ - else if (mark == AR_SECTION) - gfc_advance_section (section_index, ar, &offset); + if (mark == AR_FULL) + mpz_add_ui (offset, offset, 1); - mpz_sub_ui (size, size, 1); + /* Modify the array section indexes and recalculate the offset + for next element. */ + else if (mark == AR_SECTION) + gfc_advance_section (section_index, ar, &offset); + } } + if (mark == AR_SECTION) { for (i = 0; i < ar->dimen; i++) @@ -4141,7 +4533,6 @@ traverse_data_var (gfc_data_variable * var, locus * where) static try resolve_data_variables (gfc_data_variable * d) { - for (; d; d = d->next) { if (d->list == NULL) @@ -4151,7 +4542,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 @@ -4175,7 +4566,6 @@ resolve_data_variables (gfc_data_variable * d) static void resolve_data (gfc_data * d) { - if (resolve_data_variables (d->var) == FAILURE) return; @@ -4200,7 +4590,6 @@ resolve_data (gfc_data * d) int gfc_impure_variable (gfc_symbol * sym) { - if (sym->attr.use_assoc || sym->attr.in_common) return 1; @@ -4440,6 +4829,8 @@ gfc_resolve (gfc_namespace * ns) old_ns = gfc_current_ns; gfc_current_ns = ns; + resolve_entries (ns); + resolve_contained_functions (ns); gfc_traverse_ns (ns, resolve_symbol); @@ -4462,10 +4853,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); @@ -4492,4 +4884,3 @@ gfc_resolve (gfc_namespace * ns) gfc_current_ns = old_ns; } -