summaryrefslogtreecommitdiff
path: root/gcc/fortran/interface.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/interface.c')
-rw-r--r--gcc/fortran/interface.c322
1 files changed, 159 insertions, 163 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 5741911f0ae..2cadd8b0b2b 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -213,7 +213,7 @@ gfc_match_interface (void)
return MATCH_ERROR;
if (!sym->attr.generic
- && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
+ && !gfc_add_generic (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
if (sym->attr.dummy)
@@ -251,8 +251,7 @@ gfc_match_abstract_interface (void)
{
match m;
- if (gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
return MATCH_ERROR;
m = gfc_match_eos ();
@@ -326,23 +325,23 @@ gfc_match_end_interface (void)
/* The following if-statements are used to enforce C1202
from F2003. */
- if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
- || (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
+ if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0)
+ || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0))
break;
- if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
- || (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
+ if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0)
+ || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0))
break;
- if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
- || (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
+ if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0)
+ || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0))
break;
- if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
- || (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
+ if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0)
+ || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0))
break;
- if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
- || (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
+ if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0)
+ || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0))
break;
- if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
- || (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
+ if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0)
+ || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0))
break;
m = MATCH_ERROR;
@@ -1019,19 +1018,19 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
/* Check if the characteristics of two dummy arguments match,
cf. F08:12.3.2. */
-static gfc_try
+static bool
check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
bool type_must_agree, char *errmsg, int err_len)
{
if (s1 == NULL || s2 == NULL)
- return s1 == s2 ? SUCCESS : FAILURE;
+ return s1 == s2 ? true : false;
/* Check type and rank. */
if (type_must_agree && !compare_type_rank (s2, s1))
{
snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
s1->name);
- return FAILURE;
+ return false;
}
/* Check INTENT. */
@@ -1039,7 +1038,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
s1->name);
- return FAILURE;
+ return false;
}
/* Check OPTIONAL attribute. */
@@ -1047,7 +1046,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
s1->name);
- return FAILURE;
+ return false;
}
/* Check ALLOCATABLE attribute. */
@@ -1055,7 +1054,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
s1->name);
- return FAILURE;
+ return false;
}
/* Check POINTER attribute. */
@@ -1063,7 +1062,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
s1->name);
- return FAILURE;
+ return false;
}
/* Check TARGET attribute. */
@@ -1071,7 +1070,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
s1->name);
- return FAILURE;
+ return false;
}
/* FIXME: Do more comprehensive testing of attributes, like e.g.
@@ -1086,7 +1085,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
"'%s': %s", s1->name, err);
- return FAILURE;
+ return false;
}
}
@@ -1104,7 +1103,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Character length mismatch "
"in argument '%s'", s1->name);
- return FAILURE;
+ return false;
case -2:
/* FIXME: Implement a warning for this case.
@@ -1132,7 +1131,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
s1->name);
- return FAILURE;
+ return false;
}
if (s1->as->type == AS_EXPLICIT)
@@ -1152,7 +1151,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
"argument '%s'", i + 1, s1->name);
- return FAILURE;
+ return false;
case -2:
/* FIXME: Implement a warning for this case.
@@ -1172,14 +1171,14 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
}
}
- return SUCCESS;
+ return true;
}
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
-static gfc_try
+static bool
check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
@@ -1189,13 +1188,13 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
r2 = s2->result ? s2->result : s2;
if (r1->ts.type == BT_UNKNOWN)
- return SUCCESS;
+ return true;
/* Check type and rank. */
if (!compare_type_rank (r1, r2))
{
snprintf (errmsg, err_len, "Type/rank mismatch in function result");
- return FAILURE;
+ return false;
}
/* Check ALLOCATABLE attribute. */
@@ -1203,7 +1202,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
"function result");
- return FAILURE;
+ return false;
}
/* Check POINTER attribute. */
@@ -1211,7 +1210,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "POINTER attribute mismatch in "
"function result");
- return FAILURE;
+ return false;
}
/* Check CONTIGUOUS attribute. */
@@ -1219,7 +1218,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
"function result");
- return FAILURE;
+ return false;
}
/* Check PROCEDURE POINTER attribute. */
@@ -1227,7 +1226,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
"function result");
- return FAILURE;
+ return false;
}
/* Check string length. */
@@ -1237,7 +1236,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "Character length mismatch "
"in function result");
- return FAILURE;
+ return false;
}
if (r1->ts.u.cl->length)
@@ -1251,7 +1250,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Character length mismatch "
"in function result");
- return FAILURE;
+ return false;
case -2:
/* FIXME: Implement a warning for this case.
@@ -1279,7 +1278,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
if (r1->as->type != r2->as->type)
{
snprintf (errmsg, err_len, "Shape mismatch in function result");
- return FAILURE;
+ return false;
}
if (r1->as->type == AS_EXPLICIT)
@@ -1299,7 +1298,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
"function result", i + 1);
- return FAILURE;
+ return false;
case -2:
/* FIXME: Implement a warning for this case.
@@ -1318,7 +1317,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
}
}
- return SUCCESS;
+ return true;
}
@@ -1362,8 +1361,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check result characteristics. */
- if (check_result_characteristics (s1, s2, errmsg, err_len)
- == FAILURE)
+ if (!check_result_characteristics (s1, s2, errmsg, err_len))
return 0;
}
@@ -1423,8 +1421,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
if (strict_flag)
{
/* Check all characteristics. */
- if (check_dummy_characteristics (f1->sym, f2->sym,
- true, errmsg, err_len) == FAILURE)
+ if (!check_dummy_characteristics (f1->sym, f2->sym, true,
+ errmsg, err_len))
return 0;
}
else if (!compare_type_rank (f2->sym, f1->sym))
@@ -1491,9 +1489,9 @@ check_interface0 (gfc_interface *p, const char *interface_name)
/* F2003, C1207. F2008, C1207. */
if (p->sym->attr.proc == PROC_INTERNAL
- && gfc_notify_std (GFC_STD_F2008, "Internal procedure "
- "'%s' in %s at %L", p->sym->name, interface_name,
- &p->sym->declared_at) == FAILURE)
+ && !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
+ "'%s' in %s at %L", p->sym->name,
+ interface_name, &p->sym->declared_at))
return 1;
}
p = psave;
@@ -1879,7 +1877,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
gfc_add_function (&act_sym->attr, act_sym->name,
&act_sym->declared_at);
if (act_sym->ts.type == BT_UNKNOWN
- && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
+ && !gfc_set_default_type (act_sym, 1, act_sym->ns))
return 0;
}
else if (formal->attr.subroutine && !act_sym->attr.subroutine)
@@ -2478,7 +2476,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
/* Make sure that intrinsic vtables exist for calls to unlimited
polymorphic formal arguments. */
- if (UNLIMITED_POLY(f->sym)
+ if (UNLIMITED_POLY (f->sym)
&& a->expr->ts.type != BT_DERIVED
&& a->expr->ts.type != BT_CLASS)
gfc_find_intrinsic_vtab (&a->expr->ts);
@@ -2528,7 +2526,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
gfc_error ("Actual argument at %L to assumed-type dummy is of "
"derived type with type-bound or FINAL procedures",
&a->expr->where);
- return FAILURE;
+ return false;
}
}
@@ -2741,11 +2739,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
&& CLASS_DATA (f->sym)->attr.class_pointer)
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
- && gfc_check_vardef_context (a->expr, true, false, false, context)
- == FAILURE)
+ && !gfc_check_vardef_context (a->expr, true, false, false, context))
return 0;
- if (gfc_check_vardef_context (a->expr, false, false, false, context)
- == FAILURE)
+ if (!gfc_check_vardef_context (a->expr, false, false, false, context))
return 0;
}
@@ -2919,9 +2915,9 @@ pair_cmp (const void *p1, const void *p2)
/* Given two expressions from some actual arguments, test whether they
refer to the same expression. The analysis is conservative.
- Returning FAILURE will produce no warning. */
+ Returning false will produce no warning. */
-static gfc_try
+static bool
compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
{
const gfc_ref *r1, *r2;
@@ -2930,39 +2926,39 @@ compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
|| e1->expr_type != EXPR_VARIABLE
|| e2->expr_type != EXPR_VARIABLE
|| e1->symtree->n.sym != e2->symtree->n.sym)
- return FAILURE;
+ return false;
/* TODO: improve comparison, see expr.c:show_ref(). */
for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
{
if (r1->type != r2->type)
- return FAILURE;
+ return false;
switch (r1->type)
{
case REF_ARRAY:
if (r1->u.ar.type != r2->u.ar.type)
- return FAILURE;
+ return false;
/* TODO: At the moment, consider only full arrays;
we could do better. */
if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
- return FAILURE;
+ return false;
break;
case REF_COMPONENT:
if (r1->u.c.component != r2->u.c.component)
- return FAILURE;
+ return false;
break;
case REF_SUBSTRING:
- return FAILURE;
+ return false;
default:
gfc_internal_error ("compare_actual_expr(): Bad component code");
}
}
if (!r1 && !r2)
- return SUCCESS;
- return FAILURE;
+ return true;
+ return false;
}
@@ -2970,7 +2966,7 @@ compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
another, check that identical actual arguments aren't not
associated with some incompatible INTENTs. */
-static gfc_try
+static bool
check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f1_intent, f2_intent;
@@ -2978,7 +2974,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_actual_arglist *a1;
size_t n, i, j;
argpair *p;
- gfc_try t = SUCCESS;
+ bool t = true;
n = 0;
for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
@@ -3015,7 +3011,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_internal_error ("check_some_aliasing(): corrupted data");
/* Are the expression the same? */
- if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
+ if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
break;
f2_intent = p[j].f->sym->attr.intent;
if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
@@ -3026,7 +3022,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_intent_string (f1_intent), p[i].f->sym->name,
gfc_intent_string (f2_intent), p[j].f->sym->name,
&p[i].a->expr->where);
- t = FAILURE;
+ t = false;
}
}
}
@@ -3039,7 +3035,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
another, check that they are compatible in the sense that intents
are not mismatched. */
-static gfc_try
+static bool
check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f_intent;
@@ -3065,7 +3061,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Procedure argument at %L is local to a PURE "
"procedure and has the POINTER attribute",
&a->expr->where);
- return FAILURE;
+ return false;
}
}
@@ -3077,7 +3073,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Coindexed actual argument at %L in PURE procedure "
"is passed to an INTENT(%s) argument",
&a->expr->where, gfc_intent_string (f_intent));
- return FAILURE;
+ return false;
}
if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
@@ -3087,7 +3083,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Coindexed actual argument at %L in PURE procedure "
"is passed to a POINTER dummy argument",
&a->expr->where);
- return FAILURE;
+ return false;
}
}
@@ -3098,11 +3094,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Coindexed polymorphic actual argument at %L is passed "
"polymorphic dummy argument '%s'",
&a->expr->where, f->sym->name);
- return FAILURE;
+ return false;
}
}
- return SUCCESS;
+ return true;
}
@@ -3110,7 +3106,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
well, the actual argument list will also end up being properly
sorted. */
-gfc_try
+bool
gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
gfc_formal_arglist *dummy_args;
@@ -3139,7 +3135,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error("The pointer object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
- return FAILURE;
+ return false;
}
if (sym->attr.allocatable && !sym->attr.external)
@@ -3147,14 +3143,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error("The allocatable object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
- return FAILURE;
+ return false;
}
if (sym->attr.allocatable)
{
gfc_error("Allocatable function '%s' at %L must have an explicit "
"function interface", sym->name, where);
- return FAILURE;
+ return false;
}
for (a = *ap; a; a = a->next)
@@ -3194,7 +3190,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
&& a->expr->ts.type == BT_UNKNOWN)
{
gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
- return FAILURE;
+ return false;
}
/* TS 29113, C407b. */
@@ -3203,25 +3199,25 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
gfc_error ("Assumed-rank argument requires an explicit interface "
"at %L", &a->expr->where);
- return FAILURE;
+ return false;
}
}
- return SUCCESS;
+ return true;
}
dummy_args = gfc_sym_get_dummy_args (sym);
if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where))
- return FAILURE;
+ return false;
- if (check_intents (dummy_args, *ap) == FAILURE)
- return FAILURE;
+ if (!check_intents (dummy_args, *ap))
+ return false;
if (gfc_option.warn_aliasing)
check_some_aliasing (dummy_args, *ap);
- return SUCCESS;
+ return true;
}
@@ -3427,7 +3423,7 @@ matching_typebound_op (gfc_expr** tb_base,
{
gfc_typebound_proc* tb;
gfc_symbol* derived;
- gfc_try result;
+ bool result;
while (base->expr->expr_type == EXPR_OP
&& base->expr->value.op.op == INTRINSIC_PARENTHESES)
@@ -3462,7 +3458,7 @@ matching_typebound_op (gfc_expr** tb_base,
/* This means we hit a PRIVATE operator which is use-associated and
should thus not be seen. */
- if (result == FAILURE)
+ if (!result)
tb = NULL;
/* Look through the super-type hierarchy for a matching specific
@@ -3653,13 +3649,13 @@ gfc_extend_expr (gfc_expr *e)
a call to it and succeed. */
if (tbo)
{
- gfc_try result;
+ bool result;
gcc_assert (tb_base);
build_compcall_for_operator (e, actual, tb_base, tbo, gname);
result = gfc_resolve_expr (e);
- if (result == FAILURE)
+ if (!result)
return MATCH_ERROR;
return MATCH_YES;
@@ -3681,7 +3677,7 @@ gfc_extend_expr (gfc_expr *e)
e->value.function.name = NULL;
e->user_operator = 1;
- if (gfc_resolve_expr (e) == FAILURE)
+ if (!gfc_resolve_expr (e))
return MATCH_ERROR;
return MATCH_YES;
@@ -3690,10 +3686,10 @@ gfc_extend_expr (gfc_expr *e)
/* Tries to replace an assignment code node with a subroutine call to
the subroutine associated with the assignment operator. Return
- SUCCESS if the node was replaced. On FAILURE, no error is
+ true if the node was replaced. On false, no error is
generated. */
-gfc_try
+bool
gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gfc_actual_arglist *actual;
@@ -3711,7 +3707,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
&& (rhs->rank == 0 || rhs->rank == lhs->rank)
&& (lhs->ts.type == rhs->ts.type
|| (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
- return FAILURE;
+ return false;
actual = gfc_get_actual_arglist ();
actual->expr = lhs;
@@ -3753,12 +3749,12 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
/* c is resolved from the caller, so no need to do it here. */
- return SUCCESS;
+ return true;
}
free (actual->next);
free (actual);
- return FAILURE;
+ return false;
}
/* Replace the assignment with the call. */
@@ -3768,7 +3764,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
c->expr2 = NULL;
c->ext.actual = actual;
- return SUCCESS;
+ return true;
}
@@ -3776,7 +3772,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
the given interface list. Ambiguity isn't checked yet since module
procedures can be present without interfaces. */
-gfc_try
+bool
gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
{
gfc_interface *ip;
@@ -3787,17 +3783,17 @@ gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
{
gfc_error ("Entity '%s' at %L is already present in the interface",
new_sym->name, &loc);
- return FAILURE;
+ return false;
}
}
- return SUCCESS;
+ return true;
}
/* Add a symbol to the current interface. */
-gfc_try
+bool
gfc_add_interface (gfc_symbol *new_sym)
{
gfc_interface **head, *intr;
@@ -3808,7 +3804,7 @@ gfc_add_interface (gfc_symbol *new_sym)
{
case INTERFACE_NAMELESS:
case INTERFACE_ABSTRACT:
- return SUCCESS;
+ return true;
case INTERFACE_INTRINSIC_OP:
for (ns = current_interface.ns; ns; ns = ns->parent)
@@ -3816,62 +3812,62 @@ gfc_add_interface (gfc_symbol *new_sym)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
- if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
- gfc_current_locus) == FAILURE
- || gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
+ gfc_current_locus)
+ || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
+ new_sym, gfc_current_locus))
+ return false;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
- if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
- gfc_current_locus) == FAILURE
- || gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
+ gfc_current_locus)
+ || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
+ new_sym, gfc_current_locus))
+ return false;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
- if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym,
- gfc_current_locus) == FAILURE
- || gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
+ new_sym, gfc_current_locus)
+ || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
+ new_sym, gfc_current_locus))
+ return false;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
- if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym,
- gfc_current_locus) == FAILURE
- || gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
+ new_sym, gfc_current_locus)
+ || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
+ new_sym, gfc_current_locus))
+ return false;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
- if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym,
- gfc_current_locus) == FAILURE
- || gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
+ new_sym, gfc_current_locus)
+ || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
+ new_sym, gfc_current_locus))
+ return false;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
- if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym,
- gfc_current_locus) == FAILURE
- || gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
+ new_sym, gfc_current_locus)
+ || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
+ new_sym, gfc_current_locus))
+ return false;
break;
default:
- if (gfc_check_new_interface (ns->op[current_interface.op], new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (ns->op[current_interface.op],
+ new_sym, gfc_current_locus))
+ return false;
}
head = &current_interface.ns->op[current_interface.op];
@@ -3884,18 +3880,18 @@ gfc_add_interface (gfc_symbol *new_sym)
if (sym == NULL)
continue;
- if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)
- == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (sym->generic,
+ new_sym, gfc_current_locus))
+ return false;
}
head = &current_interface.sym->generic;
break;
case INTERFACE_USER_OP:
- if (gfc_check_new_interface (current_interface.uop->op, new_sym,
- gfc_current_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_check_new_interface (current_interface.uop->op,
+ new_sym, gfc_current_locus))
+ return false;
head = &current_interface.uop->op;
break;
@@ -3911,7 +3907,7 @@ gfc_add_interface (gfc_symbol *new_sym)
intr->next = *head;
*head = intr;
- return SUCCESS;
+ return true;
}
@@ -3980,7 +3976,7 @@ gfc_free_formal_arglist (gfc_formal_arglist *p)
/* Check that it is ok for the type-bound procedure 'proc' to override the
procedure 'old', cf. F08:4.5.7.3. */
-gfc_try
+bool
gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
locus where;
@@ -3998,7 +3994,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("Can't overwrite GENERIC '%s' at %L",
old->name, &proc->n.tb->where);
- return FAILURE;
+ return false;
}
where = proc->n.tb->where;
@@ -4010,7 +4006,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a procedure binding declared"
" NON_OVERRIDABLE", proc->name, &where);
- return FAILURE;
+ return false;
}
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
@@ -4018,7 +4014,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
" non-DEFERRED binding", proc->name, &where);
- return FAILURE;
+ return false;
}
/* If the overridden binding is PURE, the overriding must be, too. */
@@ -4026,7 +4022,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
proc->name, &where);
- return FAILURE;
+ return false;
}
/* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
@@ -4035,13 +4031,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
" ELEMENTAL", proc->name, &where);
- return FAILURE;
+ return false;
}
if (!old_target->attr.elemental && proc_target->attr.elemental)
{
gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
" be ELEMENTAL, either", proc->name, &where);
- return FAILURE;
+ return false;
}
/* If the overridden binding is a SUBROUTINE, the overriding must also be a
@@ -4050,7 +4046,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
" SUBROUTINE", proc->name, &where);
- return FAILURE;
+ return false;
}
/* If the overridden binding is a FUNCTION, the overriding must also be a
@@ -4061,15 +4057,15 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
" FUNCTION", proc->name, &where);
- return FAILURE;
+ return false;
}
- if (check_result_characteristics (proc_target, old_target,
- err, sizeof(err)) == FAILURE)
+ if (!check_result_characteristics (proc_target, old_target, err,
+ sizeof(err)))
{
gfc_error ("Result mismatch for the overriding procedure "
"'%s' at %L: %s", proc->name, &where, err);
- return FAILURE;
+ return false;
}
}
@@ -4080,7 +4076,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
" PRIVATE", proc->name, &where);
- return FAILURE;
+ return false;
}
/* Compare the formal argument lists of both procedures. This is also abused
@@ -4112,16 +4108,16 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
" to match the corresponding argument of the overridden"
" procedure", proc_formal->sym->name, proc->name, &where,
old_formal->sym->name);
- return FAILURE;
+ return false;
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
- if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
- check_type, err, sizeof(err)) == FAILURE)
+ if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
+ check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
"'%s' at %L: %s", proc->name, &where, err);
- return FAILURE;
+ return false;
}
++argpos;
@@ -4130,7 +4126,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L must have the same number of formal arguments as"
" the overridden procedure", proc->name, &where);
- return FAILURE;
+ return false;
}
/* If the overridden binding is NOPASS, the overriding one must also be
@@ -4139,7 +4135,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
" NOPASS", proc->name, &where);
- return FAILURE;
+ return false;
}
/* If the overridden binding is PASS(x), the overriding one must also be
@@ -4150,7 +4146,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
" PASS", proc->name, &where);
- return FAILURE;
+ return false;
}
if (proc_pass_arg != old_pass_arg)
@@ -4158,9 +4154,9 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
" the same position as the passed-object dummy argument of"
" the overridden procedure", proc->name, &where);
- return FAILURE;
+ return false;
}
}
- return SUCCESS;
+ return true;
}
View Lorry Controller Status