diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 2020 |
1 files changed, 998 insertions, 1022 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 835b57f4996..684d2058b2d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -114,7 +114,7 @@ is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) an ABSTRACT derived-type. If where is not NULL, an error message with that locus is printed, optionally using name. */ -static gfc_try +static bool resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) { if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract) @@ -129,14 +129,14 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) ts->u.derived->name, where); } - return FAILURE; + return false; } - return SUCCESS; + return true; } -static gfc_try +static bool check_proc_interface (gfc_symbol *ifc, locus *where) { /* Several checks for F08:C1216. */ @@ -144,7 +144,7 @@ check_proc_interface (gfc_symbol *ifc, locus *where) { gfc_error ("Interface '%s' at %L is declared " "in a later PROCEDURE statement", ifc->name, where); - return FAILURE; + return false; } if (ifc->generic) { @@ -157,14 +157,14 @@ check_proc_interface (gfc_symbol *ifc, locus *where) { gfc_error ("Interface '%s' at %L may not be generic", ifc->name, where); - return FAILURE; + return false; } } if (ifc->attr.proc == PROC_ST_FUNCTION) { gfc_error ("Interface '%s' at %L may not be a statement function", ifc->name, where); - return FAILURE; + return false; } if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) || gfc_is_intrinsic (ifc, 1, ifc->declared_at)) @@ -173,14 +173,14 @@ check_proc_interface (gfc_symbol *ifc, locus *where) { gfc_error ("Intrinsic procedure '%s' not allowed in " "PROCEDURE statement at %L", ifc->name, where); - return FAILURE; + return false; } if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') { gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -189,22 +189,22 @@ static void resolve_symbol (gfc_symbol *sym); /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ -static gfc_try +static bool resolve_procedure_interface (gfc_symbol *sym) { gfc_symbol *ifc = sym->ts.interface; if (!ifc) - return SUCCESS; + return true; if (ifc == sym) { gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface", sym->name, &sym->declared_at); - return FAILURE; + return false; } - if (check_proc_interface (ifc, &sym->declared_at) == FAILURE) - return FAILURE; + if (!check_proc_interface (ifc, &sym->declared_at)) + return false; if (ifc->attr.if_source || ifc->attr.intrinsic) { @@ -242,12 +242,12 @@ resolve_procedure_interface (gfc_symbol *sym) { sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved - && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE) - return FAILURE; + && !gfc_resolve_expr (sym->ts.u.cl->length)) + return false; } } - return SUCCESS; + return true; } @@ -303,7 +303,7 @@ resolve_formal_arglist (gfc_symbol *proc) continue; } else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL - && resolve_procedure_interface (sym) == FAILURE) + && !resolve_procedure_interface (sym)) return; if (sym->attr.if_source != IFSRC_UNKNOWN) @@ -412,7 +412,7 @@ resolve_formal_arglist (gfc_symbol *proc) { if (sym->attr.flavor == FL_PROCEDURE) { - if (!gfc_pure(sym)) + if (!gfc_pure (sym)) proc->attr.implicit_pure = 0; } else if (!sym->attr.pointer) @@ -543,7 +543,7 @@ resolve_formal_arglists (gfc_namespace *ns) static void resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) { - gfc_try t; + bool t; /* If this namespace is not a function or an entry master function, ignore it. */ @@ -556,7 +556,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) { t = gfc_set_default_type (sym->result, 0, ns); - if (t == FAILURE && !sym->result->attr.untyped) + if (!t && !sym->result->attr.untyped) { if (sym->result == sym) gfc_error ("Contained function '%s' at %L has no IMPLICIT type", @@ -1016,22 +1016,22 @@ resolve_contained_functions (gfc_namespace *ns) } -static gfc_try resolve_fl_derived0 (gfc_symbol *sym); +static bool resolve_fl_derived0 (gfc_symbol *sym); /* Resolve all of the elements of a structure constructor and make sure that the types are correct. The 'init' flag indicates that the given constructor is an initializer. */ -static gfc_try +static bool resolve_structure_cons (gfc_expr *expr, int init) { gfc_constructor *cons; gfc_component *comp; - gfc_try t; + bool t; symbol_attribute a; - t = SUCCESS; + t = true; if (expr->ts.type == BT_DERIVED) resolve_fl_derived0 (expr->ts.u.derived); @@ -1053,9 +1053,9 @@ resolve_structure_cons (gfc_expr *expr, int init) if (!cons->expr) continue; - if (gfc_resolve_expr (cons->expr) == FAILURE) + if (!gfc_resolve_expr (cons->expr)) { - t = FAILURE; + t = false; continue; } @@ -1067,7 +1067,7 @@ resolve_structure_cons (gfc_expr *expr, int init) "constructor at %L does not match that of the " "component (%d/%d)", &cons->expr->where, cons->expr->rank, rank); - t = FAILURE; + t = false; } /* If we don't have the right type, try to convert it. */ @@ -1089,12 +1089,12 @@ resolve_structure_cons (gfc_expr *expr, int init) &cons->expr->where, comp->name, gfc_basic_typename (cons->expr->ts.type), gfc_basic_typename (comp->ts.type)); - t = FAILURE; + t = false; } else { - gfc_try t2 = gfc_convert_type (cons->expr, &comp->ts, 1); - if (t != FAILURE) + bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); + if (t) t = t2; } } @@ -1168,7 +1168,7 @@ resolve_structure_cons (gfc_expr *expr, int init) && (CLASS_DATA (comp)->attr.class_pointer || CLASS_DATA (comp)->attr.allocatable)))) { - t = FAILURE; + t = false; gfc_error ("The NULL in the structure constructor at %L is " "being applied to component '%s', which is neither " "a POINTER nor ALLOCATABLE", &cons->expr->where, @@ -1206,7 +1206,7 @@ resolve_structure_cons (gfc_expr *expr, int init) gfc_error ("Interface mismatch for procedure-pointer component " "'%s' in structure constructor at %L: %s", comp->name, &cons->expr->where, err); - return FAILURE; + return false; } } @@ -1218,7 +1218,7 @@ resolve_structure_cons (gfc_expr *expr, int init) if (!a.pointer && !a.target) { - t = FAILURE; + t = false; gfc_error ("The element in the structure constructor at %L, " "for pointer component '%s' should be a POINTER or " "a TARGET", &cons->expr->where, comp->name); @@ -1229,13 +1229,13 @@ resolve_structure_cons (gfc_expr *expr, int init) /* F08:C461. Additional checks for pointer initialization. */ if (a.allocatable) { - t = FAILURE; + t = false; gfc_error ("Pointer initialization target at %L " "must not be ALLOCATABLE ", &cons->expr->where); } if (!a.save) { - t = FAILURE; + t = false; gfc_error ("Pointer initialization target at %L " "must have the SAVE attribute", &cons->expr->where); } @@ -1246,7 +1246,7 @@ resolve_structure_cons (gfc_expr *expr, int init) && (gfc_impure_variable (cons->expr->symtree->n.sym) || gfc_is_coindexed (cons->expr))) { - t = FAILURE; + t = false; gfc_error ("Invalid expression in the structure constructor for " "pointer component '%s' at %L in PURE procedure", comp->name, &cons->expr->where); @@ -1527,18 +1527,18 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) /* Resolve an intrinsic procedure: Set its function/subroutine attribute, its typespec and formal argument list. */ -gfc_try +bool gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) { gfc_intrinsic_sym* isym = NULL; const char* symstd; if (sym->formal) - return SUCCESS; + return true; /* Already resolved. */ if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) - return SUCCESS; + return true; /* We already know this one is an intrinsic, so we don't call gfc_is_intrinsic for full checking but rather use gfc_find_function and @@ -1566,8 +1566,8 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) " ignored", sym->name, &sym->declared_at); if (!sym->attr.function && - gfc_add_function (&sym->attr, sym->name, loc) == FAILURE) - return FAILURE; + !gfc_add_function(&sym->attr, sym->name, loc)) + return false; sym->ts = isym->ts; } @@ -1577,48 +1577,47 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) { gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type" " specifier", sym->name, &sym->declared_at); - return FAILURE; + return false; } if (!sym->attr.subroutine && - gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE) - return FAILURE; + !gfc_add_subroutine(&sym->attr, sym->name, loc)) + return false; } else { gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name, &sym->declared_at); - return FAILURE; + return false; } gfc_copy_formal_args_intr (sym, isym); /* Check it is actually available in the standard settings. */ - if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at) - == FAILURE) + if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) { gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not" " available in the current standard settings but %s. Use" " an appropriate -std=* option or enable -fall-intrinsics" " in order to use it.", sym->name, &sym->declared_at, symstd); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Resolve a procedure expression, like passing it to a called procedure or as RHS for a procedure pointer assignment. */ -static gfc_try +static bool resolve_procedure_expression (gfc_expr* expr) { gfc_symbol* sym; if (expr->expr_type != EXPR_VARIABLE) - return SUCCESS; + return true; gcc_assert (expr->symtree); sym = expr->symtree->n.sym; @@ -1628,7 +1627,7 @@ resolve_procedure_expression (gfc_expr* expr) if (sym->attr.flavor != FL_PROCEDURE || (sym->attr.function && sym->result == sym)) - return SUCCESS; + return true; /* A non-RECURSIVE procedure that is used as procedure expression within its own body is in danger of being called recursively. */ @@ -1637,7 +1636,7 @@ resolve_procedure_expression (gfc_expr* expr) " itself recursively. Declare it RECURSIVE or use" " -frecursive", sym->name, &expr->where); - return SUCCESS; + return true; } @@ -1647,7 +1646,7 @@ resolve_procedure_expression (gfc_expr* expr) that look like procedure arguments are really simple variable references. */ -static gfc_try +static bool resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, bool no_formal_args) { @@ -1655,7 +1654,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_symtree *parent_st; gfc_expr *e; int save_need_full_assumed_size; - gfc_try return_value = FAILURE; + bool return_value = false; bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; actual_arg = true; @@ -1691,7 +1690,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, save_need_full_assumed_size = need_full_assumed_size; if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; - if (gfc_resolve_expr (e) != SUCCESS) + if (!gfc_resolve_expr (e)) goto cleanup; need_full_assumed_size = save_need_full_assumed_size; goto argument_list; @@ -1729,10 +1728,9 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (sym->attr.contained && !sym->attr.use_assoc && sym->ns->proc_name->attr.flavor != FL_MODULE) { - if (gfc_notify_std (GFC_STD_F2008, - "Internal procedure '%s' is" - " used as actual argument at %L", - sym->name, &e->where) == FAILURE) + if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is" + " used as actual argument at %L", + sym->name, &e->where)) goto cleanup; } @@ -1775,7 +1773,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, sym->attr.function = 1; } - if (gfc_resolve_expr (e) == FAILURE) + if (!gfc_resolve_expr (e)) goto cleanup; goto argument_list; } @@ -1801,7 +1799,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, || sym->attr.intrinsic || sym->attr.external) { - if (gfc_resolve_expr (e) == FAILURE) + if (!gfc_resolve_expr (e)) goto cleanup; goto argument_list; } @@ -1829,7 +1827,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, save_need_full_assumed_size = need_full_assumed_size; if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; - if (gfc_resolve_expr (e) != SUCCESS) + if (!gfc_resolve_expr (e)) goto cleanup; need_full_assumed_size = save_need_full_assumed_size; @@ -1894,7 +1892,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, first_actual_arg = false; } - return_value = SUCCESS; + return_value = true; cleanup: actual_arg = actual_arg_sav; @@ -1908,7 +1906,7 @@ cleanup: procedures. If called with c == NULL, we have a function, otherwise if expr == NULL, we have a subroutine. */ -static gfc_try +static bool resolve_elemental_actual (gfc_expr *expr, gfc_code *c) { gfc_actual_arglist *arg0; @@ -1939,7 +1937,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) isym = expr->value.function.isym; } else - return SUCCESS; + return true; } else if (c && c->ext.actual != NULL) { @@ -1952,10 +1950,10 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) gcc_assert (esym); if (!esym->attr.elemental) - return SUCCESS; + return true; } else - return SUCCESS; + return true; /* The rank of an elemental is the rank of its array argument(s). */ for (arg = arg0; arg; arg = arg->next) @@ -2033,14 +2031,13 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) /* Being elemental, the last upper bound of an assumed size array argument must be present. */ if (resolve_assumed_size_actual (arg->expr)) - return FAILURE; + return false; /* Elemental procedure's array actual arguments must conform. */ if (e != NULL) { - if (gfc_check_conformance (arg->expr, e, - "elemental procedure") == FAILURE) - return FAILURE; + if (!gfc_check_conformance (arg->expr, e, "elemental procedure")) + return false; } else e = arg->expr; @@ -2060,9 +2057,9 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) "actual argument is an array", &arg->expr->where, (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" : "INOUT", eformal->sym->name, esym->name); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -2121,6 +2118,126 @@ not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) return true; } + +/* Check for the requirement of an explicit interface. F08:12.4.2.2. */ + +bool +gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) +{ + gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym); + + for ( ; arg; arg = arg->next) + { + if (!arg->sym) + continue; + + if (arg->sym->attr.allocatable) /* (2a) */ + { + strncpy (errmsg, _("allocatable argument"), err_len); + return true; + } + else if (arg->sym->attr.asynchronous) + { + strncpy (errmsg, _("asynchronous argument"), err_len); + return true; + } + else if (arg->sym->attr.optional) + { + strncpy (errmsg, _("optional argument"), err_len); + return true; + } + else if (arg->sym->attr.pointer) + { + strncpy (errmsg, _("pointer argument"), err_len); + return true; + } + else if (arg->sym->attr.target) + { + strncpy (errmsg, _("target argument"), err_len); + return true; + } + else if (arg->sym->attr.value) + { + strncpy (errmsg, _("value argument"), err_len); + return true; + } + else if (arg->sym->attr.volatile_) + { + strncpy (errmsg, _("volatile argument"), err_len); + return true; + } + else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */ + { + strncpy (errmsg, _("assumed-shape argument"), err_len); + return true; + } + else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */ + { + strncpy (errmsg, _("assumed-rank argument"), err_len); + return true; + } + else if (arg->sym->attr.codimension) /* (2c) */ + { + strncpy (errmsg, _("coarray argument"), err_len); + return true; + } + else if (false) /* (2d) TODO: parametrized derived type */ + { + strncpy (errmsg, _("parametrized derived type argument"), err_len); + return true; + } + else if (arg->sym->ts.type == BT_CLASS) /* (2e) */ + { + strncpy (errmsg, _("polymorphic argument"), err_len); + return true; + } + else if (arg->sym->ts.type == BT_ASSUMED) + { + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + strncpy (errmsg, _("assumed-type argument"), err_len); + return true; + } + } + + if (sym->attr.function) + { + gfc_symbol *res = sym->result ? sym->result : sym; + + if (res->attr.dimension) /* (3a) */ + { + strncpy (errmsg, _("array result"), err_len); + return true; + } + else if (res->attr.pointer || res->attr.allocatable) /* (3b) */ + { + strncpy (errmsg, _("pointer or allocatable result"), err_len); + return true; + } + else if (res->ts.type == BT_CHARACTER && res->ts.u.cl + && res->ts.u.cl->length + && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */ + { + strncpy (errmsg, _("result with non-constant character length"), err_len); + return true; + } + } + + if (sym->attr.elemental) /* (4) */ + { + strncpy (errmsg, _("elemental procedure"), err_len); + return true; + } + else if (sym->attr.is_bind_c) /* (5) */ + { + strncpy (errmsg, _("bind(c) procedure"), err_len); + return true; + } + + return false; +} + + static void resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_actual_arglist **actual, int sub) @@ -2128,6 +2245,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_gsymbol * gsym; gfc_namespace *ns; enum gfc_symbol_type type; + char reason[200]; type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; @@ -2198,160 +2316,32 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } } - /* Differences in constant character lengths. */ - if (sym->attr.function && sym->ts.type == BT_CHARACTER) + if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) { - long int l1 = 0, l2 = 0; - gfc_charlen *cl1 = sym->ts.u.cl; - gfc_charlen *cl2 = def_sym->ts.u.cl; - - if (cl1 != NULL - && cl1->length != NULL - && cl1->length->expr_type == EXPR_CONSTANT) - l1 = mpz_get_si (cl1->length->value.integer); - - if (cl2 != NULL - && cl2->length != NULL - && cl2->length->expr_type == EXPR_CONSTANT) - l2 = mpz_get_si (cl2->length->value.integer); - - if (l1 && l2 && l1 != l2) - gfc_error ("Character length mismatch in return type of " - "function '%s' at %L (%ld/%ld)", sym->name, - &sym->declared_at, l1, l2); + gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", + sym->name, &sym->declared_at, gfc_typename (&sym->ts), + gfc_typename (&def_sym->ts)); + goto done; } - /* Type mismatch of function return type and expected type. */ - if (sym->attr.function - && !gfc_compare_types (&sym->ts, &def_sym->ts)) - gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", - sym->name, &sym->declared_at, gfc_typename (&sym->ts), - gfc_typename (&def_sym->ts)); - - if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY) + if (sym->attr.if_source == IFSRC_UNKNOWN + && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) { - gfc_formal_arglist *arg = def_sym->formal; - for ( ; arg; arg = arg->next) - if (!arg->sym) - continue; - /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */ - else if (arg->sym->attr.allocatable - || arg->sym->attr.asynchronous - || arg->sym->attr.optional - || arg->sym->attr.pointer - || arg->sym->attr.target - || arg->sym->attr.value - || arg->sym->attr.volatile_) - { - gfc_error ("Dummy argument '%s' of procedure '%s' at %L " - "has an attribute that requires an explicit " - "interface for this procedure", arg->sym->name, - sym->name, &sym->declared_at); - break; - } - /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */ - else if (arg->sym && arg->sym->as - && arg->sym->as->type == AS_ASSUMED_SHAPE) - { - gfc_error ("Procedure '%s' at %L with assumed-shape dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* TS 29113, 6.2. */ - else if (arg->sym && arg->sym->as - && arg->sym->as->type == AS_ASSUMED_RANK) - { - gfc_error ("Procedure '%s' at %L with assumed-rank dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* F2008, 12.4.2.2 (2c) */ - else if (arg->sym->attr.codimension) - { - gfc_error ("Procedure '%s' at %L with coarray dummy argument " - "'%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */ - else if (false) /* TODO: is a parametrized derived type */ - { - gfc_error ("Procedure '%s' at %L with parametrized derived " - "type argument '%s' must have an explicit " - "interface", sym->name, &sym->declared_at, - arg->sym->name); - break; - } - /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */ - else if (arg->sym->ts.type == BT_CLASS) - { - gfc_error ("Procedure '%s' at %L with polymorphic dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* As assumed-type is unlimited polymorphic (cf. above). - See also TS 29113, Note 6.1. */ - else if (arg->sym->ts.type == BT_ASSUMED) - { - gfc_error ("Procedure '%s' at %L with assumed-type dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - } - - if (def_sym->attr.function) - { - /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */ - if (def_sym->as && def_sym->as->rank - && (!sym->as || sym->as->rank != def_sym->as->rank)) - gfc_error ("The reference to function '%s' at %L either needs an " - "explicit INTERFACE or the rank is incorrect", sym->name, - where); - - /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ - if ((def_sym->result->attr.pointer - || def_sym->result->attr.allocatable) - && (sym->attr.if_source != IFSRC_IFBODY - || def_sym->result->attr.pointer - != sym->result->attr.pointer - || def_sym->result->attr.allocatable - != sym->result->attr.allocatable)) - gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " - "result must have an explicit interface", sym->name, - where); - - /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ - if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY - && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL) - { - gfc_charlen *cl = sym->ts.u.cl; - - if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Nonconstant character-length function '%s' at %L " - "must have an explicit interface", sym->name, - &sym->declared_at); - } - } + gfc_error ("Explicit interface required for '%s' at %L: %s", + sym->name, &sym->declared_at, reason); + goto done; } - /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ - if (def_sym->attr.elemental && !sym->attr.elemental) - { - gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " - "interface", sym->name, &sym->declared_at); - } + if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)) + /* Turn erros into warnings with -std=gnu and -std=legacy. */ + gfc_errors_to_warnings (1); - /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ - if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c) - { - gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " - "an explicit interface", sym->name, &sym->declared_at); + if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, + reason, sizeof(reason), NULL, NULL)) + { + gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ", + sym->name, &sym->declared_at, reason); + goto done; } if (!pedantic @@ -2361,9 +2351,10 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, if (sym->attr.if_source != IFSRC_IFBODY) gfc_procedure_use (def_sym, actual, where); - - gfc_errors_to_warnings (0); } + +done: + gfc_errors_to_warnings (0); if (gsym->type == GSYM_UNKNOWN) { @@ -2419,7 +2410,7 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) } -static gfc_try +static bool resolve_generic_f (gfc_expr *expr) { gfc_symbol *sym; @@ -2432,9 +2423,9 @@ resolve_generic_f (gfc_expr *expr) { m = resolve_generic_f0 (expr, sym); if (m == MATCH_YES) - return SUCCESS; + return true; else if (m == MATCH_ERROR) - return FAILURE; + return false; generic: if (!intr) @@ -2458,27 +2449,27 @@ generic: { gfc_error ("There is no specific function for the generic '%s' " "at %L", expr->symtree->n.sym->name, &expr->where); - return FAILURE; + return false; } if (intr) { - if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL, - false) != SUCCESS) - return FAILURE; + if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, + NULL, false)) + return false; return resolve_structure_cons (expr, 0); } m = gfc_intrinsic_func_interface (expr, 0); if (m == MATCH_YES) - return SUCCESS; + return true; if (m == MATCH_NO) gfc_error ("Generic function '%s' at %L is not consistent with a " "specific intrinsic interface", expr->symtree->n.sym->name, &expr->where); - return FAILURE; + return false; } @@ -2536,7 +2527,7 @@ found: } -static gfc_try +static bool resolve_specific_f (gfc_expr *expr) { gfc_symbol *sym; @@ -2548,9 +2539,9 @@ resolve_specific_f (gfc_expr *expr) { m = resolve_specific_f0 (sym, expr); if (m == MATCH_YES) - return SUCCESS; + return true; if (m == MATCH_ERROR) - return FAILURE; + return false; if (sym->ns->parent == NULL) break; @@ -2564,13 +2555,13 @@ resolve_specific_f (gfc_expr *expr) gfc_error ("Unable to resolve the specific function '%s' at %L", expr->symtree->n.sym->name, &expr->where); - return SUCCESS; + return true; } /* Resolve a procedure call not known to be generic nor specific. */ -static gfc_try +static bool resolve_unknown_f (gfc_expr *expr) { gfc_symbol *sym; @@ -2590,8 +2581,8 @@ resolve_unknown_f (gfc_expr *expr) if (gfc_is_intrinsic (sym, 0, expr->where)) { if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) - return SUCCESS; - return FAILURE; + return true; + return false; } /* The reference is to an external name. */ @@ -2619,13 +2610,13 @@ set_type: { gfc_error ("Function '%s' at %L has no IMPLICIT type", sym->name, &expr->where); - return FAILURE; + return false; } else expr->ts = *ts; } - return SUCCESS; + return true; } @@ -2713,13 +2704,13 @@ pure_stmt_function (gfc_expr *e, gfc_symbol *sym) /* Resolve a function call, which means resolving the arguments, then figuring out which entity the name refers to. */ -static gfc_try +static bool resolve_function (gfc_expr *expr) { gfc_actual_arglist *arg; gfc_symbol *sym; const char *name; - gfc_try t; + bool t; int temp; procedure_type p = PROC_INTRINSIC; bool no_formal_args; @@ -2730,16 +2721,16 @@ resolve_function (gfc_expr *expr) /* If this is a procedure pointer component, it has already been resolved. */ if (gfc_is_proc_ptr_comp (expr)) - return SUCCESS; + return true; if (sym && sym->attr.intrinsic - && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE) - return FAILURE; + && !gfc_resolve_intrinsic (sym, &expr->where)) + return false; if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) { gfc_error ("'%s' at %L is not a function", sym->name, &expr->where); - return FAILURE; + return false; } /* If this ia a deferred TBP with an abstract interface (which may @@ -2748,7 +2739,7 @@ resolve_function (gfc_expr *expr) { gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", sym->name, &expr->where); - return FAILURE; + return false; } /* Switch off assumed size checking and do this again for certain kinds @@ -2763,11 +2754,11 @@ resolve_function (gfc_expr *expr) no_formal_args = sym && is_external_proc (sym) && gfc_sym_get_dummy_args (sym) == NULL; - if (resolve_actual_arglist (expr->value.function.actual, - p, no_formal_args) == FAILURE) + if (!resolve_actual_arglist (expr->value.function.actual, + p, no_formal_args)) { inquiry_argument = false; - return FAILURE; + return false; } inquiry_argument = false; @@ -2792,7 +2783,7 @@ resolve_function (gfc_expr *expr) gfc_error ("Function '%s' is declared CHARACTER(*) and cannot " "be used at %L since it is not a dummy argument", sym->name, &expr->where); - return FAILURE; + return false; } /* See if function is already resolved. */ @@ -2801,7 +2792,7 @@ resolve_function (gfc_expr *expr) { if (expr->ts.type == BT_UNKNOWN) expr->ts = sym->ts; - t = SUCCESS; + t = true; } else { @@ -2835,8 +2826,8 @@ resolve_function (gfc_expr *expr) temp = need_full_assumed_size; need_full_assumed_size = 0; - if (resolve_elemental_actual (expr, NULL) == FAILURE) - return FAILURE; + if (!resolve_elemental_actual (expr, NULL)) + return false; if (omp_workshare_flag && expr->value.function.esym @@ -2845,7 +2836,7 @@ resolve_function (gfc_expr *expr) gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed " "in WORKSHARE construct", expr->value.function.esym->name, &expr->where); - t = FAILURE; + t = false; } #define GENERIC_ID expr->value.function.isym->id @@ -2870,7 +2861,7 @@ resolve_function (gfc_expr *expr) if (arg->next->expr->expr_type != EXPR_CONSTANT) break; - if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0) + if (arg->next->name && strncmp (arg->next->name, "kind", 4) == 0) break; if ((int)mpz_get_si (arg->next->expr->value.integer) @@ -2881,7 +2872,7 @@ resolve_function (gfc_expr *expr) if (arg->expr != NULL && arg->expr->rank > 0 && resolve_assumed_size_actual (arg->expr)) - return FAILURE; + return false; } } #undef GENERIC_ID @@ -2896,20 +2887,20 @@ resolve_function (gfc_expr *expr) gfc_error ("Reference to non-PURE function '%s' at %L inside a " "FORALL %s", name, &expr->where, forall_flag == 2 ? "mask" : "block"); - t = FAILURE; + t = false; } else if (do_concurrent_flag) { gfc_error ("Reference to non-PURE function '%s' at %L inside a " "DO CONCURRENT %s", name, &expr->where, do_concurrent_flag == 2 ? "mask" : "block"); - t = FAILURE; + t = false; } else if (gfc_pure (NULL)) { gfc_error ("Function reference to '%s' at %L is to a non-PURE " "procedure within a PURE procedure", name, &expr->where); - t = FAILURE; + t = false; } if (gfc_implicit_pure (NULL)) @@ -2933,7 +2924,7 @@ resolve_function (gfc_expr *expr) gfc_error ("Function '%s' at %L cannot be called recursively, as it" " is not RECURSIVE", esym->name, &expr->where); - t = FAILURE; + t = false; } } @@ -3008,7 +2999,7 @@ resolve_generic_s0 (gfc_code *c, gfc_symbol *sym) } -static gfc_try +static bool resolve_generic_s (gfc_code *c) { gfc_symbol *sym; @@ -3020,9 +3011,9 @@ resolve_generic_s (gfc_code *c) { m = resolve_generic_s0 (c, sym); if (m == MATCH_YES) - return SUCCESS; + return true; else if (m == MATCH_ERROR) - return FAILURE; + return false; generic: if (sym->ns->parent == NULL) @@ -3043,17 +3034,17 @@ generic: { gfc_error ("There is no specific subroutine for the generic '%s' at %L", sym->name, &c->loc); - return FAILURE; + return false; } m = gfc_intrinsic_sub_interface (c, 0); if (m == MATCH_YES) - return SUCCESS; + return true; if (m == MATCH_NO) gfc_error ("Generic subroutine '%s' at %L is not consistent with an " "intrinsic subroutine interface", sym->name, &c->loc); - return FAILURE; + return false; } @@ -3103,7 +3094,7 @@ found: } -static gfc_try +static bool resolve_specific_s (gfc_code *c) { gfc_symbol *sym; @@ -3115,9 +3106,9 @@ resolve_specific_s (gfc_code *c) { m = resolve_specific_s0 (c, sym); if (m == MATCH_YES) - return SUCCESS; + return true; if (m == MATCH_ERROR) - return FAILURE; + return false; if (sym->ns->parent == NULL) break; @@ -3132,13 +3123,13 @@ resolve_specific_s (gfc_code *c) gfc_error ("Unable to resolve the specific subroutine '%s' at %L", sym->name, &c->loc); - return FAILURE; + return false; } /* Resolve a subroutine call not known to be generic nor specific. */ -static gfc_try +static bool resolve_unknown_s (gfc_code *c) { gfc_symbol *sym; @@ -3156,8 +3147,8 @@ resolve_unknown_s (gfc_code *c) if (gfc_is_intrinsic (sym, 1, c->loc)) { if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES) - return SUCCESS; - return FAILURE; + return true; + return false; } /* The reference is to an external name. */ @@ -3169,7 +3160,7 @@ found: pure_subroutine (c, sym); - return SUCCESS; + return true; } @@ -3177,10 +3168,10 @@ found: for functions, subroutines and functions are stored differently and this makes things awkward. */ -static gfc_try +static bool resolve_call (gfc_code *c) { - gfc_try t; + bool t; procedure_type ptype = PROC_INTRINSIC; gfc_symbol *csym, *sym; bool no_formal_args; @@ -3191,7 +3182,7 @@ resolve_call (gfc_code *c) { gfc_error ("'%s' at %L has a type, which is not consistent with " "the CALL at %L", csym->name, &csym->declared_at, &c->loc); - return FAILURE; + return false; } if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) @@ -3220,7 +3211,7 @@ resolve_call (gfc_code *c) { gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", csym->name, &c->loc); - return FAILURE; + return false; } /* Subroutines without the RECURSIVE attribution are not allowed to @@ -3235,7 +3226,7 @@ resolve_call (gfc_code *c) gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, " "as it is not RECURSIVE", csym->name, &c->loc); - t = FAILURE; + t = false; } } @@ -3248,9 +3239,8 @@ resolve_call (gfc_code *c) no_formal_args = csym && is_external_proc (csym) && gfc_sym_get_dummy_args (csym) == NULL; - if (resolve_actual_arglist (c->ext.actual, ptype, - no_formal_args) == FAILURE) - return FAILURE; + if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args)) + return false; /* Resume assumed_size checking. */ need_full_assumed_size--; @@ -3259,7 +3249,7 @@ resolve_call (gfc_code *c) if (csym && is_external_proc (csym)) resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1); - t = SUCCESS; + t = true; if (c->resolved_sym == NULL) { c->resolved_isym = NULL; @@ -3283,26 +3273,26 @@ resolve_call (gfc_code *c) } /* Some checks of elemental subroutine actual arguments. */ - if (resolve_elemental_actual (NULL, c) == FAILURE) - return FAILURE; + if (!resolve_elemental_actual (NULL, c)) + return false; 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 + op1->shape and op2->shape are non-NULL return true if their shapes + match. If both op1->shape and op2->shape are non-NULL return false if their shapes do not match. If either op1->shape or op2->shape is - NULL, return SUCCESS. */ + NULL, return true. */ -static gfc_try +static bool compare_shapes (gfc_expr *op1, gfc_expr *op2) { - gfc_try t; + bool t; int i; - t = SUCCESS; + t = true; if (op1->shape != NULL && op2->shape != NULL) { @@ -3312,7 +3302,7 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2) { gfc_error ("Shapes for operands at %L and %L are not conformable", &op1->where, &op2->where); - t = FAILURE; + t = false; break; } } @@ -3325,21 +3315,21 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2) /* Resolve an operator expression node. This can involve replacing the operation with a user defined function call. */ -static gfc_try +static bool resolve_operator (gfc_expr *e) { gfc_expr *op1, *op2; char msg[200]; bool dual_locus_error; - gfc_try t; + bool t; /* Resolve all subnodes-- give them types. */ switch (e->value.op.op) { default: - if (gfc_resolve_expr (e->value.op.op2) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (e->value.op.op2)) + return false; /* Fall through... */ @@ -3347,8 +3337,8 @@ resolve_operator (gfc_expr *e) case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: case INTRINSIC_PARENTHESES: - if (gfc_resolve_expr (e->value.op.op1) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (e->value.op.op1)) + return false; break; } @@ -3546,7 +3536,7 @@ resolve_operator (gfc_expr *e) /* Deal with arrayness of an operand through an operator. */ - t = SUCCESS; + t = true; switch (e->value.op.op) { @@ -3600,7 +3590,7 @@ resolve_operator (gfc_expr *e) if (e->shape == NULL) { t = compare_shapes (op1, op2); - if (t == FAILURE) + if (!t) e->shape = NULL; else e->shape = gfc_copy_shape (op1->shape, op1->rank); @@ -3638,14 +3628,14 @@ resolve_operator (gfc_expr *e) } /* Attempt to simplify the expression. */ - if (t == SUCCESS) + if (t) { t = gfc_simplify_expr (e, 0); - /* Some calls do not succeed in simplification and return FAILURE + /* Some calls do not succeed in simplification and return false even though there is no error; e.g. variable references to PARAMETER arrays. */ if (!gfc_is_constant_expr (e)) - t = SUCCESS; + t = true; } return t; @@ -3654,9 +3644,9 @@ bad_op: { match m = gfc_extend_expr (e); if (m == MATCH_YES) - return SUCCESS; + return true; if (m == MATCH_ERROR) - return FAILURE; + return false; } if (dual_locus_error) @@ -3664,7 +3654,7 @@ bad_op: else gfc_error (msg, &e->where); - return FAILURE; + return false; } @@ -3766,7 +3756,7 @@ compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end, || (stride != NULL && stride->ts.type != BT_INTEGER)) return 0; - if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ) + if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ) { if (compare_bound (start, end) == CMP_GT) return 0; @@ -3800,7 +3790,7 @@ compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end, /* Compare a single dimension of an array reference to the array specification. */ -static gfc_try +static bool check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) { mpz_t last_value; @@ -3812,7 +3802,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) if (ar->start[i] == NULL) { gcc_assert (ar->end[i] == NULL); - return SUCCESS; + return true; } } @@ -3840,7 +3830,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) mpz_get_si (ar->start[i]->value.integer), mpz_get_si (as->lower[i]->value.integer), i + 1 - as->rank); - return SUCCESS; + return true; } if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) { @@ -3855,7 +3845,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) mpz_get_si (ar->start[i]->value.integer), mpz_get_si (as->upper[i]->value.integer), i + 1 - as->rank); - return SUCCESS; + return true; } break; @@ -3871,7 +3861,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) if (compare_bound_int (ar->stride[i], 0) == CMP_EQ) { gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]); - return FAILURE; + return false; } /* if start == len || (stride > 0 && start < len) @@ -3891,7 +3881,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) "(%ld < %ld) in dimension %d", &ar->c_where[i], mpz_get_si (AR_START->value.integer), mpz_get_si (as->lower[i]->value.integer), i+1); - return SUCCESS; + return true; } if (compare_bound (AR_START, as->upper[i]) == CMP_GT) { @@ -3899,7 +3889,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) "(%ld > %ld) in dimension %d", &ar->c_where[i], mpz_get_si (AR_START->value.integer), mpz_get_si (as->upper[i]->value.integer), i+1); - return SUCCESS; + return true; } } @@ -3916,7 +3906,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) mpz_get_si (last_value), mpz_get_si (as->lower[i]->value.integer), i+1); mpz_clear (last_value); - return SUCCESS; + return true; } if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) { @@ -3925,7 +3915,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) mpz_get_si (last_value), mpz_get_si (as->upper[i]->value.integer), i+1); mpz_clear (last_value); - return SUCCESS; + return true; } } mpz_clear (last_value); @@ -3939,13 +3929,13 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) gfc_internal_error ("check_dimension(): Bad array reference"); } - return SUCCESS; + return true; } /* Compare an array reference with an array specification. */ -static gfc_try +static bool compare_spec_to_ref (gfc_array_ref *ar) { gfc_array_spec *as; @@ -3961,17 +3951,17 @@ compare_spec_to_ref (gfc_array_ref *ar) { gfc_error ("Rightmost upper bound of assumed size array section " "not specified at %L", &ar->where); - return FAILURE; + return false; } if (ar->type == AR_FULL) - return SUCCESS; + return true; if (as->rank != ar->dimen) { gfc_error ("Rank mismatch in array reference at %L (%d/%d)", &ar->where, ar->dimen, as->rank); - return FAILURE; + return false; } /* ar->codimen == 0 is a local array. */ @@ -3979,12 +3969,12 @@ compare_spec_to_ref (gfc_array_ref *ar) { gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", &ar->where, ar->codimen, as->corank); - return FAILURE; + return false; } for (i = 0; i < as->rank; i++) - if (check_dimension (i, ar, as) == FAILURE) - return FAILURE; + if (!check_dimension (i, ar, as)) + return false; /* Local access has no coarray spec. */ if (ar->codimen != 0) @@ -3995,47 +3985,47 @@ compare_spec_to_ref (gfc_array_ref *ar) { gfc_error ("Coindex of codimension %d must be a scalar at %L", i + 1 - as->rank, &ar->where); - return FAILURE; + return false; } - if (check_dimension (i, ar, as) == FAILURE) - return FAILURE; + if (!check_dimension (i, ar, as)) + return false; } - return SUCCESS; + return true; } /* Resolve one part of an array index. */ -static gfc_try +static bool gfc_resolve_index_1 (gfc_expr *index, int check_scalar, int force_index_integer_kind) { gfc_typespec ts; if (index == NULL) - return SUCCESS; + return true; - if (gfc_resolve_expr (index) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (index)) + return false; if (check_scalar && index->rank != 0) { gfc_error ("Array index at %L must be scalar", &index->where); - return FAILURE; + return false; } if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) { gfc_error ("Array index at %L must be of INTEGER type, found %s", &index->where, gfc_basic_typename (index->ts.type)); - return FAILURE; + return false; } if (index->ts.type == BT_REAL) - if (gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", - &index->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", + &index->where)) + return false; if ((index->ts.kind != gfc_index_integer_kind && force_index_integer_kind) @@ -4048,12 +4038,12 @@ gfc_resolve_index_1 (gfc_expr *index, int check_scalar, gfc_convert_type_warn (index, &ts, 2, 0); } - return SUCCESS; + return true; } /* Resolve one part of an array index. */ -gfc_try +bool gfc_resolve_index (gfc_expr *index, int check_scalar) { return gfc_resolve_index_1 (index, check_scalar, 1); @@ -4061,26 +4051,26 @@ gfc_resolve_index (gfc_expr *index, int check_scalar) /* Resolve a dim argument to an intrinsic function. */ -gfc_try +bool gfc_resolve_dim_arg (gfc_expr *dim) { if (dim == NULL) - return SUCCESS; + return true; - if (gfc_resolve_expr (dim) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (dim)) + return false; if (dim->rank != 0) { gfc_error ("Argument dim at %L must be scalar", &dim->where); - return FAILURE; + return false; } if (dim->ts.type != BT_INTEGER) { gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); - return FAILURE; + return false; } if (dim->ts.kind != gfc_index_integer_kind) @@ -4094,7 +4084,7 @@ gfc_resolve_dim_arg (gfc_expr *dim) gfc_convert_type_warn (dim, &ts, 2, 0); } - return SUCCESS; + return true; } /* Given an expression that contains array references, update those array @@ -4152,7 +4142,7 @@ find_array_spec (gfc_expr *e) /* Resolve an array reference. */ -static gfc_try +static bool resolve_array_ref (gfc_array_ref *ar) { int i, check_scalar; @@ -4165,12 +4155,12 @@ resolve_array_ref (gfc_array_ref *ar) /* Do not force gfc_index_integer_kind for the start. We can do fine with any integer kind. This avoids temporary arrays created for indexing with a vector. */ - if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE) - return FAILURE; - if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE) - return FAILURE; - if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE) - return FAILURE; + if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0)) + return false; + if (!gfc_resolve_index (ar->end[i], check_scalar)) + return false; + if (!gfc_resolve_index (ar->stride[i], check_scalar)) + return false; e = ar->start[i]; @@ -4191,7 +4181,7 @@ resolve_array_ref (gfc_array_ref *ar) default: gfc_error ("Array index at %L is an array of rank %d", &ar->c_where[i], e->rank); - return FAILURE; + return false; } /* Fill in the upper bound, which may be lower than the @@ -4205,7 +4195,7 @@ resolve_array_ref (gfc_array_ref *ar) { mpz_t size, end; - if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS) + if (gfc_ref_dimen_size (ar, i, &size, &end)) { if (ar->end[i] == NULL) { @@ -4260,8 +4250,8 @@ resolve_array_ref (gfc_array_ref *ar) } } - if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE) - return FAILURE; + if (!ar->as->cray_pointee && !compare_spec_to_ref (ar)) + return false; if (ar->as->corank && ar->codimen == 0) { @@ -4271,32 +4261,32 @@ resolve_array_ref (gfc_array_ref *ar) ar->dimen_type[n] = DIMEN_THIS_IMAGE; } - return SUCCESS; + return true; } -static gfc_try +static bool resolve_substring (gfc_ref *ref) { int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); if (ref->u.ss.start != NULL) { - if (gfc_resolve_expr (ref->u.ss.start) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (ref->u.ss.start)) + return false; if (ref->u.ss.start->ts.type != BT_INTEGER) { gfc_error ("Substring start index at %L must be of type INTEGER", &ref->u.ss.start->where); - return FAILURE; + return false; } if (ref->u.ss.start->rank != 0) { gfc_error ("Substring start index at %L must be scalar", &ref->u.ss.start->where); - return FAILURE; + return false; } if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT @@ -4305,27 +4295,27 @@ resolve_substring (gfc_ref *ref) { gfc_error ("Substring start index at %L is less than one", &ref->u.ss.start->where); - return FAILURE; + return false; } } if (ref->u.ss.end != NULL) { - if (gfc_resolve_expr (ref->u.ss.end) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (ref->u.ss.end)) + return false; if (ref->u.ss.end->ts.type != BT_INTEGER) { gfc_error ("Substring end index at %L must be of type INTEGER", &ref->u.ss.end->where); - return FAILURE; + return false; } if (ref->u.ss.end->rank != 0) { gfc_error ("Substring end index at %L must be scalar", &ref->u.ss.end->where); - return FAILURE; + return false; } if (ref->u.ss.length != NULL @@ -4335,7 +4325,7 @@ resolve_substring (gfc_ref *ref) { gfc_error ("Substring end index at %L exceeds the string length", &ref->u.ss.start->where); - return FAILURE; + return false; } if (compare_bound_mpz_t (ref->u.ss.end, @@ -4345,11 +4335,11 @@ resolve_substring (gfc_ref *ref) { gfc_error ("Substring end index at %L is too large", &ref->u.ss.end->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } @@ -4421,7 +4411,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) /* Resolve subtype references. */ -static gfc_try +static bool resolve_ref (gfc_expr *expr) { int current_part_dimension, n_components, seen_part_dimension; @@ -4438,16 +4428,16 @@ resolve_ref (gfc_expr *expr) switch (ref->type) { case REF_ARRAY: - if (resolve_array_ref (&ref->u.ar) == FAILURE) - return FAILURE; + if (!resolve_array_ref (&ref->u.ar)) + return false; break; case REF_COMPONENT: break; case REF_SUBSTRING: - if (resolve_substring (ref) == FAILURE) - return FAILURE; + if (!resolve_substring (ref)) + return false; break; } @@ -4498,7 +4488,7 @@ resolve_ref (gfc_expr *expr) gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the POINTER " "attribute at %L", &expr->where); - return FAILURE; + return false; } else if (ref->u.c.component->attr.allocatable || (ref->u.c.component->ts.type == BT_CLASS @@ -4508,7 +4498,7 @@ resolve_ref (gfc_expr *expr) gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the ALLOCATABLE " "attribute at %L", &expr->where); - return FAILURE; + return false; } } @@ -4526,7 +4516,7 @@ resolve_ref (gfc_expr *expr) { gfc_error ("Two or more part references with nonzero rank must " "not be specified at %L", &expr->where); - return FAILURE; + return false; } if (ref->type == REF_COMPONENT) @@ -4539,7 +4529,7 @@ resolve_ref (gfc_expr *expr) } } - return SUCCESS; + return true; } @@ -4556,7 +4546,7 @@ expression_shape (gfc_expr *e) return; for (i = 0; i < e->rank; i++) - if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE) + if (!gfc_array_dimen_size (e, i, &array[i])) goto fail; e->shape = gfc_get_shape (e->rank); @@ -4642,16 +4632,16 @@ done: /* Resolve a variable expression. */ -static gfc_try +static bool resolve_variable (gfc_expr *e) { gfc_symbol *sym; - gfc_try t; + bool t; - t = SUCCESS; + t = true; if (e->symtree == NULL) - return FAILURE; + return false; sym = e->symtree->n.sym; /* TS 29113, 407b. */ @@ -4661,7 +4651,7 @@ resolve_variable (gfc_expr *e) { gfc_error ("Assumed-type variable %s at %L may only be used " "as actual argument", sym->name, &e->where); - return FAILURE; + return false; } else if (inquiry_argument && !first_actual_arg) { @@ -4672,7 +4662,7 @@ resolve_variable (gfc_expr *e) gfc_error ("Assumed-type variable %s at %L as actual argument to " "an inquiry function shall be the first argument", sym->name, &e->where); - return FAILURE; + return false; } } @@ -4687,7 +4677,7 @@ resolve_variable (gfc_expr *e) { gfc_error ("Assumed-rank variable %s at %L may only be used as " "actual argument", sym->name, &e->where); - return FAILURE; + return false; } else if (inquiry_argument && !first_actual_arg) { @@ -4698,7 +4688,7 @@ resolve_variable (gfc_expr *e) gfc_error ("Assumed-rank variable %s at %L as actual argument " "to an inquiry function shall be the first argument", sym->name, &e->where); - return FAILURE; + return false; } } @@ -4709,7 +4699,7 @@ resolve_variable (gfc_expr *e) { gfc_error ("Assumed-type variable %s at %L shall not have a subobject " "reference", sym->name, &e->ref->u.ar.where); - return FAILURE; + return false; } /* TS 29113, C535b. */ @@ -4724,7 +4714,7 @@ resolve_variable (gfc_expr *e) { gfc_error ("Assumed-rank variable %s at %L shall not have a subobject " "reference", sym->name, &e->ref->u.ar.where); - return FAILURE; + return false; } @@ -4736,7 +4726,7 @@ resolve_variable (gfc_expr *e) if (sym->ts.type == BT_CLASS) gfc_fix_class_refs (e); if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) - return FAILURE; + return false; } if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) @@ -4752,8 +4742,8 @@ resolve_variable (gfc_expr *e) e->ref->u.ar.dimen = 0; } - if (e->ref && resolve_ref (e) == FAILURE) - return FAILURE; + if (e->ref && !resolve_ref (e)) + return false; if (sym->attr.flavor == FL_PROCEDURE && (!sym->attr.function @@ -4770,13 +4760,13 @@ resolve_variable (gfc_expr *e) else { /* Must be a simple variable reference. */ - if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE) - return FAILURE; + if (!gfc_set_default_type (sym, 1, sym->ns)) + return false; e->ts = sym->ts; } if (check_assumed_size_reference (sym, e)) - return FAILURE; + return false; /* Deal with forward references to entries during resolve_code, to satisfy, at least partially, 12.5.2.5. */ @@ -4817,7 +4807,7 @@ resolve_variable (gfc_expr *e) gfc_error ("Variable '%s' is used at %L before the ENTRY " "statement in which it is a parameter", sym->name, &cs_base->current->loc); - t = FAILURE; + t = false; } } @@ -4825,20 +4815,20 @@ resolve_variable (gfc_expr *e) saved_specification_expr = specification_expr; specification_expr = true; if (sym->ts.type == BT_CHARACTER - && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE) - t = FAILURE; + && !gfc_resolve_expr (sym->ts.u.cl->length)) + t = false; if (sym->as) for (n = 0; n < sym->as->rank; n++) { - if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE) - t = FAILURE; - if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE) - t = FAILURE; + if (!gfc_resolve_expr (sym->as->lower[n])) + t = false; + if (!gfc_resolve_expr (sym->as->upper[n])) + t = false; } specification_expr = saved_specification_expr; - if (t == SUCCESS) + if (t) /* Update the symbol's entry level. */ sym->entry_id = current_entry_id + 1; } @@ -4853,8 +4843,8 @@ resolve_variable (gfc_expr *e) sym->attr.host_assoc = 1; resolve_procedure: - if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE) - t = FAILURE; + if (t && !resolve_procedure_expression (e)) + t = false; /* F2008, C617 and C1229. */ if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) @@ -4879,7 +4869,7 @@ resolve_procedure: { gfc_error ("Polymorphic subobject of coindexed object at %L", &e->where); - t = FAILURE; + t = false; } /* Expression itself is coindexed object. */ @@ -4892,7 +4882,7 @@ resolve_procedure: { gfc_error ("Coindexed object with polymorphic allocatable " "subcomponent at %L", &e->where); - t = FAILURE; + t = false; break; } } @@ -5126,7 +5116,7 @@ extract_compcall_passed_object (gfc_expr* e) po->where = e->where; } - if (gfc_resolve_expr (po) == FAILURE) + if (!gfc_resolve_expr (po)) return NULL; return po; @@ -5136,7 +5126,7 @@ extract_compcall_passed_object (gfc_expr* e) /* Update the arglist of an EXPR_COMPCALL expression to include the passed-object. */ -static gfc_try +static bool update_compcall_arglist (gfc_expr* e) { gfc_expr* po; @@ -5145,16 +5135,16 @@ update_compcall_arglist (gfc_expr* e) tbp = e->value.compcall.tbp; if (tbp->error) - return FAILURE; + return false; po = extract_compcall_passed_object (e); if (!po) - return FAILURE; + return false; if (tbp->nopass || e->value.compcall.ignore_pass) { gfc_free_expr (po); - return SUCCESS; + return true; } gcc_assert (tbp->pass_arg_num > 0); @@ -5162,7 +5152,7 @@ update_compcall_arglist (gfc_expr* e) tbp->pass_arg_num, tbp->pass_arg); - return SUCCESS; + return true; } @@ -5187,7 +5177,7 @@ extract_ppc_passed_object (gfc_expr *e) gfc_free_ref_list (*ref); *ref = NULL; - if (gfc_resolve_expr (po) == FAILURE) + if (!gfc_resolve_expr (po)) return NULL; return po; @@ -5197,7 +5187,7 @@ extract_ppc_passed_object (gfc_expr *e) /* Update the actual arglist of a procedure pointer component to include the passed-object. */ -static gfc_try +static bool update_ppc_arglist (gfc_expr* e) { gfc_expr* po; @@ -5206,24 +5196,24 @@ update_ppc_arglist (gfc_expr* e) ppc = gfc_get_proc_ptr_comp (e); if (!ppc) - return FAILURE; + return false; tb = ppc->tb; if (tb->error) - return FAILURE; + return false; else if (tb->nopass) - return SUCCESS; + return true; po = extract_ppc_passed_object (e); if (!po) - return FAILURE; + return false; /* F08:R739. */ if (po->rank != 0) { gfc_error ("Passed-object at %L must be scalar", &e->where); - return FAILURE; + return false; } /* F08:C611. */ @@ -5231,7 +5221,7 @@ update_ppc_arglist (gfc_expr* e) { gfc_error ("Base object for procedure-pointer component call at %L is of" " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name); - return FAILURE; + return false; } gcc_assert (tb->pass_arg_num > 0); @@ -5239,27 +5229,27 @@ update_ppc_arglist (gfc_expr* e) tb->pass_arg_num, tb->pass_arg); - return SUCCESS; + return true; } /* Check that the object a TBP is called on is valid, i.e. it must not be of ABSTRACT type (as in subobject%abstract_parent%tbp()). */ -static gfc_try +static bool check_typebound_baseobject (gfc_expr* e) { gfc_expr* base; - gfc_try return_value = FAILURE; + bool return_value = false; base = extract_compcall_passed_object (e); if (!base) - return FAILURE; + return false; gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS); if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok) - return FAILURE; + return false; /* F08:C611. */ if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) @@ -5278,7 +5268,7 @@ check_typebound_baseobject (gfc_expr* e) goto cleanup; } - return_value = SUCCESS; + return_value = true; cleanup: gfc_free_expr (base); @@ -5290,7 +5280,7 @@ cleanup: statically from the data in an EXPR_COMPCALL expression. The adapted arglist and the target-procedure symtree are returned. */ -static gfc_try +static bool resolve_typebound_static (gfc_expr* e, gfc_symtree** target, gfc_actual_arglist** actual) { @@ -5298,8 +5288,8 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, gcc_assert (!e->value.compcall.tbp->is_generic); /* Update the actual arglist for PASS. */ - if (update_compcall_arglist (e) == FAILURE) - return FAILURE; + if (!update_compcall_arglist (e)) + return false; *actual = e->value.compcall.actual; *target = e->value.compcall.tbp->u.specific; @@ -5340,7 +5330,7 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, if (st) *target = st; } - return SUCCESS; + return true; } @@ -5387,7 +5377,7 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, which of the specific bindings (if any) matches the arglist and transform the expression into a call of that binding. */ -static gfc_try +static bool resolve_typebound_generic_call (gfc_expr* e, const char **name) { gfc_typebound_proc* genproc; @@ -5400,7 +5390,7 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) genproc = e->value.compcall.tbp; if (!genproc->is_generic) - return SUCCESS; + return true; /* Try the bindings on this type and in the inheritance hierarchy. */ for (; genproc; genproc = genproc->overridden) @@ -5430,7 +5420,7 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) if (!po) { gfc_free_actual_arglist (args); - return FAILURE; + return false; } gcc_assert (g->specific->pass_arg_num > 0); @@ -5463,7 +5453,7 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) /* Nothing matching found! */ gfc_error ("Found no matching specific binding for the call to the GENERIC" " '%s' at %L", genname, &e->where); - return FAILURE; + return false; success: /* Make sure that we have the right specific instance for the name. */ @@ -5473,13 +5463,13 @@ success: if (st) e->value.compcall.tbp = st->n.tb; - return SUCCESS; + return true; } /* Resolve a call to a type-bound subroutine. */ -static gfc_try +static bool resolve_typebound_call (gfc_code* c, const char **name) { gfc_actual_arglist* newactual; @@ -5490,24 +5480,24 @@ resolve_typebound_call (gfc_code* c, const char **name) { gfc_error ("'%s' at %L should be a SUBROUTINE", c->expr1->value.compcall.name, &c->loc); - return FAILURE; + return false; } - if (check_typebound_baseobject (c->expr1) == FAILURE) - return FAILURE; + if (!check_typebound_baseobject (c->expr1)) + return false; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) *name = c->expr1->value.compcall.name; - if (resolve_typebound_generic_call (c->expr1, name) == FAILURE) - return FAILURE; + if (!resolve_typebound_generic_call (c->expr1, name)) + return false; /* Transform into an ordinary EXEC_CALL for now. */ - if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE) - return FAILURE; + if (!resolve_typebound_static (c->expr1, &target, &newactual)) + return false; c->ext.actual = newactual; c->symtree = target; @@ -5526,7 +5516,7 @@ resolve_typebound_call (gfc_code* c, const char **name) /* Resolve a component-call expression. */ -static gfc_try +static bool resolve_compcall (gfc_expr* e, const char **name) { gfc_actual_arglist* newactual; @@ -5537,22 +5527,22 @@ resolve_compcall (gfc_expr* e, const char **name) { gfc_error ("'%s' at %L should be a FUNCTION", e->value.compcall.name, &e->where); - return FAILURE; + return false; } /* These must not be assign-calls! */ gcc_assert (!e->value.compcall.assign); - if (check_typebound_baseobject (e) == FAILURE) - return FAILURE; + if (!check_typebound_baseobject (e)) + return false; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) *name = e->value.compcall.name; - if (resolve_typebound_generic_call (e, name) == FAILURE) - return FAILURE; + if (!resolve_typebound_generic_call (e, name)) + return false; gcc_assert (!e->value.compcall.tbp->is_generic); /* Take the rank from the function's symbol. */ @@ -5562,8 +5552,8 @@ resolve_compcall (gfc_expr* e, const char **name) /* For now, we simply transform it into an EXPR_FUNCTION call with the same arglist to the TBP's binding target. */ - if (resolve_typebound_static (e, &target, &newactual) == FAILURE) - return FAILURE; + if (!resolve_typebound_static (e, &target, &newactual)) + return false; e->value.function.actual = newactual; e->value.function.name = NULL; @@ -5584,7 +5574,7 @@ resolve_compcall (gfc_expr* e, const char **name) /* Resolve a typebound function, or 'method'. First separate all the non-CLASS references by calling resolve_compcall directly. */ -static gfc_try +static bool resolve_typebound_function (gfc_expr* e) { gfc_symbol *declared; @@ -5628,8 +5618,8 @@ resolve_typebound_function (gfc_expr* e) if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (declared); - if (resolve_compcall (e, &name) == FAILURE) - return FAILURE; + if (!resolve_compcall (e, &name)) + return false; /* Use the generic name if it is there. */ name = name ? name : e->value.function.esym->name; @@ -5655,14 +5645,14 @@ resolve_typebound_function (gfc_expr* e) e->value.function.esym = NULL; if (expr->expr_type != EXPR_VARIABLE) e->base_expr = expr; - return SUCCESS; + return true; } if (st == NULL) return resolve_compcall (e, NULL); - if (resolve_ref (e) == FAILURE) - return FAILURE; + if (!resolve_ref (e)) + return false; /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e, true); @@ -5680,10 +5670,10 @@ resolve_typebound_function (gfc_expr* e) /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ - if (resolve_compcall (e, &name) == FAILURE) + if (!resolve_compcall (e, &name)) { gfc_free_ref_list (new_ref); - return FAILURE; + return false; } ts = e->ts; @@ -5707,14 +5697,14 @@ resolve_typebound_function (gfc_expr* e) e->ts = ts; } - return SUCCESS; + return true; } /* Resolve a typebound subroutine, or 'method'. First separate all the non-CLASS references by calling resolve_typebound_call directly. */ -static gfc_try +static bool resolve_typebound_subroutine (gfc_code *code) { gfc_symbol *declared; @@ -5756,8 +5746,8 @@ resolve_typebound_subroutine (gfc_code *code) if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (declared); - if (resolve_typebound_call (code, &name) == FAILURE) - return FAILURE; + if (!resolve_typebound_call (code, &name)) + return false; /* Use the generic name if it is there. */ name = name ? name : code->expr1->value.function.esym->name; @@ -5784,14 +5774,14 @@ resolve_typebound_subroutine (gfc_code *code) code->expr1->value.function.esym = NULL; if (expr->expr_type != EXPR_VARIABLE) code->expr1->base_expr = expr; - return SUCCESS; + return true; } if (st == NULL) return resolve_typebound_call (code, NULL); - if (resolve_ref (code->expr1) == FAILURE) - return FAILURE; + if (!resolve_ref (code->expr1)) + return false; /* Get the CLASS declared type. */ get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); @@ -5804,10 +5794,10 @@ resolve_typebound_subroutine (gfc_code *code) return resolve_typebound_call (code, NULL); } - if (resolve_typebound_call (code, &name) == FAILURE) + if (!resolve_typebound_call (code, &name)) { gfc_free_ref_list (new_ref); - return FAILURE; + return false; } ts = code->expr1->ts; @@ -5830,14 +5820,16 @@ resolve_typebound_subroutine (gfc_code *code) correct typespec. */ code->expr1->ts = ts; } + else if (new_ref) + gfc_free_ref_list (new_ref); - return SUCCESS; + return true; } /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */ -static gfc_try +static bool resolve_ppc_call (gfc_code* c) { gfc_component *comp; @@ -5851,27 +5843,28 @@ resolve_ppc_call (gfc_code* c) if (!comp->attr.subroutine) gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); - if (resolve_ref (c->expr1) == FAILURE) - return FAILURE; + if (!resolve_ref (c->expr1)) + return false; - if (update_ppc_arglist (c->expr1) == FAILURE) - return FAILURE; + if (!update_ppc_arglist (c->expr1)) + return false; c->ext.actual = c->expr1->value.compcall.actual; - if (resolve_actual_arglist (c->ext.actual, comp->attr.proc, - !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE) - return FAILURE; + if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, + !(comp->ts.interface + && comp->ts.interface->formal))) + return false; gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where); - return SUCCESS; + return true; } /* Resolve a Function Call to a Procedure Pointer Component (Function). */ -static gfc_try +static bool resolve_expr_ppc (gfc_expr* e) { gfc_component *comp; @@ -5890,19 +5883,20 @@ resolve_expr_ppc (gfc_expr* e) if (!comp->attr.function) gfc_add_function (&comp->attr, comp->name, &e->where); - if (resolve_ref (e) == FAILURE) - return FAILURE; + if (!resolve_ref (e)) + return false; - if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc, - !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE) - return FAILURE; + if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, + !(comp->ts.interface + && comp->ts.interface->formal))) + return false; - if (update_ppc_arglist (e) == FAILURE) - return FAILURE; + if (!update_ppc_arglist (e)) + return false; gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); - return SUCCESS; + return true; } @@ -5937,14 +5931,14 @@ gfc_is_expandable_expr (gfc_expr *e) with their operators, intrinsic operators are converted to function calls for overloaded types and unresolved function references are resolved. */ -gfc_try +bool gfc_resolve_expr (gfc_expr *e) { - gfc_try t; + bool t; bool inquiry_save, actual_arg_save, first_actual_arg_save; if (e == NULL) - return SUCCESS; + return true; /* inquiry_argument only applies to variables. */ inquiry_save = inquiry_argument; @@ -5972,7 +5966,7 @@ gfc_resolve_expr (gfc_expr *e) else { t = resolve_variable (e); - if (t == SUCCESS) + if (t) expression_rank (e); } @@ -5992,7 +5986,7 @@ gfc_resolve_expr (gfc_expr *e) case EXPR_CONSTANT: case EXPR_NULL: - t = SUCCESS; + t = true; break; case EXPR_PPC: @@ -6000,13 +5994,13 @@ gfc_resolve_expr (gfc_expr *e) break; case EXPR_ARRAY: - t = FAILURE; - if (resolve_ref (e) == FAILURE) + t = false; + if (!resolve_ref (e)) break; t = gfc_resolve_array_constructor (e); /* Also try to expand a constructor. */ - if (t == SUCCESS) + if (t) { expression_rank (e); if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) @@ -6016,7 +6010,7 @@ gfc_resolve_expr (gfc_expr *e) /* This provides the opportunity for the length of constructors with character valued function elements to propagate the string length to the expression. */ - if (t == SUCCESS && e->ts.type == BT_CHARACTER) + if (t && e->ts.type == BT_CHARACTER) { /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER here rather then add a duplicate test for it above. */ @@ -6028,11 +6022,11 @@ gfc_resolve_expr (gfc_expr *e) case EXPR_STRUCTURE: t = resolve_ref (e); - if (t == FAILURE) + if (!t) break; t = resolve_structure_cons (e, 0); - if (t == FAILURE) + if (!t) break; t = gfc_simplify_expr (e, 0); @@ -6042,7 +6036,7 @@ gfc_resolve_expr (gfc_expr *e) gfc_internal_error ("gfc_resolve_expr(): Bad expression type"); } - if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl) + if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl) fixup_charlen (e); inquiry_argument = inquiry_save; @@ -6056,17 +6050,17 @@ gfc_resolve_expr (gfc_expr *e) /* Resolve an expression from an iterator. They must be scalar and have INTEGER or (optionally) REAL type. */ -static gfc_try +static bool gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, const char *name_msgid) { - if (gfc_resolve_expr (expr) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (expr)) + return false; if (expr->rank != 0) { gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where); - return FAILURE; + return false; } if (expr->ts.type != BT_INTEGER) @@ -6081,16 +6075,16 @@ gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, { gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); - return FAILURE; + return false; } } else { gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } @@ -6099,29 +6093,27 @@ gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, Set own_scope to true for ac-implied-do and data-implied-do as those have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */ -gfc_try +bool gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) { - if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable") - == FAILURE) - return FAILURE; + if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")) + return false; - if (gfc_check_vardef_context (iter->var, false, false, own_scope, - _("iterator variable")) - == FAILURE) - return FAILURE; + if (!gfc_check_vardef_context (iter->var, false, false, own_scope, + _("iterator variable"))) + return false; - if (gfc_resolve_iterator_expr (iter->start, real_ok, - "Start expression in DO loop") == FAILURE) - return FAILURE; + if (!gfc_resolve_iterator_expr (iter->start, real_ok, + "Start expression in DO loop")) + return false; - if (gfc_resolve_iterator_expr (iter->end, real_ok, - "End expression in DO loop") == FAILURE) - return FAILURE; + if (!gfc_resolve_iterator_expr (iter->end, real_ok, + "End expression in DO loop")) + return false; - if (gfc_resolve_iterator_expr (iter->step, real_ok, - "Step expression in DO loop") == FAILURE) - return FAILURE; + if (!gfc_resolve_iterator_expr (iter->step, real_ok, + "Step expression in DO loop")) + return false; if (iter->step->expr_type == EXPR_CONSTANT) { @@ -6132,7 +6124,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) { gfc_error ("Step expression in DO loop at %L cannot be zero", &iter->step->where); - return FAILURE; + return false; } } @@ -6169,7 +6161,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) &iter->step->where); } - return SUCCESS; + return true; } @@ -6198,15 +6190,15 @@ forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) /* Check whether the FORALL index appears in the expression or not. - Returns SUCCESS if SYM is found in EXPR. */ + Returns true if SYM is found in EXPR. */ -gfc_try +bool find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f) { if (gfc_traverse_expr (expr, sym, forall_index, f)) - return SUCCESS; + return true; else - return FAILURE; + return false; } @@ -6224,33 +6216,33 @@ resolve_forall_iterators (gfc_forall_iterator *it) for (iter = it; iter; iter = iter->next) { - if (gfc_resolve_expr (iter->var) == SUCCESS + if (gfc_resolve_expr (iter->var) && (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 + if (gfc_resolve_expr (iter->start) && (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, 1); - if (gfc_resolve_expr (iter->end) == SUCCESS + if (gfc_resolve_expr (iter->end) && (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, 1); - if (gfc_resolve_expr (iter->stride) == SUCCESS) + if (gfc_resolve_expr (iter->stride)) { 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) + && mpz_cmp_ui (iter->stride->value.integer, 0) == 0) gfc_error ("FORALL stride expression at %L cannot be zero", &iter->stride->where); } @@ -6261,12 +6253,9 @@ resolve_forall_iterators (gfc_forall_iterator *it) for (iter = it; iter; iter = iter->next) for (iter2 = iter; iter2; iter2 = iter2->next) { - if (find_forall_index (iter2->start, - iter->var->symtree->n.sym, 0) == SUCCESS - || find_forall_index (iter2->end, - iter->var->symtree->n.sym, 0) == SUCCESS - || find_forall_index (iter2->stride, - iter->var->symtree->n.sym, 0) == SUCCESS) + if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0) + || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0) + || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0)) gfc_error ("FORALL index '%s' may not appear in triplet " "specification at %L", iter->var->symtree->name, &iter2->start->where); @@ -6300,7 +6289,7 @@ derived_inaccessible (gfc_symbol *sym) /* Resolve the argument of a deallocate expression. The expression must be a pointer or a full array. */ -static gfc_try +static bool resolve_deallocate_expr (gfc_expr *e) { symbol_attribute attr; @@ -6310,8 +6299,8 @@ resolve_deallocate_expr (gfc_expr *e) gfc_component *c; bool unlimited; - if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (e)) + return false; if (e->expr_type != EXPR_VARIABLE) goto bad; @@ -6367,25 +6356,25 @@ resolve_deallocate_expr (gfc_expr *e) bad: gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); - return FAILURE; + return false; } /* F2008, C644. */ if (gfc_is_coindexed (e)) { gfc_error ("Coindexed allocatable object at %L", &e->where); - return FAILURE; + return false; } if (pointer - && gfc_check_vardef_context (e, true, true, false, _("DEALLOCATE object")) - == FAILURE) - return FAILURE; - if (gfc_check_vardef_context (e, false, true, false, _("DEALLOCATE object")) - == FAILURE) - return FAILURE; + && !gfc_check_vardef_context (e, true, true, false, + _("DEALLOCATE object"))) + return false; + if (!gfc_check_vardef_context (e, false, true, false, + _("DEALLOCATE object"))) + return false; - return SUCCESS; + return true; } @@ -6469,7 +6458,7 @@ remove_last_array_ref (gfc_expr* e) a source-expr are conformable. This does not catch all possible cases; in particular a runtime checking is needed. */ -static gfc_try +static bool conformable_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_ref *tail; @@ -6481,7 +6470,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) gfc_error ("Source-expr at %L must be scalar or have the " "same rank as the allocate-object at %L", &e1->where, &e2->where); - return FAILURE; + return false; } if (e1->shape) @@ -6509,14 +6498,14 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) gfc_error ("Source-expr at %L and allocate-object at %L must " "have the same shape", &e1->where, &e2->where); mpz_clear (s); - return FAILURE; + return false; } } mpz_clear (s); } - return SUCCESS; + return true; } @@ -6524,7 +6513,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) checks to see whether the expression is OK or not. The expression must have a trailing array reference that gives the size of the array. */ -static gfc_try +static bool resolve_allocate_expr (gfc_expr *e, gfc_code *code) { int i, pointer, allocatable, dimension, is_abstract; @@ -6538,7 +6527,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - gfc_try t; + bool t; /* Mark the utmost array component as being in allocate to allow DIMEN_STAR checking of coarrays. */ @@ -6549,7 +6538,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (ref && ref->type == REF_ARRAY) ref->u.ar.in_allocate = true; - if (gfc_resolve_expr (e) == FAILURE) + if (!gfc_resolve_expr (e)) goto failure; /* Make sure the expression is allocatable or a pointer. If it is @@ -6671,7 +6660,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check F03:C632 and restriction following Note 6.18. */ if (code->expr3->rank > 0 && !unlimited - && conformable_arrays (code->expr3, e) == FAILURE) + && !conformable_arrays (code->expr3, e)) goto failure; /* Check F03:C633. */ @@ -6726,13 +6715,15 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) on the expression. This is fooled by the array specification present in e, thus we have to eliminate that one temporarily. */ e2 = remove_last_array_ref (e); - t = SUCCESS; - if (t == SUCCESS && pointer) - t = gfc_check_vardef_context (e2, true, true, false, _("ALLOCATE object")); - if (t == SUCCESS) - t = gfc_check_vardef_context (e2, false, true, false, _("ALLOCATE object")); + t = true; + if (t && pointer) + t = gfc_check_vardef_context (e2, true, true, false, + _("ALLOCATE object")); + if (t) + t = gfc_check_vardef_context (e2, false, true, false, + _("ALLOCATE object")); gfc_free_expr (e2); - if (t == FAILURE) + if (!t) goto failure; if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension @@ -6914,10 +6905,10 @@ check_symbols: } success: - return SUCCESS; + return true; failure: - return FAILURE; + return false; } static void @@ -6932,7 +6923,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* Check the stat variable. */ if (stat) { - gfc_check_vardef_context (stat, false, false, false, _("STAT variable")); + gfc_check_vardef_context (stat, false, false, false, + _("STAT variable")); if ((stat->ts.type != BT_INTEGER && !(stat->ref && (stat->ref->type == REF_ARRAY @@ -7294,18 +7286,18 @@ 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. Return FAILURE if anything is wrong. */ + type. Return false if anything is wrong. */ -static gfc_try +static bool validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) { - if (e == NULL) return SUCCESS; + if (e == NULL) return true; 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_expr->ts.type)); - return FAILURE; + return false; } /* C805 (R808) For a given case-construct, each case-value shall be of @@ -7316,7 +7308,7 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) { gfc_error ("Expression in CASE statement at %L must be of kind %d", &e->where, case_expr->ts.kind); - return FAILURE; + return false; } /* Convert the case value kind to that of case expression kind, @@ -7329,10 +7321,10 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) { gfc_error ("Expression in CASE statement at %L must be scalar", &e->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -7366,7 +7358,7 @@ resolve_select (gfc_code *code, bool select_type) int seen_logical; int ncases; bt type; - gfc_try t; + bool t; if (code->expr1 == NULL) { @@ -7475,7 +7467,7 @@ resolve_select (gfc_code *code, bool select_type) for (body = code->block; body; body = body->block) { /* Assume the CASE list is OK, and all CASE labels can be matched. */ - t = SUCCESS; + t = true; seen_unreachable = 0; /* Walk the case label list, making sure that all case labels @@ -7493,7 +7485,7 @@ resolve_select (gfc_code *code, bool select_type) gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->where, &cp->where); - t = FAILURE; + t = false; break; } else @@ -7505,10 +7497,10 @@ resolve_select (gfc_code *code, bool select_type) /* Deal with single value cases and case ranges. Errors are issued from the validation function. */ - if (validate_case_label_expr (cp->low, case_expr) != SUCCESS - || validate_case_label_expr (cp->high, case_expr) != SUCCESS) + if (!validate_case_label_expr (cp->low, case_expr) + || !validate_case_label_expr (cp->high, case_expr)) { - t = FAILURE; + t = false; break; } @@ -7518,7 +7510,7 @@ resolve_select (gfc_code *code, bool select_type) { gfc_error ("Logical range in CASE statement at %L is not " "allowed", &cp->low->where); - t = FAILURE; + t = false; break; } @@ -7531,7 +7523,7 @@ resolve_select (gfc_code *code, bool select_type) gfc_error ("Constant logical value in CASE statement " "is repeated at %L", &cp->low->where); - t = FAILURE; + t = false; break; } seen_logical |= value; @@ -7571,7 +7563,7 @@ resolve_select (gfc_code *code, bool select_type) /* It there was a failure in the previous case label, give up for this case label list. Continue with the next block. */ - if (t == FAILURE) + if (!t) continue; /* See if any case labels that are unreachable have been seen. @@ -7680,7 +7672,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; gcc_assert (!sym->assoc->dangling); - if (resolve_target && gfc_resolve_expr (target) != SUCCESS) + if (resolve_target && !gfc_resolve_expr (target)) return; /* For variable targets, we get some attributes from the target. */ @@ -8147,8 +8139,8 @@ resolve_transfer (gfc_code *code) code->ext.dt may be NULL if the TRANSFER is related to an INQUIRE statement -- but in this case, we are not reading, either. */ if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ - && gfc_check_vardef_context (exp, false, false, false, _("item in READ")) - == FAILURE) + && !gfc_check_vardef_context (exp, false, false, false, + _("item in READ"))) return; sym = exp->symtree->n.sym; @@ -8201,8 +8193,8 @@ resolve_transfer (gfc_code *code) the component to be printed to help debugging. */ if (ts->u.derived->ts.f90_type == BT_VOID) { - if (gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L cannot " - "have PRIVATE components", &code->loc) == FAILURE) + if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L " + "cannot have PRIVATE components", &code->loc)) return; } else if (derived_inaccessible (ts->u.derived)) @@ -8277,8 +8269,8 @@ resolve_lock_unlock (gfc_code *code) &code->expr2->where); if (code->expr2 - && gfc_check_vardef_context (code->expr2, false, false, false, - _("STAT variable")) == FAILURE) + && !gfc_check_vardef_context (code->expr2, false, false, false, + _("STAT variable"))) return; /* Check ERRMSG. */ @@ -8289,8 +8281,8 @@ resolve_lock_unlock (gfc_code *code) &code->expr3->where); if (code->expr3 - && gfc_check_vardef_context (code->expr3, false, false, false, - _("ERRMSG variable")) == FAILURE) + && !gfc_check_vardef_context (code->expr3, false, false, false, + _("ERRMSG variable"))) return; /* Check ACQUIRED_LOCK. */ @@ -8301,8 +8293,8 @@ resolve_lock_unlock (gfc_code *code) "variable", &code->expr4->where); if (code->expr4 - && gfc_check_vardef_context (code->expr4, false, false, false, - _("ACQUIRED_LOCK variable")) == FAILURE) + && !gfc_check_vardef_context (code->expr4, false, false, false, + _("ACQUIRED_LOCK variable"))) return; } @@ -8321,7 +8313,7 @@ resolve_sync (gfc_code *code) gfc_error ("Imageset argument at %L must between 1 and num_images()", &code->expr1->where); else if (code->expr1->expr_type == EXPR_ARRAY - && gfc_simplify_expr (code->expr1, 0) == SUCCESS) + && gfc_simplify_expr (code->expr1, 0)) { gfc_constructor *cons; cons = gfc_constructor_first (code->expr1->value.constructor); @@ -8450,12 +8442,12 @@ resolve_branch (gfc_st_label *label, gfc_code *code) /* Check whether EXPR1 has the same shape as EXPR2. */ -static gfc_try +static bool resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) { mpz_t shape[GFC_MAX_DIMENSIONS]; mpz_t shape2[GFC_MAX_DIMENSIONS]; - gfc_try result = FAILURE; + bool result = false; int i; /* Compare the rank. */ @@ -8465,10 +8457,10 @@ resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) /* Compare the size of each dimension. */ for (i=0; i<expr1->rank; i++) { - if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE) + if (!gfc_array_dimen_size (expr1, i, &shape[i])) goto ignore; - if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE) + if (!gfc_array_dimen_size (expr2, i, &shape2[i])) goto ignore; if (mpz_cmp (shape[i], shape2[i])) @@ -8478,7 +8470,7 @@ resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) /* When either of the two expression is an assumed size array, we ignore the comparison of dimension sizes. */ ignore: - result = SUCCESS; + result = true; over: gfc_clear_shape (shape, i); @@ -8512,7 +8504,7 @@ resolve_where (gfc_code *code, gfc_expr *mask) { /* Check if the mask-expr has a consistent shape with the outmost WHERE mask-expr. */ - if (resolve_where_shape (cblock->expr1, e) == FAILURE) + if (!resolve_where_shape (cblock->expr1, e)) gfc_error ("WHERE mask at %L has inconsistent shape", &cblock->expr1->where); } @@ -8528,7 +8520,7 @@ resolve_where (gfc_code *code, gfc_expr *mask) case EXEC_ASSIGN: /* Check shape consistent for WHERE assignment target. */ - if (e && resolve_where_shape (cnext->expr1, e) == FAILURE) + if (e && !resolve_where_shape (cnext->expr1, e)) gfc_error ("WHERE assignment target at %L has " "inconsistent shape", &cnext->expr1->where); break; @@ -8586,7 +8578,7 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) assignment variable, then there could be a many-to-one assignment. Emit a warning rather than an error because the mask could be resolving this problem. */ - if (find_forall_index (code->expr1, forall_index, 0) == FAILURE) + if (!find_forall_index (code->expr1, forall_index, 0)) gfc_warning ("The FORALL with index '%s' is not used on the " "left side of the assignment at %L and so might " "cause multiple assignment to this object", @@ -8815,25 +8807,25 @@ static void resolve_code (gfc_code *, gfc_namespace *); void gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) { - gfc_try t; + bool t; for (; b; b = b->block) { t = gfc_resolve_expr (b->expr1); - if (gfc_resolve_expr (b->expr2) == FAILURE) - t = FAILURE; + if (!gfc_resolve_expr (b->expr2)) + t = false; switch (b->op) { case EXEC_IF: - if (t == SUCCESS && b->expr1 != NULL + if (t && b->expr1 != NULL && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) gfc_error ("IF clause at %L requires a scalar LOGICAL expression", &b->expr1->where); break; case EXEC_WHERE: - if (t == SUCCESS + if (t && b->expr1 != NULL && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0)) gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array", @@ -8900,7 +8892,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) int n; gfc_ref *ref; - if (gfc_extend_assign (code, ns) == SUCCESS) + if (gfc_extend_assign (code, ns)) { gfc_expr** rhsptr; @@ -8939,9 +8931,9 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) rhs = code->expr2; if (rhs->is_boz - && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " - "a DATA statement and outside INT/REAL/DBLE/CMPLX", - &code->loc) == FAILURE) + && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " + "a DATA statement and outside INT/REAL/DBLE/CMPLX", + &code->loc)) return false; /* Handle the case of a BOZ literal on the RHS. */ @@ -9499,7 +9491,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) int omp_workshare_save; int forall_save, do_concurrent_save; code_stack frame; - gfc_try t; + bool t; frame.prev = cs_base; frame.head = code; @@ -9562,18 +9554,18 @@ resolve_code (gfc_code *code, gfc_namespace *ns) omp_workshare_flag = omp_workshare_save; } - t = SUCCESS; + t = true; if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) t = gfc_resolve_expr (code->expr1); forall_flag = forall_save; do_concurrent_flag = do_concurrent_save; - if (gfc_resolve_expr (code->expr2) == FAILURE) - t = FAILURE; + if (!gfc_resolve_expr (code->expr2)) + t = false; if (code->op == EXEC_ALLOCATE - && gfc_resolve_expr (code->expr3) == FAILURE) - t = FAILURE; + && !gfc_resolve_expr (code->expr3)) + t = false; switch (code->op) { @@ -9638,11 +9630,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_ASSIGN: - if (t == FAILURE) + if (!t) break; - if (gfc_check_vardef_context (code->expr1, false, false, false, - _("assignment")) == FAILURE) + if (!gfc_check_vardef_context (code->expr1, false, false, false, + _("assignment"))) break; if (resolve_ordinary_assign (code, ns)) @@ -9664,7 +9656,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (code->label1->defined == ST_LABEL_UNKNOWN) gfc_error ("Label %d referenced at %L is never defined", code->label1->value, &code->label1->where); - if (t == SUCCESS + if (t && (code->expr1->expr_type != EXPR_VARIABLE || code->expr1->symtree->n.sym->ts.type != BT_INTEGER || code->expr1->symtree->n.sym->ts.kind @@ -9678,7 +9670,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) { gfc_expr* e; - if (t == FAILURE) + if (!t) break; /* This is both a variable definition and pointer assignment @@ -9688,11 +9680,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) e = remove_last_array_ref (code->expr1); t = gfc_check_vardef_context (e, true, false, false, _("pointer assignment")); - if (t == SUCCESS) + if (t) t = gfc_check_vardef_context (e, false, false, false, _("pointer assignment")); gfc_free_expr (e); - if (t == FAILURE) + if (!t) break; gfc_check_pointer_assign (code->expr1, code->expr2); @@ -9700,7 +9692,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) } case EXEC_ARITHMETIC_IF: - if (t == SUCCESS + if (t && code->expr1->ts.type != BT_INTEGER && code->expr1->ts.type != BT_REAL) gfc_error ("Arithmetic IF statement at %L requires a numeric " @@ -9712,7 +9704,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_IF: - if (t == SUCCESS && code->expr1 != NULL + if (t && code->expr1 != NULL && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank != 0)) gfc_error ("IF clause at %L requires a scalar LOGICAL expression", @@ -9751,7 +9743,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (code->ext.iterator != NULL) { gfc_iterator *iter = code->ext.iterator; - if (gfc_resolve_iterator (iter, true, false) != FAILURE) + if (gfc_resolve_iterator (iter, true, false)) gfc_resolve_do_iterator (code, iter->var->symtree->n.sym); } break; @@ -9759,7 +9751,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_DO_WHILE: if (code->expr1 == NULL) gfc_internal_error ("resolve_code(): No expression on DO WHILE"); - if (t == SUCCESS + if (t && (code->expr1->rank != 0 || code->expr1->ts.type != BT_LOGICAL)) gfc_error ("Exit condition of DO WHILE loop at %L must be " @@ -9767,26 +9759,26 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_ALLOCATE: - if (t == SUCCESS) + if (t) resolve_allocate_deallocate (code, "ALLOCATE"); break; case EXEC_DEALLOCATE: - if (t == SUCCESS) + if (t) resolve_allocate_deallocate (code, "DEALLOCATE"); break; case EXEC_OPEN: - if (gfc_resolve_open (code->ext.open) == FAILURE) + if (!gfc_resolve_open (code->ext.open)) break; resolve_branch (code->ext.open->err, code); break; case EXEC_CLOSE: - if (gfc_resolve_close (code->ext.close) == FAILURE) + if (!gfc_resolve_close (code->ext.close)) break; resolve_branch (code->ext.close->err, code); @@ -9796,14 +9788,14 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_ENDFILE: case EXEC_REWIND: case EXEC_FLUSH: - if (gfc_resolve_filepos (code->ext.filepos) == FAILURE) + if (!gfc_resolve_filepos (code->ext.filepos)) break; resolve_branch (code->ext.filepos->err, code); break; case EXEC_INQUIRE: - if (gfc_resolve_inquire (code->ext.inquire) == FAILURE) + if (!gfc_resolve_inquire (code->ext.inquire)) break; resolve_branch (code->ext.inquire->err, code); @@ -9811,14 +9803,14 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_IOLENGTH: gcc_assert (code->ext.inquire != NULL); - if (gfc_resolve_inquire (code->ext.inquire) == FAILURE) + if (!gfc_resolve_inquire (code->ext.inquire)) break; resolve_branch (code->ext.inquire->err, code); break; case EXEC_WAIT: - if (gfc_resolve_wait (code->ext.wait) == FAILURE) + if (!gfc_resolve_wait (code->ext.wait)) break; resolve_branch (code->ext.wait->err, code); @@ -9828,7 +9820,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_READ: case EXEC_WRITE: - if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE) + if (!gfc_resolve_dt (code->ext.dt, &code->loc)) break; resolve_branch (code->ext.dt->err, code); @@ -9891,7 +9883,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) static void resolve_values (gfc_symbol *sym) { - gfc_try t; + bool t; if (sym->value == NULL) return; @@ -9901,7 +9893,7 @@ resolve_values (gfc_symbol *sym) else t = gfc_resolve_expr (sym->value); - if (t == FAILURE) + if (!t) return; gfc_check_assign_symbol (sym, NULL, sym->value); @@ -10109,32 +10101,32 @@ gfc_verify_binding_labels (gfc_symbol *sym) /* Resolve an index expression. */ -static gfc_try +static bool resolve_index_expr (gfc_expr *e) { - if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (e)) + return false; - if (gfc_simplify_expr (e, 0) == FAILURE) - return FAILURE; + if (!gfc_simplify_expr (e, 0)) + return false; - if (gfc_specification_expr (e) == FAILURE) - return FAILURE; + if (!gfc_specification_expr (e)) + return false; - return SUCCESS; + return true; } /* Resolve a charlen structure. */ -static gfc_try +static bool resolve_charlen (gfc_charlen *cl) { int i, k; bool saved_specification_expr; if (cl->resolved) - return SUCCESS; + return true; cl->resolved = 1; saved_specification_expr = specification_expr; @@ -10142,25 +10134,25 @@ resolve_charlen (gfc_charlen *cl) if (cl->length_from_typespec) { - if (gfc_resolve_expr (cl->length) == FAILURE) + if (!gfc_resolve_expr (cl->length)) { specification_expr = saved_specification_expr; - return FAILURE; + return false; } - if (gfc_simplify_expr (cl->length, 0) == FAILURE) + if (!gfc_simplify_expr (cl->length, 0)) { specification_expr = saved_specification_expr; - return FAILURE; + return false; } } else { - if (resolve_index_expr (cl->length) == FAILURE) + if (!resolve_index_expr (cl->length)) { specification_expr = saved_specification_expr; - return FAILURE; + return false; } } @@ -10184,11 +10176,11 @@ resolve_charlen (gfc_charlen *cl) { gfc_error ("String length at %L is too large", &cl->length->where); specification_expr = saved_specification_expr; - return FAILURE; + return false; } specification_expr = saved_specification_expr; - return SUCCESS; + return true; } @@ -10210,11 +10202,11 @@ is_non_constant_shape_array (gfc_symbol *sym) for (i = 0; i < sym->as->rank + sym->as->corank; i++) { e = sym->as->lower[i]; - if (e && (resolve_index_expr (e) == FAILURE + if (e && (!resolve_index_expr(e) || !gfc_is_constant_expr (e))) not_constant = true; e = sym->as->upper[i]; - if (e && (resolve_index_expr (e) == FAILURE + if (e && (!resolve_index_expr(e) || !gfc_is_constant_expr (e))) not_constant = true; } @@ -10486,7 +10478,7 @@ apply_default_init_local (gfc_symbol *sym) /* Resolution of common features of flavors variable and procedure. */ -static gfc_try +static bool resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { gfc_array_spec *as; @@ -10520,19 +10512,19 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { gfc_error ("Allocatable array '%s' at %L must have a deferred " "shape or assumed rank", sym->name, &sym->declared_at); - return FAILURE; + return false; } - else if (gfc_notify_std (GFC_STD_F2003, "Scalar object " - "'%s' at %L may not be ALLOCATABLE", - sym->name, &sym->declared_at) == FAILURE) - return FAILURE; + else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object " + "'%s' at %L may not be ALLOCATABLE", + sym->name, &sym->declared_at)) + return false; } if (pointer && dimension && as->type != AS_ASSUMED_RANK) { gfc_error ("Array pointer '%s' at %L must have a deferred shape or " "assumed rank", sym->name, &sym->declared_at); - return FAILURE; + return false; } } else @@ -10542,7 +10534,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { gfc_error ("Array '%s' at %L cannot have a deferred shape", sym->name, &sym->declared_at); - return FAILURE; + return false; } } @@ -10552,13 +10544,13 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) /* F03:C502. */ if (sym->attr.class_ok && !sym->attr.select_type_temporary - && !UNLIMITED_POLY(sym) + && !UNLIMITED_POLY (sym) && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", CLASS_DATA (sym)->ts.u.derived->name, sym->name, &sym->declared_at); - return FAILURE; + return false; } /* F03:C509. */ @@ -10569,18 +10561,18 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " "or pointer", sym->name, &sym->declared_at); - return FAILURE; + return false; } } - return SUCCESS; + return true; } /* Additional checks for symbols with flavor variable and derived type. To be called from resolve_fl_variable. */ -static gfc_try +static bool resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) { gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); @@ -10603,7 +10595,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) "of the same name declared at %L", sym->ts.u.derived->name, &sym->declared_at, &s->declared_at); - return FAILURE; + return false; } } @@ -10620,11 +10612,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) && !sym->ns->save_all && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable && gfc_has_default_initializer (sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2008, "Implied SAVE for " - "module variable '%s' at %L, needed due to " - "the default initialization", sym->name, - &sym->declared_at) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable " + "'%s' at %L, needed due to the default " + "initialization", sym->name, &sym->declared_at)) + return false; /* Assign default initializer. */ if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) @@ -10633,13 +10624,13 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) sym->value = gfc_default_initializer (&sym->ts); } - return SUCCESS; + return true; } /* Resolve symbols with flavor variable. */ -static gfc_try +static bool resolve_fl_variable (gfc_symbol *sym, int mp_flag) { int no_init_flag, automatic_flag; @@ -10650,8 +10641,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) auto_save_msg = "Automatic object '%s' at %L cannot have the " "SAVE attribute"; - if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) - return FAILURE; + if (!resolve_fl_var_and_proc (sym, mp_flag)) + return false; /* Set this flag to check that variables are parameters of all entries. This check is effected by the call to gfc_resolve_expr through @@ -10672,7 +10663,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) gfc_error ("The module or main program array '%s' at %L must " "have constant shape", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; - return FAILURE; + return false; } /* Constraints on deferred type parameter. */ @@ -10682,7 +10673,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) "requires either the pointer or allocatable attribute", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; - return FAILURE; + return false; } if (sym->ts.type == BT_CHARACTER) @@ -10696,14 +10687,14 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) gfc_error ("Entity with assumed character length at %L must be a " "dummy argument or a PARAMETER", &sym->declared_at); specification_expr = saved_specification_expr; - return FAILURE; + return false; } if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) { gfc_error (auto_save_msg, sym->name, &sym->declared_at); specification_expr = saved_specification_expr; - return FAILURE; + return false; } if (!gfc_is_constant_expr (e) @@ -10717,14 +10708,14 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) gfc_error ("'%s' at %L must have constant character length " "in this context", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; - return FAILURE; + return false; } if (sym->attr.in_common) { gfc_error ("COMMON variable '%s' at %L must have constant " "character length", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; - return FAILURE; + return false; } } } @@ -10755,7 +10746,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) { gfc_error (auto_save_msg, sym->name, &sym->declared_at); specification_expr = saved_specification_expr; - return FAILURE; + return false; } } @@ -10789,47 +10780,47 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) else goto no_init_error; specification_expr = saved_specification_expr; - return FAILURE; + return false; } no_init_error: if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) { - gfc_try res = resolve_fl_variable_derived (sym, no_init_flag); + bool res = resolve_fl_variable_derived (sym, no_init_flag); specification_expr = saved_specification_expr; return res; } specification_expr = saved_specification_expr; - return SUCCESS; + return true; } /* Resolve a procedure. */ -static gfc_try +static bool resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_formal_arglist *arg; if (sym->attr.function - && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) - return FAILURE; + && !resolve_fl_var_and_proc (sym, mp_flag)) + return false; if (sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.u.cl; if (cl && cl->length && gfc_is_constant_expr (cl->length) - && resolve_charlen (cl) == FAILURE) - return FAILURE; + && !resolve_charlen (cl)) + return false; if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) && sym->attr.proc == PROC_ST_FUNCTION) { gfc_error ("Character-valued statement function '%s' at %L must " "have constant length", sym->name, &sym->declared_at); - return FAILURE; + return false; } } @@ -10849,15 +10840,15 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "'%s' is of a " - "PRIVATE type and cannot be a dummy argument" - " of '%s', which is PUBLIC at %L", - arg->sym->name, sym->name, &sym->declared_at) - == FAILURE) + && !gfc_notify_std (GFC_STD_F2003, "'%s' is of a PRIVATE type " + "and cannot be a dummy argument" + " of '%s', which is PUBLIC at %L", + arg->sym->name, sym->name, + &sym->declared_at)) { /* Stop this message from recurring. */ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; - return FAILURE; + return false; } } @@ -10871,16 +10862,16 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Procedure " - "'%s' in PUBLIC interface '%s' at %L " - "takes dummy arguments of '%s' which is " - "PRIVATE", iface->sym->name, sym->name, - &iface->sym->declared_at, - gfc_typename (&arg->sym->ts)) == FAILURE) + && !gfc_notify_std (GFC_STD_F2003, "Procedure '%s' in " + "PUBLIC interface '%s' at %L " + "takes dummy arguments of '%s' which " + "is PRIVATE", iface->sym->name, + sym->name, &iface->sym->declared_at, + gfc_typename(&arg->sym->ts))) { /* Stop this message from recurring. */ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; - return FAILURE; + return false; } } } @@ -10895,16 +10886,16 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Procedure " - "'%s' in PUBLIC interface '%s' at %L " - "takes dummy arguments of '%s' which is " - "PRIVATE", iface->sym->name, sym->name, - &iface->sym->declared_at, - gfc_typename (&arg->sym->ts)) == FAILURE) + && !gfc_notify_std (GFC_STD_F2003, "Procedure '%s' in " + "PUBLIC interface '%s' at %L takes " + "dummy arguments of '%s' which is " + "PRIVATE", iface->sym->name, + sym->name, &iface->sym->declared_at, + gfc_typename(&arg->sym->ts))) { /* Stop this message from recurring. */ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; - return FAILURE; + return false; } } } @@ -10915,7 +10906,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_error ("Function '%s' at %L cannot have an initializer", sym->name, &sym->declared_at); - return FAILURE; + return false; } /* An external symbol may not have an initializer because it is taken to be @@ -10924,7 +10915,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_error ("External object '%s' at %L may not have an initializer", sym->name, &sym->declared_at); - return FAILURE; + return false; } /* An elemental function is required to return a scalar 12.7.1 */ @@ -10934,7 +10925,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) "result", sym->name, &sym->declared_at); /* Reset so that the error only occurs once. */ sym->attr.elemental = 0; - return FAILURE; + return false; } if (sym->attr.proc == PROC_ST_FUNCTION @@ -10942,7 +10933,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_error ("Statement function '%s' at %L may not have pointer or " "allocatable attribute", sym->name, &sym->declared_at); - return FAILURE; + return false; } /* 5.1.1.5 of the Standard: A function name declared with an asterisk @@ -10974,7 +10965,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) gfc_error ("CHARACTER(*) function '%s' at %L cannot be " "recursive", sym->name, &sym->declared_at); - return FAILURE; + return false; } /* Appendix B.2 of the standard. Contained functions give an @@ -10993,8 +10984,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) gfc_formal_arglist *curr_arg; int has_non_interop_arg = 0; - if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, - sym->common_block) == FAILURE) + if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, + sym->common_block)) { /* Clear these to prevent looking at them again if there was an error. */ @@ -11014,7 +11005,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { /* Skip implicitly typed dummy args here. */ if (curr_arg->sym->attr.implicit_type == 0) - if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE) + if (!gfc_verify_c_interop_param (curr_arg->sym)) /* If something is found to fail, record the fact so we can mark the symbol for the procedure as not being BIND(C) to try and prevent multiple errors being @@ -11040,19 +11031,19 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; + return false; } if (sym->attr.intent) { gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; + return false; } if (sym->attr.subroutine && sym->attr.result) { gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; + return false; } if (sym->attr.external && sym->attr.function && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) @@ -11060,18 +11051,18 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; + return false; } if (strcmp ("ppr@", sym->name) == 0) { gfc_error ("Procedure pointer result '%s' at %L " "is missing the pointer attribute", sym->ns->proc_name->name, &sym->declared_at); - return FAILURE; + return false; } } - return SUCCESS; + return true; } @@ -11079,16 +11070,16 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) been defined and we now know their defined arguments, check that they fulfill the requirements of the standard for procedures used as finalizers. */ -static gfc_try +static bool gfc_resolve_finalizers (gfc_symbol* derived) { gfc_finalizer* list; gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ - gfc_try result = SUCCESS; + bool result = true; bool seen_scalar = false; if (!derived->f2k_derived || !derived->f2k_derived->finalizers) - return SUCCESS; + return true; /* Walk over the list of finalizer-procedures, check them, and if any one does not fit in with the standard's definition, print an error and remove @@ -11210,7 +11201,7 @@ gfc_resolve_finalizers (gfc_symbol* derived) /* Remove wrong nodes immediately from the list so we don't risk any troubles in the future when they might fail later expectations. */ error: - result = FAILURE; + result = false; i = list; *prev_link = list->next; gfc_free_finalizer (i); @@ -11219,7 +11210,7 @@ error: /* Warn if we haven't seen a scalar finalizer procedure (but we know there were nodes in the list, must have been for arrays. It is surely a good idea to have a scalar version there if there's something to finalize. */ - if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar) + if (gfc_option.warn_surprising && result && !seen_scalar) gfc_warning ("Only array FINAL procedures declared for derived type '%s'" " defined at %L, suggest also scalar one", derived->name, &derived->declared_at); @@ -11235,7 +11226,7 @@ error: /* Check if two GENERIC targets are ambiguous and emit an error is they are. */ -static gfc_try +static bool check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, const char* generic_name, locus where) { @@ -11251,7 +11242,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, sym2 = t2->specific->u.specific->n.sym; if (sym1 == sym2) - return SUCCESS; + return true; /* Both must be SUBROUTINEs or both must be FUNCTIONs. */ if (sym1->attr.subroutine != sym2->attr.subroutine @@ -11260,7 +11251,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for" " GENERIC '%s' at %L", sym1->name, sym2->name, generic_name, &where); - return FAILURE; + return false; } /* Compare the interfaces. */ @@ -11281,10 +11272,10 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, { gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous", sym1->name, sym2->name, generic_name, &where); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -11296,7 +11287,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, tb_uop_root or tb_op, respectively. Thus the caller must already find the super-type and set p->overridden correctly. */ -static gfc_try +static bool resolve_tb_generic_targets (gfc_symbol* super_type, gfc_typebound_proc* p, const char* name) { @@ -11340,7 +11331,7 @@ resolve_tb_generic_targets (gfc_symbol* super_type, gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'" " at %L", target_name, name, &p->where); - return FAILURE; + return false; /* Once we've found the specific binding, check it is not ambiguous with other specifics already found or inherited for the same GENERIC. */ @@ -11352,15 +11343,14 @@ specific_found: { gfc_error ("GENERIC '%s' at %L must target a specific binding," " '%s' is GENERIC, too", name, &p->where, target_name); - return FAILURE; + return false; } /* Check those already resolved on this type directly. */ for (g = p->u.generic; g; g = g->next) if (g != target && g->specific - && check_generic_tbp_ambiguity (target, g, name, p->where) - == FAILURE) - return FAILURE; + && !check_generic_tbp_ambiguity (target, g, name, p->where)) + return false; /* Check for ambiguity with inherited specific targets. */ for (overridden_tbp = p->overridden; overridden_tbp; @@ -11370,9 +11360,8 @@ specific_found: for (g = overridden_tbp->u.generic; g; g = g->next) { gcc_assert (g->specific); - if (check_generic_tbp_ambiguity (target, g, - name, p->where) == FAILURE) - return FAILURE; + if (!check_generic_tbp_ambiguity (target, g, name, p->where)) + return false; } } } @@ -11382,7 +11371,7 @@ specific_found: { gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with" " the same name", name, &p->where); - return FAILURE; + return false; } /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as @@ -11392,13 +11381,13 @@ specific_found: p->subroutine = first_target->n.sym->attr.subroutine; p->function = first_target->n.sym->attr.function; - return SUCCESS; + return true; } /* Resolve a GENERIC procedure binding for a derived type. */ -static gfc_try +static bool resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) { gfc_symbol* super_type; @@ -11446,7 +11435,7 @@ get_checked_tb_operator_target (gfc_tbp_generic* target, locus where) /* Resolve a type-bound intrinsic operator. */ -static gfc_try +static bool resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, gfc_typebound_proc* p) { @@ -11455,7 +11444,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, /* If there's already an error here, do nothing (but don't fail again). */ if (p->error) - return SUCCESS; + return true; /* Operators should always be GENERIC bindings. */ gcc_assert (p->is_generic); @@ -11469,7 +11458,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, p->overridden = NULL; /* Resolve general GENERIC properties using worker function. */ - if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE) + if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op))) goto error; /* Check the targets to be procedures of correct interface. */ @@ -11489,9 +11478,8 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns) { gfc_interface *head, *intr; - if (gfc_check_new_interface (derived->ns->op[op], target_proc, - p->where) == FAILURE) - return FAILURE; + if (!gfc_check_new_interface (derived->ns->op[op], target_proc, p->where)) + return false; head = derived->ns->op[op]; intr = gfc_get_interface (); intr->sym = target_proc; @@ -11501,20 +11489,20 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, } } - return SUCCESS; + return true; error: p->error = 1; - return FAILURE; + return false; } /* Resolve a type-bound user operator (tree-walker callback). */ static gfc_symbol* resolve_bindings_derived; -static gfc_try resolve_bindings_result; +static bool resolve_bindings_result; -static gfc_try check_uop_procedure (gfc_symbol* sym, locus where); +static bool check_uop_procedure (gfc_symbol* sym, locus where); static void resolve_typebound_user_op (gfc_symtree* stree) @@ -11545,8 +11533,7 @@ resolve_typebound_user_op (gfc_symtree* stree) stree->n.tb->overridden = NULL; /* Resolve basically using worker function. */ - if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name) - == FAILURE) + if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)) goto error; /* Check the targets to be functions of correct interface. */ @@ -11558,14 +11545,14 @@ resolve_typebound_user_op (gfc_symtree* stree) if (!target_proc) goto error; - if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE) + if (!check_uop_procedure (target_proc, stree->n.tb->where)) goto error; } return; error: - resolve_bindings_result = FAILURE; + resolve_bindings_result = false; stree->n.tb->error = 1; } @@ -11593,8 +11580,7 @@ resolve_typebound_procedure (gfc_symtree* stree) /* If this is a GENERIC binding, use that routine. */ if (stree->n.tb->is_generic) { - if (resolve_typebound_generic (resolve_bindings_derived, stree) - == FAILURE) + if (!resolve_typebound_generic (resolve_bindings_derived, stree)) goto error; return; } @@ -11610,7 +11596,7 @@ resolve_typebound_procedure (gfc_symtree* stree) if (stree->n.tb->deferred) { - if (check_proc_interface (proc, &where) == FAILURE) + if (!check_proc_interface (proc, &where)) goto error; } else @@ -11740,7 +11726,7 @@ resolve_typebound_procedure (gfc_symtree* stree) if (overridden->n.tb) stree->n.tb->overridden = overridden->n.tb; - if (gfc_check_typebound_override (stree, overridden) == FAILURE) + if (!gfc_check_typebound_override (stree, overridden)) goto error; } } @@ -11768,26 +11754,26 @@ resolve_typebound_procedure (gfc_symtree* stree) return; error: - resolve_bindings_result = FAILURE; + resolve_bindings_result = false; stree->n.tb->error = 1; } -static gfc_try +static bool resolve_typebound_procedures (gfc_symbol* derived) { int op; gfc_symbol* super_type; if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) - return SUCCESS; + return true; super_type = gfc_get_derived_super_type (derived); if (super_type) resolve_symbol (super_type); resolve_bindings_derived = derived; - resolve_bindings_result = SUCCESS; + resolve_bindings_result = true; /* Make sure the vtab has been generated. */ gfc_find_derived_vtab (derived); @@ -11803,9 +11789,9 @@ resolve_typebound_procedures (gfc_symbol* derived) for (op = 0; op != GFC_INTRINSIC_OPS; ++op) { gfc_typebound_proc* p = derived->f2k_derived->tb_op[op]; - if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op, - p) == FAILURE) - resolve_bindings_result = FAILURE; + if (p && !resolve_typebound_intrinsic_op (derived, + (gfc_intrinsic_op)op, p)) + resolve_bindings_result = false; } return resolve_bindings_result; @@ -11833,37 +11819,37 @@ add_dt_to_dt_list (gfc_symbol *derived) /* Ensure that a derived-type is really not abstract, meaning that every inherited DEFERRED binding is overridden by a non-DEFERRED one. */ -static gfc_try +static bool ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) { if (!st) - return SUCCESS; + return true; - if (ensure_not_abstract_walker (sub, st->left) == FAILURE) - return FAILURE; - if (ensure_not_abstract_walker (sub, st->right) == FAILURE) - return FAILURE; + if (!ensure_not_abstract_walker (sub, st->left)) + return false; + if (!ensure_not_abstract_walker (sub, st->right)) + return false; if (st->n.tb && st->n.tb->deferred) { gfc_symtree* overriding; overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); if (!overriding) - return FAILURE; + return false; gcc_assert (overriding->n.tb); if (overriding->n.tb->deferred) { gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because" " '%s' is DEFERRED and not overridden", sub->name, &sub->declared_at, st->name); - return FAILURE; + return false; } } - return SUCCESS; + return true; } -static gfc_try +static bool ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) { /* The algorithm used here is to recursively travel up the ancestry of sub @@ -11876,15 +11862,15 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) gcc_assert (ancestor && !sub->attr.abstract); if (!ancestor->attr.abstract) - return SUCCESS; + return true; /* Walk bindings of this ancestor. */ if (ancestor->f2k_derived) { - gfc_try t; + bool t; t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root); - if (t == FAILURE) - return FAILURE; + if (!t) + return false; } /* Find next ancestor type and recurse on it. */ @@ -11892,7 +11878,7 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) if (ancestor) return ensure_not_abstract (sub, ancestor); - return SUCCESS; + return true; } @@ -11937,14 +11923,14 @@ check_defined_assignments (gfc_symbol *derived) resolution stage, but can be done as soon as the dt declaration has been parsed. */ -static gfc_try +static bool resolve_fl_derived0 (gfc_symbol *sym) { gfc_symbol* super_type; gfc_component *c; if (sym->attr.unlimited_polymorphic) - return SUCCESS; + return true; super_type = gfc_get_derived_super_type (sym); @@ -11954,19 +11940,19 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_error ("As extending type '%s' at %L has a coarray component, " "parent type '%s' shall also have one", sym->name, &sym->declared_at, super_type->name); - return FAILURE; + return false; } /* Ensure the extended type gets resolved before we do. */ - if (super_type && resolve_fl_derived0 (super_type) == FAILURE) - return FAILURE; + if (super_type && !resolve_fl_derived0 (super_type)) + return false; /* An ABSTRACT type must be extensible. */ if (sym->attr.abstract && !gfc_type_is_extensible (sym)) { gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT", sym->name, &sym->declared_at); - return FAILURE; + return false; } c = (sym->attr.is_class) ? sym->components->ts.u.derived->components @@ -11982,7 +11968,7 @@ resolve_fl_derived0 (gfc_symbol *sym) { gfc_error ("Deferred-length character component '%s' at %L is not " "yet supported", c->name, &c->loc); - return FAILURE; + return false; } /* F2008, C442. */ @@ -11992,7 +11978,7 @@ resolve_fl_derived0 (gfc_symbol *sym) { gfc_error ("Coarray component '%s' at %L must be allocatable with " "deferred shape", c->name, &c->loc); - return FAILURE; + return false; } /* F2008, C443. */ @@ -12001,7 +11987,7 @@ resolve_fl_derived0 (gfc_symbol *sym) { gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " "shall not be a coarray", c->name, &c->loc); - return FAILURE; + return false; } /* F2008, C444. */ @@ -12012,7 +11998,7 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_error ("Component '%s' at %L with coarray component " "shall be a nonpointer, nonallocatable scalar", c->name, &c->loc); - return FAILURE; + return false; } /* F2008, C448. */ @@ -12020,7 +12006,7 @@ resolve_fl_derived0 (gfc_symbol *sym) { gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " "is not an array pointer", c->name, &c->loc); - return FAILURE; + return false; } if (c->attr.proc_pointer && c->ts.interface) @@ -12028,8 +12014,8 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_symbol *ifc = c->ts.interface; if (!sym->attr.vtype - && check_proc_interface (ifc, &c->loc) == FAILURE) - return FAILURE; + && !check_proc_interface (ifc, &c->loc)) + return false; if (ifc->attr.if_source || ifc->attr.intrinsic) { @@ -12071,8 +12057,8 @@ resolve_fl_derived0 (gfc_symbol *sym) { gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); if (cl->length && !cl->resolved - && gfc_resolve_expr (cl->length) == FAILURE) - return FAILURE; + && !gfc_resolve_expr (cl->length)) + return false; c->ts.u.cl = cl; } } @@ -12115,7 +12101,7 @@ resolve_fl_derived0 (gfc_symbol *sym) "at %L has no argument '%s'", c->name, c->tb->pass_arg, &c->loc, c->tb->pass_arg); c->tb->error = 1; - return FAILURE; + return false; } } else @@ -12129,7 +12115,7 @@ resolve_fl_derived0 (gfc_symbol *sym) "must have at least one argument", c->name, &c->loc); c->tb->error = 1; - return FAILURE; + return false; } me_arg = c->ts.interface->formal->sym; } @@ -12145,7 +12131,7 @@ resolve_fl_derived0 (gfc_symbol *sym) " the derived type '%s'", me_arg->name, c->name, me_arg->name, &c->loc, sym->name); c->tb->error = 1; - return FAILURE; + return false; } /* Check for C453. */ @@ -12155,7 +12141,7 @@ resolve_fl_derived0 (gfc_symbol *sym) "must be scalar", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; - return FAILURE; + return false; } if (me_arg->attr.pointer) @@ -12164,7 +12150,7 @@ resolve_fl_derived0 (gfc_symbol *sym) "may not have the POINTER attribute", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; - return FAILURE; + return false; } if (me_arg->attr.allocatable) @@ -12173,7 +12159,7 @@ resolve_fl_derived0 (gfc_symbol *sym) "may not be ALLOCATABLE", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; - return FAILURE; + return false; } if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) @@ -12189,8 +12175,8 @@ resolve_fl_derived0 (gfc_symbol *sym) || (!sym->attr.is_class && (!sym->attr.extension || c != sym->components))) && !sym->attr.vtype - && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) - return FAILURE; + && !resolve_typespec_used (&c->ts, &c->loc, c->name)) + return false; /* If this type is an extension, set the accessibility of the parent component. */ @@ -12209,21 +12195,21 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_error ("Component '%s' of '%s' at %L has the same name as an" " inherited type-bound procedure", c->name, sym->name, &c->loc); - return FAILURE; + return false; } if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer && !c->ts.deferred) { if (c->ts.u.cl->length == NULL - || (resolve_charlen (c->ts.u.cl) == FAILURE) + || (!resolve_charlen(c->ts.u.cl)) || !gfc_is_constant_expr (c->ts.u.cl->length)) { gfc_error ("Character length of component '%s' needs to " "be a constant specification expression at %L", c->name, c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); - return FAILURE; + return false; } } @@ -12233,7 +12219,7 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_error ("Character component '%s' of '%s' at %L with deferred " "length must be a POINTER or ALLOCATABLE", c->name, sym->name, &c->loc); - return FAILURE; + return false; } if (c->ts.type == BT_DERIVED @@ -12242,17 +12228,17 @@ resolve_fl_derived0 (gfc_symbol *sym) && !is_sym_host_assoc (c->ts.u.derived, sym->ns) && !c->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (c->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "the component '%s' " - "is a PRIVATE type and cannot be a component of " - "'%s', which is PUBLIC at %L", c->name, - sym->name, &sym->declared_at) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2003, "the component '%s' is a " + "PRIVATE type and cannot be a component of " + "'%s', which is PUBLIC at %L", c->name, + sym->name, &sym->declared_at)) + return false; if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) { gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " "type %s", c->name, &c->loc, sym->name); - return FAILURE; + return false; } if (sym->attr.sequence) @@ -12262,7 +12248,7 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_error ("Component %s of SEQUENCE type declared at %L does " "not have the SEQUENCE attribute", c->ts.u.derived->name, &sym->declared_at); - return FAILURE; + return false; } } @@ -12280,7 +12266,7 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_error ("The pointer component '%s' of '%s' at %L is a type " "that has not been declared", c->name, sym->name, &c->loc); - return FAILURE; + return false; } if (c->ts.type == BT_CLASS && c->attr.class_ok @@ -12292,7 +12278,7 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_error ("The pointer component '%s' of '%s' at %L is a type " "that has not been declared", c->name, sym->name, &c->loc); - return FAILURE; + return false; } /* C437. */ @@ -12305,7 +12291,7 @@ resolve_fl_derived0 (gfc_symbol *sym) "or pointer", c->name, &c->loc); /* Prevent a recurrence of the error. */ c->ts.type = BT_UNKNOWN; - return FAILURE; + return false; } /* Ensure that all the derived type components are put on the @@ -12318,14 +12304,14 @@ resolve_fl_derived0 (gfc_symbol *sym) && sym != c->ts.u.derived) add_dt_to_dt_list (c->ts.u.derived); - if (gfc_resolve_array_spec (c->as, !(c->attr.pointer - || c->attr.proc_pointer - || c->attr.allocatable)) == FAILURE) - return FAILURE; + if (!gfc_resolve_array_spec (c->as, + !(c->attr.pointer || c->attr.proc_pointer + || c->attr.allocatable))) + return false; if (c->initializer && !sym->attr.vtype - && gfc_check_assign_symbol (sym, c, c->initializer) == FAILURE) - return FAILURE; + && !gfc_check_assign_symbol (sym, c, c->initializer)) + return false; } check_defined_assignments (sym); @@ -12338,8 +12324,8 @@ resolve_fl_derived0 (gfc_symbol *sym) all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract && !sym->attr.is_class - && ensure_not_abstract (sym, super_type) == FAILURE) - return FAILURE; + && !ensure_not_abstract (sym, super_type)) + return false; /* Add derived type to the derived type list. */ add_dt_to_dt_list (sym); @@ -12348,7 +12334,7 @@ resolve_fl_derived0 (gfc_symbol *sym) finalization wrapper is generated early enough. */ gfc_is_finalizable (sym, NULL); - return SUCCESS; + return true; } @@ -12357,34 +12343,34 @@ resolve_fl_derived0 (gfc_symbol *sym) to 'resolve_fl_derived0' this can only be done after the module has been parsed completely. */ -static gfc_try +static bool resolve_fl_derived (gfc_symbol *sym) { gfc_symbol *gen_dt = NULL; if (sym->attr.unlimited_polymorphic) - return SUCCESS; + return true; if (!sym->attr.is_class) gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); if (gen_dt && gen_dt->generic && gen_dt->generic->next && (!gen_dt->generic->sym->attr.use_assoc || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) - && gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of " - "function '%s' at %L being the same name as derived " - "type at %L", sym->name, - gen_dt->generic->sym == sym - ? gen_dt->generic->next->sym->name - : gen_dt->generic->sym->name, - gen_dt->generic->sym == sym - ? &gen_dt->generic->next->sym->declared_at - : &gen_dt->generic->sym->declared_at, - &sym->declared_at) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of function " + "'%s' at %L being the same name as derived " + "type at %L", sym->name, + gen_dt->generic->sym == sym + ? gen_dt->generic->next->sym->name + : gen_dt->generic->sym->name, + gen_dt->generic->sym == sym + ? &gen_dt->generic->next->sym->declared_at + : &gen_dt->generic->sym->declared_at, + &sym->declared_at)) + return false; /* Resolve the finalizer procedures. */ - if (gfc_resolve_finalizers (sym) == FAILURE) - return FAILURE; + if (!gfc_resolve_finalizers (sym)) + return false; if (sym->attr.is_class && sym->ts.u.derived == NULL) { @@ -12394,7 +12380,7 @@ resolve_fl_derived (gfc_symbol *sym) /* Nothing more to do for unlimited polymorphic entities. */ if (data->ts.u.derived->attr.unlimited_polymorphic) - return SUCCESS; + return true; else if (vptr->ts.u.derived == NULL) { gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); @@ -12403,18 +12389,18 @@ resolve_fl_derived (gfc_symbol *sym) } } - if (resolve_fl_derived0 (sym) == FAILURE) - return FAILURE; + if (!resolve_fl_derived0 (sym)) + return false; /* Resolve the type-bound procedures. */ - if (resolve_typebound_procedures (sym) == FAILURE) - return FAILURE; + if (!resolve_typebound_procedures (sym)) + return false; - return SUCCESS; + return true; } -static gfc_try +static bool resolve_fl_namelist (gfc_symbol *sym) { gfc_namelist *nl; @@ -12428,31 +12414,29 @@ resolve_fl_namelist (gfc_symbol *sym) { gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not " "allowed", nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; + return false; } if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_F2003, "NAMELIST array " - "object '%s' with assumed shape in namelist " - "'%s' at %L", nl->sym->name, sym->name, - &sym->declared_at) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' " + "with assumed shape in namelist '%s' at %L", + nl->sym->name, sym->name, &sym->declared_at)) + return false; if (is_non_constant_shape_array (nl->sym) - && gfc_notify_std (GFC_STD_F2003, "NAMELIST array " - "object '%s' with nonconstant shape in namelist " - "'%s' at %L", nl->sym->name, sym->name, - &sym->declared_at) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' " + "with nonconstant shape in namelist '%s' at %L", + nl->sym->name, sym->name, &sym->declared_at)) + return false; if (nl->sym->ts.type == BT_CHARACTER && (nl->sym->ts.u.cl->length == NULL || !gfc_is_constant_expr (nl->sym->ts.u.cl->length)) - && gfc_notify_std (GFC_STD_F2003, "NAMELIST object " - "'%s' with nonconstant character length in " - "namelist '%s' at %L", nl->sym->name, sym->name, - &sym->declared_at) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object '%s' with " + "nonconstant character length in " + "namelist '%s' at %L", nl->sym->name, + sym->name, &sym->declared_at)) + return false; /* FIXME: Once UDDTIO is implemented, the following can be removed. */ @@ -12461,18 +12445,18 @@ resolve_fl_namelist (gfc_symbol *sym) gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is " "polymorphic and requires a defined input/output " "procedure", nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; + return false; } if (nl->sym->ts.type == BT_DERIVED && (nl->sym->ts.u.derived->attr.alloc_comp || nl->sym->ts.u.derived->attr.pointer_comp)) { - if (gfc_notify_std (GFC_STD_F2003, "NAMELIST object " - "'%s' in namelist '%s' at %L with ALLOCATABLE " - "or POINTER components", nl->sym->name, - sym->name, &sym->declared_at) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object '%s' in " + "namelist '%s' at %L with ALLOCATABLE " + "or POINTER components", nl->sym->name, + sym->name, &sym->declared_at)) + return false; /* FIXME: Once UDDTIO is implemented, the following can be removed. */ @@ -12480,7 +12464,7 @@ resolve_fl_namelist (gfc_symbol *sym) "ALLOCATABLE or POINTER components and thus requires " "a defined input/output procedure", nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; + return false; } } @@ -12496,7 +12480,7 @@ resolve_fl_namelist (gfc_symbol *sym) gfc_error ("NAMELIST object '%s' was declared PRIVATE and " "cannot be member of PUBLIC namelist '%s' at %L", nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; + return false; } /* Types with private components that came here by USE-association. */ @@ -12506,7 +12490,7 @@ resolve_fl_namelist (gfc_symbol *sym) gfc_error ("NAMELIST object '%s' has use-associated PRIVATE " "components and cannot be member of namelist '%s' at %L", nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; + return false; } /* Types with private components that are defined in the same module. */ @@ -12517,7 +12501,7 @@ resolve_fl_namelist (gfc_symbol *sym) gfc_error ("NAMELIST object '%s' has PRIVATE components and " "cannot be a member of PUBLIC namelist '%s' at %L", nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; + return false; } } } @@ -12544,15 +12528,15 @@ resolve_fl_namelist (gfc_symbol *sym) gfc_error ("PROCEDURE attribute conflicts with NAMELIST " "attribute in '%s' at %L", nlsym->name, &sym->declared_at); - return FAILURE; + return false; } } - return SUCCESS; + return true; } -static gfc_try +static bool resolve_fl_parameter (gfc_symbol *sym) { /* A parameter array's shape needs to be constant. */ @@ -12562,7 +12546,7 @@ resolve_fl_parameter (gfc_symbol *sym) { gfc_error ("Parameter array '%s' at %L cannot be automatic " "or of deferred shape", sym->name, &sym->declared_at); - return FAILURE; + return false; } /* Make sure a parameter that has been implicitly typed still @@ -12574,7 +12558,7 @@ resolve_fl_parameter (gfc_symbol *sym) { gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a " "later IMPLICIT type", sym->name, &sym->declared_at); - return FAILURE; + return false; } /* Make sure the types of derived parameters are consistent. This @@ -12585,9 +12569,9 @@ resolve_fl_parameter (gfc_symbol *sym) { gfc_error ("Incompatible derived type in PARAMETER at %L", &sym->value->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -12659,7 +12643,7 @@ resolve_symbol (gfc_symbol *sym) gfc_add_function (&sym->attr, sym->name, &sym->declared_at); if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL - && resolve_procedure_interface (sym) == FAILURE) + && !resolve_procedure_interface (sym)) return; if (sym->attr.is_protected && !sym->attr.proc_pointer @@ -12675,7 +12659,7 @@ resolve_symbol (gfc_symbol *sym) return; } - if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) + if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym)) return; /* Symbols that are module procedures with results (functions) have @@ -12689,7 +12673,7 @@ resolve_symbol (gfc_symbol *sym) representation. This needs to be done before assigning a default type to avoid spurious warnings. */ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic - && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE) + && !gfc_resolve_intrinsic (sym, &sym->declared_at)) return; /* Resolve associate names. */ @@ -12897,7 +12881,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.use_assoc == 0 && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED) { - gfc_try t = SUCCESS; + bool t = true; /* First, make sure the variable is declared at the module-level scope (J3/04-007, Section 15.3). */ @@ -12907,7 +12891,7 @@ resolve_symbol (gfc_symbol *sym) gfc_error ("Variable '%s' at %L cannot be BIND(C) because it " "is neither a COMMON block nor declared at the " "module level scope", sym->name, &(sym->declared_at)); - t = FAILURE; + t = false; } else if (sym->common_head != NULL) { @@ -12926,7 +12910,7 @@ resolve_symbol (gfc_symbol *sym) of that type are declared. */ if (sym->ts.u.derived->attr.is_bind_c != 1) verify_bind_c_derived_type (sym->ts.u.derived); - t = FAILURE; + t = false; } /* Verify the variable itself as C interoperable if it @@ -12937,7 +12921,7 @@ resolve_symbol (gfc_symbol *sym) sym->common_block); } - if (t == FAILURE) + if (!t) { /* clear the is_bind_c flag to prevent reporting errors more than once if something failed. */ @@ -12972,7 +12956,7 @@ resolve_symbol (gfc_symbol *sym) && sym->ts.u.derived->attr.use_assoc && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE - && resolve_fl_derived (sym->ts.u.derived) == FAILURE) + && !resolve_fl_derived (sym->ts.u.derived)) return; /* Unless the derived-type declaration is use associated, Fortran 95 @@ -12984,11 +12968,12 @@ resolve_symbol (gfc_symbol *sym) && !sym->ts.u.derived->attr.use_assoc && gfc_check_symbol_access (sym) && !gfc_check_symbol_access (sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L " - "of PRIVATE derived type '%s'", - (sym->attr.flavor == FL_PARAMETER) ? "parameter" - : "variable", sym->name, &sym->declared_at, - sym->ts.u.derived->name) == FAILURE) + && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L of PRIVATE " + "derived type '%s'", + (sym->attr.flavor == FL_PARAMETER) + ? "parameter" : "variable", + sym->name, &sym->declared_at, + sym->ts.u.derived->name)) return; /* F2008, C1302. */ @@ -13128,41 +13113,40 @@ resolve_symbol (gfc_symbol *sym) if (gfc_logical_kinds[i].kind == sym->ts.kind) break; if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy - && gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at %L " - "with non-C_Bool kind in BIND(C) procedure '%s'", - sym->name, &sym->declared_at, - sym->ns->proc_name->name) == FAILURE) + && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at " + "%L with non-C_Bool kind in BIND(C) procedure " + "'%s'", sym->name, &sym->declared_at, + sym->ns->proc_name->name)) return; else if (!gfc_logical_kinds[i].c_bool - && gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable '%s' at" - " %L with non-C_Bool kind in BIND(C) " - "procedure '%s'", sym->name, - &sym->declared_at, - sym->attr.function ? sym->name - : sym->ns->proc_name->name) - == FAILURE) + && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable " + "'%s' at %L with non-C_Bool kind in " + "BIND(C) procedure '%s'", sym->name, + &sym->declared_at, + sym->attr.function ? sym->name + : sym->ns->proc_name->name)) return; } switch (sym->attr.flavor) { case FL_VARIABLE: - if (resolve_fl_variable (sym, mp_flag) == FAILURE) + if (!resolve_fl_variable (sym, mp_flag)) return; break; case FL_PROCEDURE: - if (resolve_fl_procedure (sym, mp_flag) == FAILURE) + if (!resolve_fl_procedure (sym, mp_flag)) return; break; case FL_NAMELIST: - if (resolve_fl_namelist (sym) == FAILURE) + if (!resolve_fl_namelist (sym)) return; break; case FL_PARAMETER: - if (resolve_fl_parameter (sym) == FAILURE) + if (!resolve_fl_parameter (sym)) return; break; @@ -13243,8 +13227,7 @@ resolve_symbol (gfc_symbol *sym) /* If this symbol has a type-spec, check it. */ if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) - if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name) - == FAILURE) + if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)) return; } @@ -13261,30 +13244,30 @@ values; /* Advance the values structure to point to the next value in the data list. */ -static gfc_try +static bool next_data_value (void) { while (mpz_cmp_ui (values.left, 0) == 0) { if (values.vnode->next == NULL) - return FAILURE; + return false; values.vnode = values.vnode->next; mpz_set (values.left, values.vnode->repeat); } - return SUCCESS; + return true; } -static gfc_try +static bool check_data_variable (gfc_data_variable *var, locus *where) { gfc_expr *e; mpz_t size; mpz_t offset; - gfc_try t; + bool t; ar_type mark = AR_UNKNOWN; int i; mpz_t section_index[GFC_MAX_DIMENSIONS]; @@ -13293,8 +13276,8 @@ check_data_variable (gfc_data_variable *var, locus *where) gfc_symbol *sym; int has_pointer; - if (gfc_resolve_expr (var->expr) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (var->expr)) + return false; ar = NULL; mpz_init_set_si (offset, 0); @@ -13315,7 +13298,7 @@ check_data_variable (gfc_data_variable *var, locus *where) { gfc_error ("DATA array '%s' at %L must be specified in a previous" " declaration", sym->name, where); - return FAILURE; + return false; } has_pointer = sym->attr.pointer; @@ -13324,7 +13307,7 @@ check_data_variable (gfc_data_variable *var, locus *where) { gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name, where); - return FAILURE; + return false; } for (ref = e->ref; ref; ref = ref->next) @@ -13338,7 +13321,7 @@ check_data_variable (gfc_data_variable *var, locus *where) { gfc_error ("DATA element '%s' at %L is a pointer and so must " "be a full array", sym->name, where); - return FAILURE; + return false; } } @@ -13380,29 +13363,29 @@ check_data_variable (gfc_data_variable *var, locus *where) gcc_unreachable (); } - if (gfc_array_size (e, &size) == FAILURE) + if (!gfc_array_size (e, &size)) { gfc_error ("Nonconstant array section at %L in DATA statement", &e->where); mpz_clear (offset); - return FAILURE; + return false; } } - t = SUCCESS; + t = true; while (mpz_cmp_ui (size, 0) > 0) { - if (next_data_value () == FAILURE) + if (!next_data_value ()) { gfc_error ("DATA statement at %L has more variables than values", where); - t = FAILURE; + t = false; break; } t = gfc_check_assign (var->expr, values.vnode->expr, 0); - if (t == FAILURE) + if (!t) break; /* If we have more than one element left in the repeat count, @@ -13434,7 +13417,7 @@ check_data_variable (gfc_data_variable *var, locus *where) mpz_add (offset, offset, range); mpz_clear (range); - if (t == FAILURE) + if (!t) break; } @@ -13446,7 +13429,7 @@ check_data_variable (gfc_data_variable *var, locus *where) t = gfc_assign_data_value (var->expr, values.vnode->expr, offset, NULL); - if (t == FAILURE) + if (!t) break; if (mark == AR_FULL) @@ -13472,17 +13455,17 @@ check_data_variable (gfc_data_variable *var, locus *where) } -static gfc_try traverse_data_var (gfc_data_variable *, locus *); +static bool traverse_data_var (gfc_data_variable *, locus *); /* Iterate over a list of elements in a DATA statement. */ -static gfc_try +static bool traverse_data_list (gfc_data_variable *var, locus *where) { mpz_t trip; iterator_stack frame; gfc_expr *e, *start, *end, *step; - gfc_try retval = SUCCESS; + bool retval = true; mpz_init (frame.value); mpz_init (trip); @@ -13491,28 +13474,28 @@ traverse_data_list (gfc_data_variable *var, locus *where) end = gfc_copy_expr (var->iter.end); step = gfc_copy_expr (var->iter.step); - if (gfc_simplify_expr (start, 1) == FAILURE + if (!gfc_simplify_expr (start, 1) || start->expr_type != EXPR_CONSTANT) { gfc_error ("start of implied-do loop at %L could not be " "simplified to a constant value", &start->where); - retval = FAILURE; + retval = false; goto cleanup; } - if (gfc_simplify_expr (end, 1) == FAILURE + if (!gfc_simplify_expr (end, 1) || end->expr_type != EXPR_CONSTANT) { gfc_error ("end of implied-do loop at %L could not be " "simplified to a constant value", &start->where); - retval = FAILURE; + retval = false; goto cleanup; } - if (gfc_simplify_expr (step, 1) == FAILURE + if (!gfc_simplify_expr (step, 1) || step->expr_type != EXPR_CONSTANT) { gfc_error ("step of implied-do loop at %L could not be " "simplified to a constant value", &start->where); - retval = FAILURE; + retval = false; goto cleanup; } @@ -13530,17 +13513,17 @@ traverse_data_list (gfc_data_variable *var, locus *where) while (mpz_cmp_ui (trip, 0) > 0) { - if (traverse_data_var (var->list, where) == FAILURE) + if (!traverse_data_var (var->list, where)) { - retval = FAILURE; + retval = false; goto cleanup; } e = gfc_copy_expr (var->expr); - if (gfc_simplify_expr (e, 1) == FAILURE) + if (!gfc_simplify_expr (e, 1)) { gfc_free_expr (e); - retval = FAILURE; + retval = false; goto cleanup; } @@ -13564,10 +13547,10 @@ cleanup: /* Type resolve variables in the variable list of a DATA statement. */ -static gfc_try +static bool traverse_data_var (gfc_data_variable *var, locus *where) { - gfc_try t; + bool t; for (; var; var = var->next) { @@ -13576,11 +13559,11 @@ traverse_data_var (gfc_data_variable *var, locus *where) else t = check_data_variable (var, where); - if (t == FAILURE) - return FAILURE; + if (!t) + return false; } - return SUCCESS; + return true; } @@ -13588,27 +13571,27 @@ traverse_data_var (gfc_data_variable *var, locus *where) This is separate from the assignment checking because data lists should only be resolved once. */ -static gfc_try +static bool resolve_data_variables (gfc_data_variable *d) { for (; d; d = d->next) { if (d->list == NULL) { - if (gfc_resolve_expr (d->expr) == FAILURE) - return FAILURE; + if (!gfc_resolve_expr (d->expr)) + return false; } else { - if (gfc_resolve_iterator (&d->iter, false, true) == FAILURE) - return FAILURE; + if (!gfc_resolve_iterator (&d->iter, false, true)) + return false; - if (resolve_data_variables (d->list) == FAILURE) - return FAILURE; + if (!resolve_data_variables (d->list)) + return false; } } - return SUCCESS; + return true; } @@ -13620,7 +13603,7 @@ static void resolve_data (gfc_data *d) { - if (resolve_data_variables (d->var) == FAILURE) + if (!resolve_data_variables (d->var)) return; values.vnode = d->value; @@ -13629,12 +13612,12 @@ resolve_data (gfc_data *d) else mpz_set (values.left, d->value->repeat); - if (traverse_data_var (d->var, &d->where) == FAILURE) + if (!traverse_data_var (d->var, &d->where)) return; /* At this point, we better not have any values left. */ - if (next_data_value () == SUCCESS) + if (next_data_value ()) gfc_error ("DATA statement at %L has more values than variables", &d->where); } @@ -13851,13 +13834,13 @@ sequence_type (gfc_typespec ts) /* Resolve derived type EQUIVALENCE object. */ -static gfc_try +static bool resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) { gfc_component *c = derived->components; if (!derived) - return SUCCESS; + return true; /* Shall not be an object of nonsequence derived type. */ if (!derived->attr.sequence) @@ -13865,7 +13848,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) gfc_error ("Derived type variable '%s' at %L must have SEQUENCE " "attribute to be an EQUIVALENCE object", sym->name, &e->where); - return FAILURE; + return false; } /* Shall not have allocatable components. */ @@ -13874,7 +13857,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE " "components to be an EQUIVALENCE object",sym->name, &e->where); - return FAILURE; + return false; } if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived)) @@ -13882,14 +13865,14 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) gfc_error ("Derived type variable '%s' at %L with default " "initialization cannot be in EQUIVALENCE with a variable " "in COMMON", sym->name, &e->where); - return FAILURE; + return false; } for (; c ; c = c->next) { if (c->ts.type == BT_DERIVED - && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE)) - return FAILURE; + && (!resolve_equivalence_derived(c->ts.u.derived, sym, e))) + return false; /* Shall not be an object of sequence derived type containing a pointer in the structure. */ @@ -13898,10 +13881,10 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) gfc_error ("Derived type variable '%s' at %L with pointer " "component(s) cannot be an EQUIVALENCE object", sym->name, &e->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } @@ -14004,7 +13987,7 @@ resolve_equivalence (gfc_equiv *eq) } } - if (gfc_resolve_expr (e) == FAILURE) + if (!gfc_resolve_expr (e)) continue; sym = e->symtree->n.sym; @@ -14040,7 +14023,7 @@ resolve_equivalence (gfc_equiv *eq) } if (e->ts.type == BT_DERIVED - && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE) + && !resolve_equivalence_derived (e->ts.u.derived, sym, e)) continue; /* Check that the types correspond correctly: @@ -14068,38 +14051,32 @@ resolve_equivalence (gfc_equiv *eq) "statement at %L with different type objects"; if ((object ==2 && last_eq_type == SEQ_MIXED - && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where) - == FAILURE) + && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) || (eq_type == SEQ_MIXED - && gfc_notify_std (GFC_STD_GNU, msg, sym->name, - &e->where) == FAILURE)) + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) continue; msg = "Non-default type object or sequence %s in EQUIVALENCE " "statement at %L with objects of different type"; if ((object ==2 && last_eq_type == SEQ_NONDEFAULT - && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, - last_where) == FAILURE) + && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) || (eq_type == SEQ_NONDEFAULT - && gfc_notify_std (GFC_STD_GNU, msg, sym->name, - &e->where) == FAILURE)) + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) continue; msg ="Non-CHARACTER object '%s' in default CHARACTER " "EQUIVALENCE statement at %L"; if (last_eq_type == SEQ_CHARACTER && eq_type != SEQ_CHARACTER - && gfc_notify_std (GFC_STD_GNU, msg, sym->name, - &e->where) == FAILURE) + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) continue; msg ="Non-NUMERIC object '%s' in default NUMERIC " "EQUIVALENCE statement at %L"; if (last_eq_type == SEQ_NUMERIC && eq_type != SEQ_NUMERIC - && gfc_notify_std (GFC_STD_GNU, msg, sym->name, - &e->where) == FAILURE) + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) continue; identical_types: @@ -14111,7 +14088,7 @@ resolve_equivalence (gfc_equiv *eq) /* Shall not be an automatic array. */ if (e->ref->type == REF_ARRAY - && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE) + && !gfc_resolve_array_spec (e->ref->u.ar.as, 1)) { gfc_error ("Array '%s' at %L with non-constant bounds cannot be " "an EQUIVALENCE object", sym->name, &e->where); @@ -14165,7 +14142,7 @@ resolve_fntype (gfc_namespace *ns) sym = ns->proc_name; if (sym->result == sym && sym->ts.type == BT_UNKNOWN - && gfc_set_default_type (sym, 0, NULL) == FAILURE + && !gfc_set_default_type (sym, 0, NULL) && !sym->attr.untyped) { gfc_error ("Function '%s' at %L has no IMPLICIT type", @@ -14188,7 +14165,7 @@ resolve_fntype (gfc_namespace *ns) { if (el->sym->result == el->sym && el->sym->ts.type == BT_UNKNOWN - && gfc_set_default_type (el->sym, 0, NULL) == FAILURE + && !gfc_set_default_type (el->sym, 0, NULL) && !el->sym->attr.untyped) { gfc_error ("ENTRY '%s' at %L has no IMPLICIT type", @@ -14201,7 +14178,7 @@ resolve_fntype (gfc_namespace *ns) /* 12.3.2.1.1 Defined operators. */ -static gfc_try +static bool check_uop_procedure (gfc_symbol *sym, locus where) { gfc_formal_arglist *formal; @@ -14210,7 +14187,7 @@ check_uop_procedure (gfc_symbol *sym, locus where) { gfc_error ("User operator procedure '%s' at %L must be a FUNCTION", sym->name, &where); - return FAILURE; + return false; } if (sym->ts.type == BT_CHARACTER @@ -14220,7 +14197,7 @@ check_uop_procedure (gfc_symbol *sym, locus where) { gfc_error ("User operator procedure '%s' at %L cannot be assumed " "character length", sym->name, &where); - return FAILURE; + return false; } formal = gfc_sym_get_dummy_args (sym); @@ -14228,49 +14205,49 @@ check_uop_procedure (gfc_symbol *sym, locus where) { gfc_error ("User operator procedure '%s' at %L must have at least " "one argument", sym->name, &where); - return FAILURE; + return false; } if (formal->sym->attr.intent != INTENT_IN) { gfc_error ("First argument of operator interface at %L must be " "INTENT(IN)", &where); - return FAILURE; + return false; } if (formal->sym->attr.optional) { gfc_error ("First argument of operator interface at %L cannot be " "optional", &where); - return FAILURE; + return false; } formal = formal->next; if (!formal || !formal->sym) - return SUCCESS; + return true; if (formal->sym->attr.intent != INTENT_IN) { gfc_error ("Second argument of operator interface at %L must be " "INTENT(IN)", &where); - return FAILURE; + return false; } if (formal->sym->attr.optional) { gfc_error ("Second argument of operator interface at %L cannot be " "optional", &where); - return FAILURE; + return false; } if (formal->next) { gfc_error ("Operator interface at %L must have, at most, two " "arguments", &where); - return FAILURE; + return false; } - return SUCCESS; + return true; } static void @@ -14310,9 +14287,8 @@ resolve_types (gfc_namespace *ns) unsigned letter; for (letter = 0; letter != GFC_LETTERS; ++letter) if (ns->set_flag[letter] - && resolve_typespec_used (&ns->default_type[letter], - &ns->implicit_loc[letter], - NULL) == FAILURE) + && !resolve_typespec_used (&ns->default_type[letter], + &ns->implicit_loc[letter], NULL)) return; } |