diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 177 |
1 files changed, 165 insertions, 12 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ce5c3242ac1..77acef9300a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -694,6 +694,69 @@ procedure_kind (gfc_symbol * sym) return PTYPE_UNKNOWN; } +/* Check references to assumed size arrays. The flag need_full_assumed_size + is non-zero when matching actual arguments. */ + +static int need_full_assumed_size = 0; + +static bool +check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e) +{ + gfc_ref * ref; + int dim; + int last = 1; + + if (need_full_assumed_size + || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + for (dim = 0; dim < ref->u.ar.as->rank; dim++) + last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT); + + if (last) + { + gfc_error ("The upper bound in the last dimension must " + "appear in the reference to the assumed size " + "array '%s' at %L.", sym->name, &e->where); + return true; + } + return false; +} + + +/* Look for bad assumed size array references in argument expressions + of elemental and array valued intrinsic procedures. Since this is + called from procedure resolution functions, it only recurses at + operators. */ + +static bool +resolve_assumed_size_actual (gfc_expr *e) +{ + if (e == NULL) + return false; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + if (e->symtree + && check_assumed_size_reference (e->symtree->n.sym, e)) + return true; + break; + + case EXPR_OP: + if (resolve_assumed_size_actual (e->value.op.op1) + || resolve_assumed_size_actual (e->value.op.op2)) + return true; + break; + + default: + break; + } + return false; +} + /* Resolve an actual argument list. Most of the time, this is just resolving the expressions in the list. @@ -1072,10 +1135,18 @@ resolve_function (gfc_expr * expr) gfc_actual_arglist *arg; const char *name; try t; + int temp; + + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size++; if (resolve_actual_arglist (expr->value.function.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size--; + /* See if function is already resolved. */ if (expr->value.function.name != NULL) @@ -1113,6 +1184,9 @@ resolve_function (gfc_expr * expr) if (expr->expr_type != EXPR_FUNCTION) return t; + temp = need_full_assumed_size; + need_full_assumed_size = 0; + if (expr->value.function.actual != NULL && ((expr->value.function.esym != NULL && expr->value.function.esym->attr.elemental) @@ -1121,7 +1195,6 @@ resolve_function (gfc_expr * expr) { /* The rank of an elemental is the rank of its array argument(s). */ - for (arg = expr->value.function.actual; arg; arg = arg->next) { if (arg->expr != NULL && arg->expr->rank > 0) @@ -1130,8 +1203,45 @@ resolve_function (gfc_expr * expr) break; } } + + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } + } + + else if (expr->value.function.actual != NULL + && expr->value.function.isym != NULL + && strcmp (expr->value.function.isym->name, "lbound")) + { + /* Array instrinsics must also have the last upper bound of an + asumed size array argument. UBOUND and SIZE have to be + excluded from the check if the second argument is anything + than a constant. */ + int inquiry; + inquiry = strcmp (expr->value.function.isym->name, "ubound") == 0 + || strcmp (expr->value.function.isym->name, "size") == 0; + + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (inquiry && arg->next != NULL && arg->next->expr + && arg->next->expr->expr_type != EXPR_CONSTANT) + break; + + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } } + need_full_assumed_size = temp; + if (omp_workshare_flag && expr->value.function.esym && ! gfc_elemental (expr->value.function.esym)) @@ -1387,10 +1497,17 @@ static try resolve_call (gfc_code * c) { try t; + + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size++; if (resolve_actual_arglist (c->ext.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size--; + if (c->resolved_sym != NULL) return SUCCESS; @@ -1412,6 +1529,21 @@ resolve_call (gfc_code * c) gfc_internal_error ("resolve_subroutine(): bad function type"); } + if (c->ext.actual != NULL + && c->symtree->n.sym->attr.elemental) + { + gfc_actual_arglist * a; + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (a = c->ext.actual; a; a = a->next) + { + if (a->expr != NULL + && a->expr->rank > 0 + && resolve_assumed_size_actual (a->expr)) + return FAILURE; + } + } + return t; } @@ -2336,6 +2468,9 @@ resolve_variable (gfc_expr * e) e->ts = sym->ts; } + if (check_assumed_size_reference (sym, e)) + return FAILURE; + return SUCCESS; } @@ -2507,7 +2642,9 @@ gfc_resolve_iterator (gfc_iterator * iter, bool real_ok) } -/* Resolve a list of FORALL iterators. */ +/* Resolve a list of FORALL iterators. The FORALL index-name is constrained + to be a scalar INTEGER variable. The subscripts and stride are scalar + INTEGERs, and if stride is a constant it must be nonzero. */ static void resolve_forall_iterators (gfc_forall_iterator * iter) @@ -2516,28 +2653,35 @@ resolve_forall_iterators (gfc_forall_iterator * iter) while (iter) { if (gfc_resolve_expr (iter->var) == SUCCESS - && iter->var->ts.type != BT_INTEGER) - gfc_error ("FORALL Iteration variable at %L must be INTEGER", + && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)) + gfc_error ("FORALL index-name at %L must be a scalar INTEGER", &iter->var->where); if (gfc_resolve_expr (iter->start) == SUCCESS - && iter->start->ts.type != BT_INTEGER) - gfc_error ("FORALL start expression at %L must be INTEGER", + && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)) + gfc_error ("FORALL start expression at %L must be a scalar INTEGER", &iter->start->where); if (iter->var->ts.kind != iter->start->ts.kind) gfc_convert_type (iter->start, &iter->var->ts, 2); if (gfc_resolve_expr (iter->end) == SUCCESS - && iter->end->ts.type != BT_INTEGER) - gfc_error ("FORALL end expression at %L must be INTEGER", + && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)) + gfc_error ("FORALL end expression at %L must be a scalar INTEGER", &iter->end->where); if (iter->var->ts.kind != iter->end->ts.kind) gfc_convert_type (iter->end, &iter->var->ts, 2); - if (gfc_resolve_expr (iter->stride) == SUCCESS - && iter->stride->ts.type != BT_INTEGER) - gfc_error ("FORALL Stride expression at %L must be INTEGER", - &iter->stride->where); + if (gfc_resolve_expr (iter->stride) == SUCCESS) + { + if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0) + gfc_error ("FORALL stride expression at %L must be a scalar %s", + &iter->stride->where, "INTEGER"); + + if (iter->stride->expr_type == EXPR_CONSTANT + && mpz_cmp_ui(iter->stride->value.integer, 0) == 0) + gfc_error ("FORALL stride expression at %L cannot be zero", + &iter->stride->where); + } if (iter->var->ts.kind != iter->stride->ts.kind) gfc_convert_type (iter->stride, &iter->var->ts, 2); @@ -5544,6 +5688,15 @@ resolve_fntype (gfc_namespace * ns) sym->attr.untyped = 1; } + if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc + && !gfc_check_access (sym->ts.derived->attr.access, + sym->ts.derived->ns->default_access) + && gfc_check_access (sym->attr.access, sym->ns->default_access)) + { + gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'", + sym->name, &sym->declared_at, sym->ts.derived->name); + } + if (ns->entries) for (el = ns->entries->next; el; el = el->next) { |