diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 48 |
1 files changed, 43 insertions, 5 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fe37f2c..0e9916a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -829,6 +829,14 @@ resolve_actual_arglist (gfc_actual_arglist * arg) || sym->attr.external) { + /* If a procedure is not already determined to be something else + check if it is intrinsic. */ + if (!sym->attr.intrinsic + && !(sym->attr.external || sym->attr.use_assoc + || sym->attr.if_source == IFSRC_IFBODY) + && gfc_intrinsic_name (sym->name, sym->attr.subroutine)) + sym->attr.intrinsic = 1; + if (sym->attr.proc == PROC_ST_FUNCTION) { gfc_error ("Statement function '%s' at %L is not allowed as an " @@ -1381,8 +1389,9 @@ resolve_function (gfc_expr * expr) if (forall_flag) { gfc_error - ("Function reference to '%s' at %L is inside a FORALL block", - name, &expr->where); + ("reference to non-PURE function '%s' at %L inside a " + "FORALL %s", name, &expr->where, forall_flag == 2 ? + "mask" : "block"); t = FAILURE; } else if (gfc_pure (NULL)) @@ -3619,6 +3628,7 @@ resolve_select (gfc_code * code) gfc_expr *case_expr; gfc_case *cp, *default_case, *tail, *head; int seen_unreachable; + int seen_logical; int ncases; bt type; try t; @@ -3701,6 +3711,7 @@ resolve_select (gfc_code * code) default_case = NULL; head = tail = NULL; ncases = 0; + seen_logical = 0; for (body = code->block; body; body = body->block) { @@ -3753,6 +3764,21 @@ resolve_select (gfc_code * code) break; } + if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT) + { + int value; + value = cp->low->value.logical == 0 ? 2 : 1; + if (value & seen_logical) + { + gfc_error ("constant logical value in CASE statement " + "is repeated at %L", + &cp->low->where); + t = FAILURE; + break; + } + seen_logical |= value; + } + if (cp->low != NULL && cp->high != NULL && cp->low != cp->high && gfc_compare_expr (cp->low, cp->high) > 0) @@ -4513,6 +4539,7 @@ static void resolve_code (gfc_code * code, gfc_namespace * ns) { int omp_workshare_save; + int forall_save; code_stack frame; gfc_alloc *a; try t; @@ -4524,14 +4551,13 @@ resolve_code (gfc_code * code, gfc_namespace * ns) for (; code; code = code->next) { frame.current = code; + forall_save = forall_flag; if (code->op == EXEC_FORALL) { - int forall_save = forall_flag; - forall_flag = 1; gfc_resolve_forall (code, ns, forall_save); - forall_flag = forall_save; + forall_flag = 2; } else if (code->block) { @@ -4567,6 +4593,8 @@ resolve_code (gfc_code * code, gfc_namespace * ns) } t = gfc_resolve_expr (code->expr); + forall_flag = forall_save; + if (gfc_resolve_expr (code->expr2) == FAILURE) t = FAILURE; @@ -5181,6 +5209,16 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) return FAILURE; } + /* An elemental function is required to return a scalar 12.7.1 */ + if (sym->attr.elemental && sym->attr.function && sym->as) + { + gfc_error ("ELEMENTAL function '%s' at %L must have a scalar " + "result", sym->name, &sym->declared_at); + /* Reset so that the error only occurs once. */ + sym->attr.elemental = 0; + return FAILURE; + } + /* 5.1.1.5 of the Standard: A function name declared with an asterisk char-len-param shall not be array-valued, pointer-valued, recursive or pure. ....snip... A character value of * may only be used in the |