diff options
Diffstat (limited to 'gcc/fortran/expr.c')
| -rw-r--r-- | gcc/fortran/expr.c | 646 |
1 files changed, 319 insertions, 327 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 8deb4ebf05d..1a531d92afc 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -610,7 +610,7 @@ gfc_replace_expr (gfc_expr *dest, gfc_expr *src) /* Try to extract an integer constant from the passed expression node. Returns an error message or NULL if the result is set. It is - tempting to generate an error and return SUCCESS or FAILURE, but + tempting to generate an error and return true or false, but failure is OK for some callers. */ const char * @@ -1005,27 +1005,27 @@ is_subref_array (gfc_expr * e) /* Try to collapse intrinsic expressions. */ -static gfc_try +static bool simplify_intrinsic_op (gfc_expr *p, int type) { gfc_intrinsic_op op; gfc_expr *op1, *op2, *result; if (p->value.op.op == INTRINSIC_USER) - return SUCCESS; + return true; op1 = p->value.op.op1; op2 = p->value.op.op2; op = p->value.op.op; - if (gfc_simplify_expr (op1, type) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (op2, type) == FAILURE) - return FAILURE; + if (!gfc_simplify_expr (op1, type)) + return false; + if (!gfc_simplify_expr (op2, type)) + return false; if (!gfc_is_constant_expr (op1) || (op2 != NULL && !gfc_is_constant_expr (op2))) - return SUCCESS; + return true; /* Rip p apart. */ p->value.op.op1 = NULL; @@ -1127,21 +1127,21 @@ simplify_intrinsic_op (gfc_expr *p, int type) { gfc_free_expr (op1); gfc_free_expr (op2); - return FAILURE; + return false; } result->rank = p->rank; result->where = p->where; gfc_replace_expr (p, result); - return SUCCESS; + return true; } /* Subroutine to simplify constructor expressions. Mutually recursive with gfc_simplify_expr(). */ -static gfc_try +static bool simplify_constructor (gfc_constructor_base base, int type) { gfc_constructor *c; @@ -1150,10 +1150,10 @@ simplify_constructor (gfc_constructor_base base, int type) for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { if (c->iterator - && (gfc_simplify_expr (c->iterator->start, type) == FAILURE - || gfc_simplify_expr (c->iterator->end, type) == FAILURE - || gfc_simplify_expr (c->iterator->step, type) == FAILURE)) - return FAILURE; + && (!gfc_simplify_expr(c->iterator->start, type) + || !gfc_simplify_expr (c->iterator->end, type) + || !gfc_simplify_expr (c->iterator->step, type))) + return false; if (c->expr) { @@ -1162,7 +1162,7 @@ simplify_constructor (gfc_constructor_base base, int type) doing so can make a dog's dinner of complicated things. */ p = gfc_copy_expr (c->expr); - if (gfc_simplify_expr (p, type) == FAILURE) + if (!gfc_simplify_expr (p, type)) { gfc_free_expr (p); continue; @@ -1172,13 +1172,13 @@ simplify_constructor (gfc_constructor_base base, int type) } } - return SUCCESS; + return true; } /* Pull a single array element out of an array constructor. */ -static gfc_try +static bool find_array_element (gfc_constructor_base base, gfc_array_ref *ar, gfc_constructor **rval) { @@ -1190,9 +1190,9 @@ find_array_element (gfc_constructor_base base, gfc_array_ref *ar, mpz_t tmp; gfc_constructor *cons; gfc_expr *e; - gfc_try t; + bool t; - t = SUCCESS; + t = true; e = NULL; mpz_init_set_ui (offset, 0); @@ -1201,10 +1201,10 @@ find_array_element (gfc_constructor_base base, gfc_array_ref *ar, mpz_init_set_ui (span, 1); for (i = 0; i < ar->dimen; i++) { - if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE - || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE) + if (!gfc_reduce_init_expr (ar->as->lower[i]) + || !gfc_reduce_init_expr (ar->as->upper[i])) { - t = FAILURE; + t = false; cons = NULL; goto depart; } @@ -1229,7 +1229,7 @@ find_array_element (gfc_constructor_base base, gfc_array_ref *ar, gfc_error ("Index in dimension %d is out of bounds " "at %L", i + 1, &ar->c_where[i]); cons = NULL; - t = FAILURE; + t = false; goto depart; } @@ -1309,7 +1309,7 @@ remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) /* Pull an array section out of an array constructor. */ -static gfc_try +static bool find_array_section (gfc_expr *expr, gfc_ref *ref) { int idx; @@ -1335,9 +1335,9 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) gfc_expr *step; gfc_expr *upper; gfc_expr *lower; - gfc_try t; + bool t; - t = SUCCESS; + t = true; base = expr->value.constructor; expr->value.constructor = NULL; @@ -1381,7 +1381,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) { - t = FAILURE; + t = false; goto cleanup; } @@ -1407,7 +1407,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) { gfc_error ("index in dimension %d is out of bounds " "at %L", d + 1, &ref->u.ar.c_where[d]); - t = FAILURE; + t = false; goto cleanup; } } @@ -1418,7 +1418,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) || (finish && finish->expr_type != EXPR_CONSTANT) || (step && step->expr_type != EXPR_CONSTANT)) { - t = FAILURE; + t = false; goto cleanup; } @@ -1458,7 +1458,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) { gfc_error ("index in dimension %d is out of bounds " "at %L", d + 1, &ref->u.ar.c_where[d]); - t = FAILURE; + t = false; goto cleanup; } @@ -1537,7 +1537,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) "upper limit. See -fmax-array-constructor " "option", &expr->where, gfc_option.flag_max_array_constructor); - return FAILURE; + return false; } cons = gfc_constructor_lookup (base, limit); @@ -1567,7 +1567,7 @@ cleanup: /* Pull a substring out of an expression. */ -static gfc_try +static bool find_substring_ref (gfc_expr *p, gfc_expr **newp) { int end; @@ -1577,7 +1577,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) - return FAILURE; + return false; *newp = gfc_copy_expr (p); free ((*newp)->value.character.string); @@ -1591,7 +1591,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) memcpy (chr, &p->value.character.string[start - 1], length * sizeof (gfc_char_t)); chr[length] = '\0'; - return SUCCESS; + return true; } @@ -1599,7 +1599,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) /* Simplify a subobject reference of a constructor. This occurs when parameter variable values are substituted. */ -static gfc_try +static bool simplify_const_ref (gfc_expr *p) { gfc_constructor *cons, *c; @@ -1621,19 +1621,18 @@ simplify_const_ref (gfc_expr *p) remove_subobject_ref (p, NULL); break; } - if (find_array_element (p->value.constructor, &p->ref->u.ar, - &cons) == FAILURE) - return FAILURE; + if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) + return false; if (!cons) - return SUCCESS; + return true; remove_subobject_ref (p, cons); break; case AR_SECTION: - if (find_array_section (p, p->ref) == FAILURE) - return FAILURE; + if (!find_array_section (p, p->ref)) + return false; p->ref->u.ar.type = AR_FULL; /* Fall through. */ @@ -1646,8 +1645,8 @@ simplify_const_ref (gfc_expr *p) c; c = gfc_constructor_next (c)) { c->expr->ref = gfc_copy_ref (p->ref->next); - if (simplify_const_ref (c->expr) == FAILURE) - return FAILURE; + if (!simplify_const_ref (c->expr)) + return false; } if (p->ts.type == BT_DERIVED @@ -1695,7 +1694,7 @@ simplify_const_ref (gfc_expr *p) break; default: - return SUCCESS; + return true; } break; @@ -1706,8 +1705,8 @@ simplify_const_ref (gfc_expr *p) break; case REF_SUBSTRING: - if (find_substring_ref (p, &newp) == FAILURE) - return FAILURE; + if (!find_substring_ref (p, &newp)) + return false; gfc_replace_expr (p, newp); gfc_free_ref_list (p->ref); @@ -1716,13 +1715,13 @@ simplify_const_ref (gfc_expr *p) } } - return SUCCESS; + return true; } /* Simplify a chain of references. */ -static gfc_try +static bool simplify_ref_chain (gfc_ref *ref, int type) { int n; @@ -1734,41 +1733,41 @@ simplify_ref_chain (gfc_ref *ref, int type) case REF_ARRAY: for (n = 0; n < ref->u.ar.dimen; n++) { - if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE) - return FAILURE; + if (!gfc_simplify_expr (ref->u.ar.start[n], type)) + return false; + if (!gfc_simplify_expr (ref->u.ar.end[n], type)) + return false; + if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) + return false; } break; case REF_SUBSTRING: - if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE) - return FAILURE; - if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE) - return FAILURE; + if (!gfc_simplify_expr (ref->u.ss.start, type)) + return false; + if (!gfc_simplify_expr (ref->u.ss.end, type)) + return false; break; default: break; } } - return SUCCESS; + return true; } /* Try to substitute the value of a parameter variable. */ -static gfc_try +static bool simplify_parameter_variable (gfc_expr *p, int type) { gfc_expr *e; - gfc_try t; + bool t; e = gfc_copy_expr (p->symtree->n.sym->value); if (e == NULL) - return FAILURE; + return false; e->rank = p->rank; @@ -1778,7 +1777,7 @@ simplify_parameter_variable (gfc_expr *p, int type) t = gfc_simplify_expr (e, type); /* Only use the simplification if it eliminated all subobject references. */ - if (t == SUCCESS && !e->ref) + if (t && !e->ref) gfc_replace_expr (p, e); else gfc_free_expr (e); @@ -1802,16 +1801,16 @@ simplify_parameter_variable (gfc_expr *p, int type) 0 Basic expression parsing 1 Simplifying array constructors -- will substitute iterator values. - Returns FAILURE on error, SUCCESS otherwise. - NOTE: Will return SUCCESS even if the expression can not be simplified. */ + Returns false on error, true otherwise. + NOTE: Will return true even if the expression can not be simplified. */ -gfc_try +bool gfc_simplify_expr (gfc_expr *p, int type) { gfc_actual_arglist *ap; if (p == NULL) - return SUCCESS; + return true; switch (p->expr_type) { @@ -1821,18 +1820,18 @@ gfc_simplify_expr (gfc_expr *p, int type) case EXPR_FUNCTION: for (ap = p->value.function.actual; ap; ap = ap->next) - if (gfc_simplify_expr (ap->expr, type) == FAILURE) - return FAILURE; + if (!gfc_simplify_expr (ap->expr, type)) + return false; if (p->value.function.isym != NULL && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) - return FAILURE; + return false; break; case EXPR_SUBSTRING: - if (simplify_ref_chain (p->ref, type) == FAILURE) - return FAILURE; + if (!simplify_ref_chain (p->ref, type)) + return false; if (gfc_is_constant_expr (p)) { @@ -1871,8 +1870,8 @@ gfc_simplify_expr (gfc_expr *p, int type) break; case EXPR_OP: - if (simplify_intrinsic_op (p, type) == FAILURE) - return FAILURE; + if (!simplify_intrinsic_op (p, type)) + return false; break; case EXPR_VARIABLE: @@ -1882,8 +1881,8 @@ gfc_simplify_expr (gfc_expr *p, int type) && (gfc_init_expr_flag || p->ref || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) { - if (simplify_parameter_variable (p, type) == FAILURE) - return FAILURE; + if (!simplify_parameter_variable (p, type)) + return false; break; } @@ -1893,25 +1892,25 @@ gfc_simplify_expr (gfc_expr *p, int type) } /* Simplify subcomponent references. */ - if (simplify_ref_chain (p->ref, type) == FAILURE) - return FAILURE; + if (!simplify_ref_chain (p->ref, type)) + return false; break; case EXPR_STRUCTURE: case EXPR_ARRAY: - if (simplify_ref_chain (p->ref, type) == FAILURE) - return FAILURE; + if (!simplify_ref_chain (p->ref, type)) + return false; - if (simplify_constructor (p->value.constructor, type) == FAILURE) - return FAILURE; + if (!simplify_constructor (p->value.constructor, type)) + return false; if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY && p->ref->u.ar.type == AR_FULL) gfc_expand_constructor (p, false); - if (simplify_const_ref (p) == FAILURE) - return FAILURE; + if (!simplify_const_ref (p)) + return false; break; @@ -1921,7 +1920,7 @@ gfc_simplify_expr (gfc_expr *p, int type) break; } - return SUCCESS; + return true; } @@ -1932,7 +1931,7 @@ gfc_simplify_expr (gfc_expr *p, int type) static bt et0 (gfc_expr *e) { - if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS) + if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) return BT_INTEGER; return e->ts.type; @@ -1941,7 +1940,7 @@ et0 (gfc_expr *e) /* Scalarize an expression for an elemental intrinsic call. */ -static gfc_try +static bool scalarize_intrinsic_call (gfc_expr *e) { gfc_actual_arglist *a, *b; @@ -1967,7 +1966,7 @@ scalarize_intrinsic_call (gfc_expr *e) } if (!array_arg) - return FAILURE; + return false; old = gfc_copy_expr (e); @@ -1984,7 +1983,7 @@ scalarize_intrinsic_call (gfc_expr *e) for (; a; a = a->next) { /* Check that this is OK for an initialization expression. */ - if (a->expr && gfc_check_init_expr (a->expr) == FAILURE) + if (a->expr && !gfc_check_init_expr (a->expr)) goto cleanup; rank[n] = 0; @@ -2060,7 +2059,7 @@ scalarize_intrinsic_call (gfc_expr *e) /* Free "expr" but not the pointers it contains. */ free (expr); gfc_free_expr (old); - return SUCCESS; + return true; compliance: gfc_error_now ("elemental function arguments at %C are not compliant"); @@ -2068,18 +2067,18 @@ compliance: cleanup: gfc_free_expr (expr); gfc_free_expr (old); - return FAILURE; + return false; } -static gfc_try -check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) +static bool +check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) { gfc_expr *op1 = e->value.op.op1; gfc_expr *op2 = e->value.op.op2; - if ((*check_function) (op1) == FAILURE) - return FAILURE; + if (!(*check_function)(op1)) + return false; switch (e->value.op.op) { @@ -2101,15 +2100,15 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) case INTRINSIC_LT_OS: case INTRINSIC_LE: case INTRINSIC_LE_OS: - if ((*check_function) (op2) == FAILURE) - return FAILURE; + if (!(*check_function)(op2)) + return false; if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) { gfc_error ("Numeric or CHARACTER operands are required in " "expression at %L", &e->where); - return FAILURE; + return false; } break; @@ -2118,8 +2117,8 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: case INTRINSIC_POWER: - if ((*check_function) (op2) == FAILURE) - return FAILURE; + if (!(*check_function)(op2)) + return false; if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) goto not_numeric; @@ -2127,21 +2126,21 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) break; case INTRINSIC_CONCAT: - if ((*check_function) (op2) == FAILURE) - return FAILURE; + if (!(*check_function)(op2)) + return false; if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) { gfc_error ("Concatenation operator in expression at %L " "must have two CHARACTER operands", &op1->where); - return FAILURE; + return false; } if (op1->ts.kind != op2->ts.kind) { gfc_error ("Concat operator at %L must concatenate strings of the " "same kind", &e->where); - return FAILURE; + return false; } break; @@ -2151,7 +2150,7 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) { gfc_error (".NOT. operator in expression at %L must have a LOGICAL " "operand", &op1->where); - return FAILURE; + return false; } break; @@ -2160,14 +2159,14 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) case INTRINSIC_OR: case INTRINSIC_EQV: case INTRINSIC_NEQV: - if ((*check_function) (op2) == FAILURE) - return FAILURE; + if (!(*check_function)(op2)) + return false; if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) { gfc_error ("LOGICAL operands are required in expression at %L", &e->where); - return FAILURE; + return false; } break; @@ -2178,20 +2177,20 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) default: gfc_error ("Only intrinsic operators can be used in expression at %L", &e->where); - return FAILURE; + return false; } - return SUCCESS; + return true; not_numeric: gfc_error ("Numeric operands are required in expression at %L", &e->where); - return FAILURE; + return false; } /* F2003, 7.1.7 (3): In init expression, allocatable components must not be data-initialized. */ -static gfc_try +static bool check_alloc_comp_init (gfc_expr *e) { gfc_component *comp; @@ -2210,11 +2209,11 @@ check_alloc_comp_init (gfc_expr *e) gfc_error("Invalid initialization expression for ALLOCATABLE " "component '%s' in structure constructor at %L", comp->name, &ctor->expr->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } static match @@ -2223,13 +2222,13 @@ check_init_expr_arguments (gfc_expr *e) gfc_actual_arglist *ap; for (ap = e->value.function.actual; ap; ap = ap->next) - if (gfc_check_init_expr (ap->expr) == FAILURE) + if (!gfc_check_init_expr (ap->expr)) return MATCH_ERROR; return MATCH_YES; } -static gfc_try check_restricted (gfc_expr *); +static bool check_restricted (gfc_expr *); /* F95, 7.1.6.1, Initialization expressions, (7) F2003, 7.1.7 Initialization expression, (8) */ @@ -2305,8 +2304,7 @@ check_inquiry (gfc_expr *e, int not_restricted) if (ap->expr->ts.type == BT_UNKNOWN) { if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN - && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns) - == FAILURE) + && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)) return MATCH_NO; ap->expr->ts = ap->expr->symtree->n.sym->ts; @@ -2325,12 +2323,12 @@ check_inquiry (gfc_expr *e, int not_restricted) &ap->expr->where); return MATCH_ERROR; } - else if (not_restricted && gfc_check_init_expr (ap->expr) == FAILURE) + else if (not_restricted && !gfc_check_init_expr (ap->expr)) return MATCH_ERROR; if (not_restricted == 0 && ap->expr->expr_type != EXPR_VARIABLE - && check_restricted (ap->expr) == FAILURE) + && !check_restricted (ap->expr)) return MATCH_ERROR; if (not_restricted == 0 @@ -2416,9 +2414,8 @@ check_elemental (gfc_expr *e) if (e->ts.type != BT_INTEGER && e->ts.type != BT_CHARACTER - && gfc_notify_std (GFC_STD_F2003, "Evaluation of " - "nonstandard initialization expression at %L", - &e->where) == FAILURE) + && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " + "initialization expression at %L", &e->where)) return MATCH_ERROR; return check_init_expr_arguments (e); @@ -2441,28 +2438,28 @@ check_conversion (gfc_expr *e) node if all goes well. This would normally happen when the expression is constructed but function references are assumed to be intrinsics in the context of initialization expressions. If - FAILURE is returned an error message has been generated. */ + false is returned an error message has been generated. */ -gfc_try +bool gfc_check_init_expr (gfc_expr *e) { match m; - gfc_try t; + bool t; if (e == NULL) - return SUCCESS; + return true; switch (e->expr_type) { case EXPR_OP: t = check_intrinsic_op (e, gfc_check_init_expr); - if (t == SUCCESS) + if (t) t = gfc_simplify_expr (e, 0); break; case EXPR_FUNCTION: - t = FAILURE; + t = false; { gfc_intrinsic_sym* isym; @@ -2491,13 +2488,13 @@ gfc_check_init_expr (gfc_expr *e) } if (m == MATCH_ERROR) - return FAILURE; + return false; /* Try to scalarize an elemental intrinsic function that has an array argument. */ isym = gfc_find_function (e->symtree->n.sym->name); if (isym && isym->elemental - && (t = scalarize_intrinsic_call (e)) == SUCCESS) + && (t = scalarize_intrinsic_call(e))) break; } @@ -2507,9 +2504,9 @@ gfc_check_init_expr (gfc_expr *e) break; case EXPR_VARIABLE: - t = SUCCESS; + t = true; - if (gfc_check_iter_variable (e) == SUCCESS) + if (gfc_check_iter_variable (e)) break; if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) @@ -2521,7 +2518,7 @@ gfc_check_init_expr (gfc_expr *e) { gfc_error("PARAMETER '%s' is used at %L before its definition " "is complete", e->symtree->n.sym->name, &e->where); - t = FAILURE; + t = false; } else t = simplify_parameter_variable (e, 0); @@ -2532,7 +2529,7 @@ gfc_check_init_expr (gfc_expr *e) if (gfc_in_match_data ()) break; - t = FAILURE; + t = false; if (e->symtree->n.sym->as) { @@ -2575,42 +2572,42 @@ gfc_check_init_expr (gfc_expr *e) case EXPR_CONSTANT: case EXPR_NULL: - t = SUCCESS; + t = true; break; case EXPR_SUBSTRING: t = gfc_check_init_expr (e->ref->u.ss.start); - if (t == FAILURE) + if (!t) break; t = gfc_check_init_expr (e->ref->u.ss.end); - if (t == SUCCESS) + if (t) t = gfc_simplify_expr (e, 0); break; case EXPR_STRUCTURE: - t = e->ts.is_iso_c ? SUCCESS : FAILURE; - if (t == SUCCESS) + t = e->ts.is_iso_c ? true : false; + if (t) break; t = check_alloc_comp_init (e); - if (t == FAILURE) + if (!t) break; t = gfc_check_constructor (e, gfc_check_init_expr); - if (t == FAILURE) + if (!t) break; break; case EXPR_ARRAY: t = gfc_check_constructor (e, gfc_check_init_expr); - if (t == FAILURE) + if (!t) break; t = gfc_expand_constructor (e, true); - if (t == FAILURE) + if (!t) break; t = gfc_check_constructor_type (e); @@ -2625,31 +2622,31 @@ gfc_check_init_expr (gfc_expr *e) /* Reduces a general expression to an initialization expression (a constant). This used to be part of gfc_match_init_expr. - Note that this function doesn't free the given expression on FAILURE. */ + Note that this function doesn't free the given expression on false. */ -gfc_try +bool gfc_reduce_init_expr (gfc_expr *expr) { - gfc_try t; + bool t; gfc_init_expr_flag = true; t = gfc_resolve_expr (expr); - if (t == SUCCESS) + if (t) t = gfc_check_init_expr (expr); gfc_init_expr_flag = false; - if (t == FAILURE) - return FAILURE; + if (!t) + return false; if (expr->expr_type == EXPR_ARRAY) { - if (gfc_check_constructor_type (expr) == FAILURE) - return FAILURE; - if (gfc_expand_constructor (expr, true) == FAILURE) - return FAILURE; + if (!gfc_check_constructor_type (expr)) + return false; + if (!gfc_expand_constructor (expr, true)) + return false; } - return SUCCESS; + return true; } @@ -2661,7 +2658,7 @@ gfc_match_init_expr (gfc_expr **result) { gfc_expr *expr; match m; - gfc_try t; + bool t; expr = NULL; @@ -2675,7 +2672,7 @@ gfc_match_init_expr (gfc_expr **result) } t = gfc_reduce_init_expr (expr); - if (t != SUCCESS) + if (!t) { gfc_free_expr (expr); gfc_init_expr_flag = false; @@ -2693,16 +2690,16 @@ gfc_match_init_expr (gfc_expr **result) restricted expression and optionally if the expression type is integer or character. */ -static gfc_try +static bool restricted_args (gfc_actual_arglist *a) { for (; a; a = a->next) { - if (check_restricted (a->expr) == FAILURE) - return FAILURE; + if (!check_restricted (a->expr)) + return false; } - return SUCCESS; + return true; } @@ -2711,7 +2708,7 @@ restricted_args (gfc_actual_arglist *a) /* Make sure a non-intrinsic function is a specification function. */ -static gfc_try +static bool external_spec_function (gfc_expr *e) { gfc_symbol *f; @@ -2722,28 +2719,28 @@ external_spec_function (gfc_expr *e) { gfc_error ("Specification function '%s' at %L cannot be a statement " "function", f->name, &e->where); - return FAILURE; + return false; } if (f->attr.proc == PROC_INTERNAL) { gfc_error ("Specification function '%s' at %L cannot be an internal " "function", f->name, &e->where); - return FAILURE; + return false; } if (!f->attr.pure && !f->attr.elemental) { gfc_error ("Specification function '%s' at %L must be PURE", f->name, &e->where); - return FAILURE; + return false; } if (f->attr.recursive) { gfc_error ("Specification function '%s' at %L cannot be RECURSIVE", f->name, &e->where); - return FAILURE; + return false; } return restricted_args (e->value.function.actual); @@ -2753,12 +2750,12 @@ external_spec_function (gfc_expr *e) /* Check to see that a function reference to an intrinsic is a restricted expression. */ -static gfc_try +static bool restricted_intrinsic (gfc_expr *e) { /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ if (check_inquiry (e, 0) == MATCH_YES) - return SUCCESS; + return true; return restricted_args (e->value.function.actual); } @@ -2766,39 +2763,39 @@ restricted_intrinsic (gfc_expr *e) /* Check the expressions of an actual arglist. Used by check_restricted. */ -static gfc_try -check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*)) +static bool +check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) { for (; arg; arg = arg->next) - if (checker (arg->expr) == FAILURE) - return FAILURE; + if (!checker (arg->expr)) + return false; - return SUCCESS; + return true; } /* Check the subscription expressions of a reference chain with a checking function; used by check_restricted. */ -static gfc_try -check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*)) +static bool +check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) { int dim; if (!ref) - return SUCCESS; + return true; switch (ref->type) { case REF_ARRAY: for (dim = 0; dim != ref->u.ar.dimen; ++dim) { - if (checker (ref->u.ar.start[dim]) == FAILURE) - return FAILURE; - if (checker (ref->u.ar.end[dim]) == FAILURE) - return FAILURE; - if (checker (ref->u.ar.stride[dim]) == FAILURE) - return FAILURE; + if (!checker (ref->u.ar.start[dim])) + return false; + if (!checker (ref->u.ar.end[dim])) + return false; + if (!checker (ref->u.ar.stride[dim])) + return false; } break; @@ -2807,10 +2804,10 @@ check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*)) break; case REF_SUBSTRING: - if (checker (ref->u.ss.start) == FAILURE) - return FAILURE; - if (checker (ref->u.ss.end) == FAILURE) - return FAILURE; + if (!checker (ref->u.ss.start)) + return false; + if (!checker (ref->u.ss.end)) + return false; break; default: @@ -2824,22 +2821,22 @@ check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*)) /* Verify that an expression is a restricted expression. Like its cousin check_init_expr(), an error message is generated if we - return FAILURE. */ + return false. */ -static gfc_try +static bool check_restricted (gfc_expr *e) { gfc_symbol* sym; - gfc_try t; + bool t; if (e == NULL) - return SUCCESS; + return true; switch (e->expr_type) { case EXPR_OP: t = check_intrinsic_op (e, check_restricted); - if (t == SUCCESS) + if (t) t = gfc_simplify_expr (e, 0); break; @@ -2848,24 +2845,24 @@ check_restricted (gfc_expr *e) if (e->value.function.esym) { t = check_arglist (e->value.function.actual, &check_restricted); - if (t == SUCCESS) + if (t) t = external_spec_function (e); } else { if (e->value.function.isym && e->value.function.isym->inquiry) - t = SUCCESS; + t = true; else t = check_arglist (e->value.function.actual, &check_restricted); - if (t == SUCCESS) + if (t) t = restricted_intrinsic (e); } break; case EXPR_VARIABLE: sym = e->symtree->n.sym; - t = FAILURE; + t = false; /* If a dummy argument appears in a context that is valid for a restricted expression in an elemental procedure, it will have @@ -2895,7 +2892,7 @@ check_restricted (gfc_expr *e) } /* Check reference chain if any. */ - if (check_references (e->ref, &check_restricted) == FAILURE) + if (!check_references (e->ref, &check_restricted)) break; /* gfc_is_formal_arg broadcasts that a formal argument list is being @@ -2916,7 +2913,7 @@ check_restricted (gfc_expr *e) && sym->ns->proc_name->attr.flavor == FL_MODULE) || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) { - t = SUCCESS; + t = true; break; } @@ -2928,16 +2925,16 @@ check_restricted (gfc_expr *e) case EXPR_NULL: case EXPR_CONSTANT: - t = SUCCESS; + t = true; break; case EXPR_SUBSTRING: t = gfc_specification_expr (e->ref->u.ss.start); - if (t == FAILURE) + if (!t) break; t = gfc_specification_expr (e->ref->u.ss.end); - if (t == SUCCESS) + if (t) t = gfc_simplify_expr (e, 0); break; @@ -2959,21 +2956,21 @@ check_restricted (gfc_expr *e) /* Check to see that an expression is a specification expression. If - we return FAILURE, an error has been generated. */ + we return false, an error has been generated. */ -gfc_try +bool gfc_specification_expr (gfc_expr *e) { gfc_component *comp; if (e == NULL) - return SUCCESS; + return true; if (e->ts.type != BT_INTEGER) { gfc_error ("Expression at %L must be of INTEGER type, found %s", &e->where, gfc_basic_typename (e->ts.type)); - return FAILURE; + return false; } comp = gfc_get_proc_ptr_comp (e); @@ -2987,17 +2984,17 @@ gfc_specification_expr (gfc_expr *e) e->symtree->n.sym->name, &e->where); /* Prevent repeat error messages. */ e->symtree->n.sym->attr.pure = 1; - return FAILURE; + return false; } if (e->rank != 0) { gfc_error ("Expression at %L must be scalar", &e->where); - return FAILURE; + return false; } - if (gfc_simplify_expr (e, 0) == FAILURE) - return FAILURE; + if (!gfc_simplify_expr (e, 0)) + return false; return check_restricted (e); } @@ -3007,18 +3004,18 @@ gfc_specification_expr (gfc_expr *e) /* Given two expressions, make sure that the arrays are conformable. */ -gfc_try +bool gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) { int op1_flag, op2_flag, d; mpz_t op1_size, op2_size; - gfc_try t; + bool t; va_list argp; char buffer[240]; if (op1->rank == 0 || op2->rank == 0) - return SUCCESS; + return true; va_start (argp, optype_msgid); vsnprintf (buffer, 240, optype_msgid, argp); @@ -3028,15 +3025,15 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, . { gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), op1->rank, op2->rank, &op1->where); - return FAILURE; + return false; } - t = SUCCESS; + t = true; for (d = 0; d < op1->rank; d++) { - op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS; - op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS; + op1_flag = gfc_array_dimen_size(op1, d, &op1_size); + op2_flag = gfc_array_dimen_size(op2, d, &op2_size); if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) { @@ -3045,7 +3042,7 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, . (int) mpz_get_si (op1_size), (int) mpz_get_si (op2_size)); - t = FAILURE; + t = false; } if (op1_flag) @@ -3053,18 +3050,18 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, . if (op2_flag) mpz_clear (op2_size); - if (t == FAILURE) - return FAILURE; + if (!t) + return false; } - return SUCCESS; + return true; } /* Given an assignable expression and an arbitrary expression, make sure that the assignment can take place. */ -gfc_try +bool gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) { gfc_symbol *sym; @@ -3130,7 +3127,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) if (bad_proc) { gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where); - return FAILURE; + return false; } } @@ -3138,26 +3135,26 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) { gfc_error ("Incompatible ranks %d and %d in assignment at %L", lvalue->rank, rvalue->rank, &lvalue->where); - return FAILURE; + return false; } if (lvalue->ts.type == BT_UNKNOWN) { gfc_error ("Variable type is UNKNOWN in assignment at %L", &lvalue->where); - return FAILURE; + return false; } if (rvalue->expr_type == EXPR_NULL) { if (has_pointer && (ref == NULL || ref->next == NULL) && lvalue->symtree->n.sym->attr.data) - return SUCCESS; + return true; else { gfc_error ("NULL appears on right-hand side in assignment at %L", &rvalue->where); - return FAILURE; + return false; } } @@ -3169,21 +3166,20 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) /* Check size of array assignments. */ if (lvalue->rank != 0 && rvalue->rank != 0 - && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS) - return FAILURE; + && !gfc_check_conformance (lvalue, rvalue, "array assignment")) + return false; if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER && lvalue->symtree->n.sym->attr.data - && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " - "initialize non-integer variable '%s'", - &rvalue->where, lvalue->symtree->n.sym->name) - == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " + "initialize non-integer variable '%s'", + &rvalue->where, lvalue->symtree->n.sym->name)) + return false; else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data - && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " - "a DATA statement and outside INT/REAL/DBLE/CMPLX", - &rvalue->where) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " + "a DATA statement and outside INT/REAL/DBLE/CMPLX", + &rvalue->where)) + return false; /* Handle the case of a BOZ literal on the RHS. */ if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER) @@ -3194,7 +3190,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) "non-integer symbol '%s'", &rvalue->where, lvalue->symtree->n.sym->name); if (!gfc_convert_boz (rvalue, &lvalue->ts)) - return FAILURE; + return false; if ((rc = gfc_range_check (rvalue)) != ARITH_OK) { if (rc == ARITH_UNDERFLOW) @@ -3209,7 +3205,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L" ". This check can be disabled with the option " "-fno-range-check", &rvalue->where); - return FAILURE; + return false; } } @@ -3261,7 +3257,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) } if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) - return SUCCESS; + return true; /* Only DATA Statements come here. */ if (!conform) @@ -3270,16 +3266,16 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) converted to any other type. */ if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) || rvalue->ts.type == BT_HOLLERITH) - return SUCCESS; + return true; if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) - return SUCCESS; + return true; gfc_error ("Incompatible types in DATA statement at %L; attempted " "conversion of %s to %s", &lvalue->where, gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); - return FAILURE; + return false; } /* Assignment is the only case where character variables of different @@ -3289,7 +3285,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) if (lvalue->ts.kind != rvalue->ts.kind) gfc_convert_chartype (rvalue, &lvalue->ts); - return SUCCESS; + return true; } return gfc_convert_type (rvalue, &lvalue->ts, 1); @@ -3300,7 +3296,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) we only check rvalue if it's not an assignment to NULL() or a NULLIFY statement. */ -gfc_try +bool gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { symbol_attribute attr, lhs_attr; @@ -3313,7 +3309,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Pointer assignment target is not a POINTER at %L", &lvalue->where); - return FAILURE; + return false; } if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc @@ -3322,7 +3318,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) gfc_error ("'%s' in the pointer assignment at %L cannot be an " "l-value since it is a procedure", lvalue->symtree->n.sym->name, &lvalue->where); - return FAILURE; + return false; } proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; @@ -3344,14 +3340,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Expected bounds specification for '%s' at %L", lvalue->symtree->n.sym->name, &lvalue->where); - return FAILURE; + return false; } - if (gfc_notify_std (GFC_STD_F2003,"Bounds " - "specification for '%s' in pointer assignment " - "at %L", lvalue->symtree->n.sym->name, - &lvalue->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " + "for '%s' in pointer assignment at %L", + lvalue->symtree->n.sym->name, &lvalue->where)) + return false; /* When bounds are given, all lbounds are necessary and either all or none of the upper bounds; no strides are allowed. If the @@ -3363,13 +3358,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Lower bound has to be present at %L", &lvalue->where); - return FAILURE; + return false; } if (ref->u.ar.stride[dim]) { gfc_error ("Stride must not be present at %L", &lvalue->where); - return FAILURE; + return false; } if (dim == 0) @@ -3381,7 +3376,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Either all or none of the upper bounds" " must be specified at %L", &lvalue->where); - return FAILURE; + return false; } } } @@ -3395,7 +3390,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) kind, etc for lvalue and rvalue must match, and rvalue must be a pure variable if we're in a pure function. */ if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) - return SUCCESS; + return true; /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ if (lvalue->expr_type == EXPR_VARIABLE @@ -3407,7 +3402,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Pointer object at %L shall not have a coindex", &lvalue->where); - return FAILURE; + return false; } } @@ -3428,7 +3423,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Invalid procedure pointer assignment at %L", &rvalue->where); - return FAILURE; + return false; } if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) { @@ -3453,7 +3448,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) gfc_error ("Function result '%s' is invalid as proc-target " "in procedure pointer assignment at %L", sym->name, &rvalue->where); - return FAILURE; + return false; } } } @@ -3462,7 +3457,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) gfc_error ("Abstract interface '%s' is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); - return FAILURE; + return false; } /* Check for F08:C729. */ if (attr.flavor == FL_PROCEDURE) @@ -3472,20 +3467,19 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) gfc_error ("Statement function '%s' is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); - return FAILURE; + return false; } if (attr.proc == PROC_INTERNAL && - gfc_notify_std (GFC_STD_F2008, "Internal procedure " - "'%s' is invalid in procedure pointer assignment " - "at %L", rvalue->symtree->name, &rvalue->where) - == FAILURE) - return FAILURE; + !gfc_notify_std(GFC_STD_F2008, "Internal procedure '%s' " + "is invalid in procedure pointer assignment " + "at %L", rvalue->symtree->name, &rvalue->where)) + return false; if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, attr.subroutine) == 0) { gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer " "assignment", rvalue->symtree->name, &rvalue->where); - return FAILURE; + return false; } } /* Check for F08:C730. */ @@ -3494,7 +3488,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) gfc_error ("Nonintrinsic elemental procedure '%s' is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); - return FAILURE; + return false; } /* Ensure that the calling convention is the same. As other attributes @@ -3517,7 +3511,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) gfc_error ("Mismatch in the procedure pointer assignment " "at %L: mismatch in the calling convention", &rvalue->where); - return FAILURE; + return false; } } @@ -3560,14 +3554,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) s2 = s2->ts.interface; if (s1 == s2 || !s1 || !s2) - return SUCCESS; + return true; if (!gfc_compare_interfaces (s1, s2, name, 0, 1, err, sizeof(err), NULL, NULL)) { gfc_error ("Interface mismatch in procedure pointer assignment " "at %L: %s", &rvalue->where, err); - return FAILURE; + return false; } if (!gfc_compare_interfaces (s2, s1, name, 0, 1, @@ -3575,10 +3569,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Interface mismatch in procedure pointer assignment " "at %L: %s", &rvalue->where, err); - return FAILURE; + return false; } - return SUCCESS; + return true; } if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) @@ -3599,20 +3593,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) "attempted assignment of %s to %s", &lvalue->where, gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); - return FAILURE; + return false; } if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) { gfc_error ("Different kind type parameters in pointer " "assignment at %L", &lvalue->where); - return FAILURE; + return false; } if (lvalue->rank != rvalue->rank && !rank_remap) { gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); - return FAILURE; + return false; } /* Make sure the vtab is present. */ @@ -3628,15 +3622,15 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) /* If this can be determined, check that the target must be at least as large as the pointer assigned to it is. */ - if (gfc_array_size (lvalue, &lsize) == SUCCESS - && gfc_array_size (rvalue, &rsize) == SUCCESS + if (gfc_array_size (lvalue, &lsize) + && gfc_array_size (rvalue, &rsize) && mpz_cmp (rsize, lsize) < 0) { gfc_error ("Rank remapping target is smaller than size of the" " pointer (%ld < %ld) at %L", mpz_get_si (rsize), mpz_get_si (lsize), &lvalue->where); - return FAILURE; + return false; } /* The target must be either rank one or it must be simply contiguous @@ -3647,24 +3641,23 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Rank remapping target must be rank 1 or" " simply contiguous at %L", &rvalue->where); - return FAILURE; + return false; } - if (gfc_notify_std (GFC_STD_F2008, "Rank remapping" - " target is not rank 1 at %L", &rvalue->where) - == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " + "rank 1 at %L", &rvalue->where)) + return false; } } /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ if (rvalue->expr_type == EXPR_NULL) - return SUCCESS; + return true; if (lvalue->ts.type == BT_CHARACTER) { - gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); - if (t == FAILURE) - return FAILURE; + bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); + if (!t) + return false; } if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) @@ -3677,14 +3670,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) gfc_error ("Target expression in pointer assignment " "at %L must deliver a pointer result", &rvalue->where); - return FAILURE; + return false; } if (!attr.target && !attr.pointer) { gfc_error ("Pointer assignment target is neither TARGET " "nor POINTER at %L", &rvalue->where); - return FAILURE; + return false; } if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) @@ -3701,7 +3694,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Pointer assignment with vector subscript " "on rhs at %L", &rvalue->where); - return FAILURE; + return false; } if (attr.is_protected && attr.use_assoc @@ -3709,7 +3702,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Pointer assignment target has PROTECTED " "attribute at %L", &rvalue->where); - return FAILURE; + return false; } /* F2008, C725. For PURE also C1283. */ @@ -3722,7 +3715,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { gfc_error ("Data target at %L shall not have a coindex", &rvalue->where); - return FAILURE; + return false; } } @@ -3761,18 +3754,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) "pointer target", &lvalue->where); } - return SUCCESS; + return true; } /* Relative of gfc_check_assign() except that the lvalue is a single symbol. Used for initialization assignments. */ -gfc_try +bool gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) { gfc_expr lvalue; - gfc_try r; + bool r; bool pointer, proc_pointer; memset (&lvalue, '\0', sizeof (gfc_expr)); @@ -3812,7 +3805,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) free (lvalue.symtree); - if (r == FAILURE) + if (!r) return r; if (pointer && rvalue->expr_type != EXPR_NULL) @@ -3824,13 +3817,13 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) { gfc_error ("Pointer initialization target at %L " "must not be ALLOCATABLE", &rvalue->where); - return FAILURE; + return false; } if (!attr.target || attr.pointer) { gfc_error ("Pointer initialization target at %L " "must have the TARGET attribute", &rvalue->where); - return FAILURE; + return false; } if (!attr.save && rvalue->expr_type == EXPR_VARIABLE @@ -3845,7 +3838,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) { gfc_error ("Pointer initialization target at %L " "must have the SAVE attribute", &rvalue->where); - return FAILURE; + return false; } } @@ -3857,11 +3850,11 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) { gfc_error ("Procedure pointer initialization target at %L " "may not be a procedure pointer", &rvalue->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } @@ -4275,7 +4268,7 @@ static bool expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, int* f ATTRIBUTE_UNUSED) { - gfc_try t; + bool t; if (e->expr_type != EXPR_VARIABLE) return false; @@ -4284,10 +4277,10 @@ expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, true, e->where); - return (t == FAILURE); + return (!t); } -gfc_try +bool gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) { bool error_found; @@ -4301,12 +4294,12 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) if (e->expr_type == EXPR_OP) { - gfc_try t = SUCCESS; + bool t = true; gcc_assert (e->value.op.op1); t = gfc_expr_check_typed (e->value.op.op1, ns, strict); - if (t == SUCCESS && e->value.op.op2) + if (t && e->value.op.op2) t = gfc_expr_check_typed (e->value.op.op2, ns, strict); return t; @@ -4317,7 +4310,7 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) check_typed_ns = ns; error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); - return error_found ? FAILURE : SUCCESS; + return error_found ? false : true; } @@ -4676,9 +4669,9 @@ gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, variables), some checks are not performed. Optionally, a possible error message can be suppressed if context is NULL - and just the return status (SUCCESS / FAILURE) be requested. */ + and just the return status (true / false) be requested. */ -gfc_try +bool gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, bool own_scope, const char* context) { @@ -4711,7 +4704,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (context) gfc_error ("Fortran 2008: Pointer functions in variable definition" " context (%s) at %L", context, &e->where); - return FAILURE; + return false; } } else if (e->expr_type != EXPR_VARIABLE) @@ -4719,7 +4712,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (context) gfc_error ("Non-variable expression in variable definition context (%s)" " at %L", context, &e->where); - return FAILURE; + return false; } if (!pointer && sym->attr.flavor == FL_PARAMETER) @@ -4727,7 +4720,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (context) gfc_error ("Named constant '%s' in variable definition context (%s)" " at %L", sym->name, context, &e->where); - return FAILURE; + return false; } if (!pointer && sym->attr.flavor != FL_VARIABLE && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) @@ -4736,7 +4729,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (context) gfc_error ("'%s' in variable definition context (%s) at %L is not" " a variable", sym->name, context, &e->where); - return FAILURE; + return false; } /* Find out whether the expr is a pointer; this also means following @@ -4747,7 +4740,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (context) gfc_error ("Non-POINTER in pointer association context (%s)" " at %L", context, &e->where); - return FAILURE; + return false; } /* F2008, C1303. */ @@ -4760,7 +4753,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (context) gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", context, &e->where); - return FAILURE; + return false; } /* INTENT(IN) dummy argument. Check this, unless the object itself is the @@ -4790,7 +4783,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer" " association context (%s) at %L", sym->name, context, &e->where); - return FAILURE; + return false; } if (!pointer && !is_pointer && !sym->attr.pointer) { @@ -4798,7 +4791,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, gfc_error ("Dummy argument '%s' with INTENT(IN) in variable" " definition context (%s) at %L", sym->name, context, &e->where); - return FAILURE; + return false; } } @@ -4811,7 +4804,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, gfc_error ("Variable '%s' is PROTECTED and can not appear in a" " pointer association context (%s) at %L", sym->name, context, &e->where); - return FAILURE; + return false; } if (!pointer && !is_pointer) { @@ -4819,7 +4812,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, gfc_error ("Variable '%s' is PROTECTED and can not appear in a" " variable definition context (%s) at %L", sym->name, context, &e->where); - return FAILURE; + return false; } } @@ -4831,7 +4824,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, gfc_error ("Variable '%s' can not appear in a variable definition" " context (%s) at %L in PURE procedure", sym->name, context, &e->where); - return FAILURE; + return false; } if (!pointer && context && gfc_implicit_pure (NULL) @@ -4895,12 +4888,11 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, " not be used in a variable definition context (%s)", name, &e->where, context); } - return FAILURE; + return false; } /* Target must be allowed to appear in a variable definition context. */ - if (gfc_check_vardef_context (assoc->target, pointer, false, false, NULL) - == FAILURE) + if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) { if (context) gfc_error ("Associate-name '%s' can not appear in a variable" @@ -4908,9 +4900,9 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, " at %L can not, either", name, context, &e->where, &assoc->target->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } |