/* Compare components according to 4.4.2 of the Fortran standard. */
-static int
+static bool
compare_components (gfc_component *cmp1, gfc_component *cmp2,
gfc_symbol *derived1, gfc_symbol *derived2)
{
/* Compare names, but not for anonymous components such as UNION or MAP. */
if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2)
&& strcmp (cmp1->name, cmp2->name) != 0)
- return 0;
+ return false;
if (cmp1->attr.access != cmp2->attr.access)
- return 0;
+ return false;
if (cmp1->attr.pointer != cmp2->attr.pointer)
- return 0;
+ return false;
if (cmp1->attr.dimension != cmp2->attr.dimension)
- return 0;
+ return false;
if (cmp1->attr.allocatable != cmp2->attr.allocatable)
- return 0;
+ return false;
if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
- return 0;
+ return false;
if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER)
{
&& l1->length->expr_type == EXPR_CONSTANT
&& l2->length->expr_type == EXPR_CONSTANT
&& gfc_dep_compare_expr (l1->length, l2->length) != 0)
- return 0;
+ return false;
}
/* Make sure that link lists do not put this function into an
endless recursive loop! */
if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
&& !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)
- && gfc_compare_types (&cmp1->ts, &cmp2->ts) == 0)
- return 0;
+ && !gfc_compare_types (&cmp1->ts, &cmp2->ts))
+ return false;
else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
&& !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
- return 0;
+ return false;
else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
&& (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
- return 0;
+ return false;
- return 1;
+ return true;
}
gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
definitions' than 'equivalent structure'. */
-int
-gfc_compare_union_types (gfc_symbol *un1, gfc_symbol *un2)
+static bool
+compare_union_types (gfc_symbol *un1, gfc_symbol *un2)
{
gfc_component *map1, *map2, *cmp1, *cmp2;
gfc_symbol *map1_t, *map2_t;
if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION)
- return 0;
+ return false;
if (un1->attr.zero_comp != un2->attr.zero_comp)
- return 0;
+ return false;
if (un1->attr.zero_comp)
- return 1;
+ return true;
map1 = un1->components;
map2 = un2->components;
/* Protect against null components. */
if (map1_t->attr.zero_comp != map2_t->attr.zero_comp)
- return 0;
+ return false;
if (map1_t->attr.zero_comp)
- return 1;
+ return true;
for (;;)
{
the same component, because one map field is created with its type
declaration. Therefore don't worry about recursion here. */
/* TODO: worry about recursion into parent types of the unions? */
- if (compare_components (cmp1, cmp2, map1_t, map2_t) == 0)
- return 0;
+ if (!compare_components (cmp1, cmp2, map1_t, map2_t))
+ return false;
cmp1 = cmp1->next;
cmp2 = cmp2->next;
if (cmp1 == NULL && cmp2 == NULL)
break;
if (cmp1 == NULL || cmp2 == NULL)
- return 0;
+ return false;
}
map1 = map1->next;
if (map1 == NULL && map2 == NULL)
break;
if (map1 == NULL || map2 == NULL)
- return 0;
+ return false;
}
- return 1;
+ return true;
}
/* Compare two derived types using the criteria in 4.4.2 of the standard,
recursing through gfc_compare_types for the components. */
-int
+bool
gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
{
gfc_component *cmp1, *cmp2;
if (derived1 == derived2)
- return 1;
+ return true;
if (!derived1 || !derived2)
gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
/* Compare UNION types specially. */
if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION)
- return gfc_compare_union_types (derived1, derived2);
+ return compare_union_types (derived1, derived2);
/* Special case for comparing derived types across namespaces. If the
true names and module names are the same and the module name is
if (strcmp (derived1->name, derived2->name) == 0
&& derived1->module != NULL && derived2->module != NULL
&& strcmp (derived1->module, derived2->module) == 0)
- return 1;
+ return true;
/* Compare type via the rules of the standard. Both types must have
the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
/* Compare names, but not for anonymous types such as UNION or MAP. */
if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2)
&& strcmp (derived1->name, derived2->name) != 0)
- return 0;
+ return false;
if (derived1->component_access == ACCESS_PRIVATE
|| derived2->component_access == ACCESS_PRIVATE)
- return 0;
+ return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
&& !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
- return 0;
+ return false;
/* Protect against null components. */
if (derived1->attr.zero_comp != derived2->attr.zero_comp)
- return 0;
+ return false;
if (derived1->attr.zero_comp)
- return 1;
+ return true;
cmp1 = derived1->components;
cmp2 = derived2->components;
for (;;)
{
if (!compare_components (cmp1, cmp2, derived1, derived2))
- return 0;
+ return false;
cmp1 = cmp1->next;
cmp2 = cmp2->next;
if (cmp1 == NULL && cmp2 == NULL)
break;
if (cmp1 == NULL || cmp2 == NULL)
- return 0;
+ return false;
}
- return 1;
+ return true;
}
/* Compare two typespecs, recursively if necessary. */
-int
+bool
gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
{
/* See if one of the typespecs is a BT_VOID, which is what is being used
TODO: Possibly should narrow this to just the one typespec coming in
that is for the formal arg, but oh well. */
if (ts1->type == BT_VOID || ts2->type == BT_VOID)
- return 1;
+ return true;
/* The _data component is not always present, therefore check for its
presence before assuming, that its derived->attr is available.
&& ts1->u.derived->components->ts.u.derived->attr
.unlimited_polymorphic)
|| ts1->u.derived->attr.unlimited_polymorphic))
- return 1;
+ return true;
/* F2003: C717 */
if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
.unlimited_polymorphic)
|| ts2->u.derived->attr.unlimited_polymorphic)
&& (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
- return 1;
+ return true;
if (ts1->type != ts2->type
&& ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
|| (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
- return 0;
+ return false;
if (ts1->type == BT_UNION)
- return gfc_compare_union_types (ts1->u.derived, ts2->u.derived);
+ return compare_union_types (ts1->u.derived, ts2->u.derived);
if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
return (ts1->kind == ts2->kind);
}
-static int
+static bool
compare_type (gfc_symbol *s1, gfc_symbol *s2)
{
if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
- return 1;
+ return true;
/* TYPE and CLASS of the same declared type are type compatible,
but have different characteristics. */
if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
|| (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
- return 0;
+ return false;
return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
}
-static int
+static bool
compare_rank (gfc_symbol *s1, gfc_symbol *s2)
{
gfc_array_spec *as1, *as2;
int r1, r2;
if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
- return 1;
+ return true;
as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
r2 = as2 ? as2->rank : 0;
if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
- return 0; /* Ranks differ. */
+ return false; /* Ranks differ. */
- return 1;
+ return true;
}
/* Given two symbols that are formal arguments, compare their ranks
- and types. Returns nonzero if they have the same rank and type,
- zero otherwise. */
+ and types. Returns true if they have the same rank and type,
+ false otherwise. */
-static int
+static bool
compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
{
return compare_type (s1, s2) && compare_rank (s1, s2);
/* Given two symbols that are formal arguments, compare their types
and rank and their formal interfaces if they are both dummy
- procedures. Returns nonzero if the same, zero if different. */
+ procedures. Returns true if the same, false if different. */
-static int
+static bool
compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
{
if (s1 == NULL || s2 == NULL)
- return s1 == s2 ? 1 : 0;
+ return (s1 == s2);
if (s1 == s2)
- return 1;
+ return true;
if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
return compare_type_rank (s1, s2);
if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
- return 0;
+ return false;
/* At this point, both symbols are procedures. It can happen that
external procedures are compared, where one is identified by usage
to be a function or subroutine but the other is not. Check TKR
nonetheless for these cases. */
if (s1->attr.function == 0 && s1->attr.subroutine == 0)
- return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+ return s1->attr.external ? compare_type_rank (s1, s2) : false;
if (s2->attr.function == 0 && s2->attr.subroutine == 0)
- return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+ return s2->attr.external ? compare_type_rank (s1, s2) : false;
/* Now the type of procedure has been identified. */
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
- return 0;
+ return false;
- if (s1->attr.function && compare_type_rank (s1, s2) == 0)
- return 0;
+ if (s1->attr.function && !compare_type_rank (s1, s2))
+ return false;
/* Originally, gfortran recursed here to check the interfaces of passed
procedures. This is explicitly not required by the standard. */
- return 1;
+ return true;
}
by this test. This subroutine implements rule 1 of section F03:16.2.3.
'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
-static int
+static bool
count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
const char *p1, const char *p2)
{
- int rc, ac1, ac2, i, j, k, n1;
+ int ac1, ac2, i, j, k, n1;
gfc_formal_arglist *f;
typedef struct
/* Now loop over each distinct type found in f1. */
k = 0;
- rc = 0;
+ bool rc = false;
for (i = 0; i < n1; i++)
{
if (ac1 > ac2)
{
- rc = 1;
+ rc = true;
break;
}
At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
-static int
+static bool
generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
const char *p1, const char *p2)
{
|| ((gfc_option.allow_std & GFC_STD_F2008)
&& ((sym->attr.allocatable && g->sym->attr.pointer)
|| (sym->attr.pointer && g->sym->attr.allocatable))))
- return 1;
+ return true;
}
next:
f2 = f2->next;
}
- return 0;
+ return false;
}
/* 'Compare' two formal interfaces associated with a pair of symbols.
- We return nonzero if there exists an actual argument list that
+ We return true if there exists an actual argument list that
would be ambiguous between the two interfaces, zero otherwise.
'strict_flag' specifies whether all the characteristics are
required to match, which is not the case for ambiguity checks.
'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
-int
+bool
gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
int generic_flag, int strict_flag,
char *errmsg, int err_len,
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "'%s' is not a function", name2);
- return 0;
+ return false;
}
if (s1->attr.subroutine && s2->attr.function)
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
- return 0;
+ return false;
}
/* Do strict checks on all characteristics
/* If both are functions, check result characteristics. */
if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
|| !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
- return 0;
+ return false;
}
if (s1->attr.pure && !s2->attr.pure)
{
snprintf (errmsg, err_len, "Mismatch in PURE attribute");
- return 0;
+ return false;
}
if (s1->attr.elemental && !s2->attr.elemental)
{
snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
- return 0;
+ return false;
}
}
if (s1->attr.if_source == IFSRC_UNKNOWN
|| s2->attr.if_source == IFSRC_UNKNOWN)
- return 1;
+ return true;
f1 = gfc_sym_get_dummy_args (s1);
f2 = gfc_sym_get_dummy_args (s2);
/* Special case: No arguments. */
if (f1 == NULL && f2 == NULL)
- return 1;
+ return true;
if (generic_flag)
{
if (count_types_test (f1, f2, p1, p2)
|| count_types_test (f2, f1, p2, p1))
- return 0;
+ return false;
/* Special case: alternate returns. If both f1->sym and f2->sym are
NULL, then the leading formal arguments are alternate returns.
The previous conditional should catch argument lists with
different number of argument. */
if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
- return 1;
+ return true;
if (generic_correspondence (f1, f2, p1, p2)
|| generic_correspondence (f2, f1, p2, p1))
- return 0;
+ return false;
}
else
/* Perform the abbreviated correspondence test for operators (the
if (errmsg != NULL)
snprintf (errmsg, err_len, "'%s' has the wrong number of "
"arguments", name2);
- return 0;
+ return false;
}
if (strict_flag)
/* Check all characteristics. */
if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
- return 0;
+ return false;
}
else
{
"(%s/%s)", f1->sym->name,
gfc_typename (&f1->sym->ts),
gfc_typename (&f2->sym->ts));
- return 0;
+ return false;
}
if (!compare_rank (f2->sym, f1->sym))
{
snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
"(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
symbol_rank (f2->sym));
- return 0;
+ return false;
}
}
}
- return 1;
+ return true;
}
/* Given a pointer to an interface pointer, remove duplicate
interfaces and make sure that all symbols are either functions
- or subroutines, and all of the same kind. Returns nonzero if
+ or subroutines, and all of the same kind. Returns true if
something goes wrong. */
-static int
+static bool
check_interface0 (gfc_interface *p, const char *interface_name)
{
gfc_interface *psave, *q, *qlast;
gfc_error ("Procedure %qs in %s at %L is neither function nor "
"subroutine", p->sym->name, interface_name,
&p->sym->declared_at);
- return 1;
+ return true;
}
/* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
"generic name is also the name of a derived type",
interface_name, &p->sym->declared_at);
- return 1;
+ return true;
}
/* F2003, C1207. F2008, C1207. */
&& !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
"%qs in %s at %L", p->sym->name,
interface_name, &p->sym->declared_at))
- return 1;
+ return true;
}
p = psave;
}
}
- return 0;
+ return false;
}
/* Check lists of interfaces to make sure that no two interfaces are
ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
-static int
+static bool
check_interface1 (gfc_interface *p, gfc_interface *q0,
int generic_flag, const char *interface_name,
bool referenced)
else
gfc_warning (0, "Although not referenced, %qs has ambiguous "
"interfaces at %L", interface_name, &p->where);
- return 1;
+ return true;
}
}
- return 0;
+ return false;
}
/* Given a symbol of a formal argument list and an expression, if the
formal argument is allocatable, check that the actual argument is
- allocatable. Returns nonzero if compatible, zero if not compatible. */
+ allocatable. Returns true if compatible, zero if not compatible. */
-static int
+static bool
compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
{
if (formal->attr.allocatable
{
symbol_attribute attr = gfc_expr_attr (actual);
if (actual->ts.type == BT_CLASS && !attr.class_ok)
- return 1;
+ return true;
else if (!attr.allocatable)
- return 0;
+ return false;
}
- return 1;
+ return true;
}
/* Given a symbol of a formal argument list and an expression, see if
- the two are compatible as arguments. Returns nonzero if
- compatible, zero if not compatible. */
+ the two are compatible as arguments. Returns true if
+ compatible, false if not compatible. */
-static int
+static bool
compare_parameter (gfc_symbol *formal, gfc_expr *actual,
int ranks_must_agree, int is_elemental, locus *where)
{
procs c_f_pointer or c_f_procpointer, and we need to accept most
pointers the user could give us. This should allow that. */
if (formal->ts.type == BT_VOID)
- return 1;
+ return true;
if (formal->ts.type == BT_DERIVED
&& formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
&& actual->ts.type == BT_DERIVED
&& actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
- return 1;
+ return true;
if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
/* Make sure the vtab symbol is present when
{
if (where)
gfc_error ("Invalid procedure argument at %L", &actual->where);
- return 0;
+ return false;
}
if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
gfc_error (OPT_Wargument_mismatch,
"Interface mismatch in dummy procedure %qs at %L: %s",
formal->name, &actual->where, err);
- return 0;
+ return false;
}
if (formal->attr.function && !act_sym->attr.function)
&act_sym->declared_at);
if (act_sym->ts.type == BT_UNKNOWN
&& !gfc_set_default_type (act_sym, 1, act_sym->ns))
- return 0;
+ return false;
}
else if (formal->attr.subroutine && !act_sym->attr.subroutine)
gfc_add_subroutine (&act_sym->attr, act_sym->name,
&act_sym->declared_at);
- return 1;
+ return true;
}
ppc = gfc_get_proc_ptr_comp (actual);
gfc_error (OPT_Wargument_mismatch,
"Interface mismatch in dummy procedure %qs at %L: %s",
formal->name, &actual->where, err);
- return 0;
+ return false;
}
}
if (where)
gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
"must be simply contiguous", formal->name, &actual->where);
- return 0;
+ return false;
}
symbol_attribute actual_attr = gfc_expr_attr (actual);
if (actual->ts.type == BT_CLASS && !actual_attr.class_ok)
- return 1;
+ return true;
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& actual->ts.type != BT_HOLLERITH
"Type mismatch in argument %qs at %L; passed %s to %s",
formal->name, where, gfc_typename (&actual->ts),
gfc_typename (&formal->ts));
- return 0;
+ return false;
}
if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
gfc_error ("Assumed-type actual argument at %L requires that dummy "
"argument %qs is of assumed type", &actual->where,
formal->name);
- return 0;
+ return false;
}
/* F2008, 12.5.2.5; IR F08/0073. */
if (where)
gfc_error ("Actual argument to %qs at %L must be polymorphic",
formal->name, &actual->where);
- return 0;
+ return false;
}
if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
if (where)
gfc_error ("Actual argument to %qs at %L must have the same "
"declared type", formal->name, &actual->where);
- return 0;
+ return false;
}
}
"pointer or allocatable unlimited polymorphic "
"entity [F2008: 12.5.2.5]", formal->name,
&actual->where);
- return 0;
+ return false;
}
if (formal->attr.codimension && !gfc_is_coarray (actual))
if (where)
gfc_error ("Actual argument to %qs at %L must be a coarray",
formal->name, &actual->where);
- return 0;
+ return false;
}
if (formal->attr.codimension && formal->attr.allocatable)
formal->name, &actual->where, formal->as->corank,
last ? last->u.c.component->as->corank
: actual->symtree->n.sym->as->corank);
- return 0;
+ return false;
}
}
gfc_error ("Actual argument to %qs at %L must be simply "
"contiguous or an element of such an array",
formal->name, &actual->where);
- return 0;
+ return false;
}
/* F2008, C1303 and C1304. */
gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
"which is LOCK_TYPE or has a LOCK_TYPE component",
formal->name, &actual->where);
- return 0;
+ return false;
}
/* TS18508, C702/C703. */
gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
"which is EVENT_TYPE or has a EVENT_TYPE component",
formal->name, &actual->where);
- return 0;
+ return false;
}
}
"assumed-rank array without CONTIGUOUS attribute - as actual"
" argument at %L is not simply contiguous and both are "
"ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
- return 0;
+ return false;
}
if (formal->attr.allocatable && !formal->attr.codimension
gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
"INTENT(OUT) dummy argument %qs", &actual->where,
formal->name);
- return 0;
+ return false;
}
else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
gfc_warning (OPT_Wsurprising,
/* If the rank is the same or the formal argument has assumed-rank. */
if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
- return 1;
+ return true;
rank_check = where != NULL && !is_elemental && formal->as
&& (formal->as->type == AS_ASSUMED_SHAPE
/* Skip rank checks for NO_ARG_CHECK. */
if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
- return 1;
+ return true;
/* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
if (rank_check || ranks_must_agree
if (where)
argument_rank_mismatch (formal->name, &actual->where,
symbol_rank (formal), actual->rank);
- return 0;
+ return false;
}
else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
- return 1;
+ return true;
/* At this point, we are considering a scalar passed to an array. This
is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
if (where)
gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
"at %L", formal->name, &actual->where);
- return 0;
+ return false;
}
if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
gfc_error ("Element of assumed-shaped or pointer "
"array passed to array dummy argument %qs at %L",
formal->name, &actual->where);
- return 0;
+ return false;
}
if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
"CHARACTER actual argument with array dummy argument "
"%qs at %L", formal->name, &actual->where);
- return 0;
+ return false;
}
if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
"array dummy argument %qs at %L",
formal->name, &actual->where);
- return 0;
+ return false;
}
- else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
- return 0;
else
- return 1;
+ return ((gfc_option.allow_std & GFC_STD_F2003) != 0);
}
if (ref == NULL && actual->expr_type != EXPR_NULL)
if (where)
argument_rank_mismatch (formal->name, &actual->where,
symbol_rank (formal), actual->rank);
- return 0;
+ return false;
}
- return 1;
+ return true;
}
/* Given an expression, check whether it is an array section
- which has a vector subscript. If it has, one is returned,
- otherwise zero. */
+ which has a vector subscript. */
-int
+bool
gfc_has_vector_subscript (gfc_expr *e)
{
int i;
gfc_ref *ref;
if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
- return 0;
+ return false;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
for (i = 0; i < ref->u.ar.dimen; i++)
if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
- return 1;
+ return true;
- return 0;
+ return false;
}
errors when things don't match instead of just returning the status
code. */
-static int
+static bool
compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int ranks_must_agree, int is_elemental, locus *where)
{
actual = *ap;
if (actual == NULL && formal == NULL)
- return 1;
+ return true;
n = 0;
for (f = formal; f; f = f->next)
if (where)
gfc_error ("Keyword argument %qs at %L is not in "
"the procedure", a->name, &a->expr->where);
- return 0;
+ return false;
}
if (new_arg[i] != NULL)
gfc_error ("Keyword argument %qs at %L is already associated "
"with another actual argument", a->name,
&a->expr->where);
- return 0;
+ return false;
}
}
gfc_error ("More actual than formal arguments in procedure "
"call at %L", where);
- return 0;
+ return false;
}
if (f->sym == NULL && a->expr == NULL)
if (where)
gfc_error ("Missing alternate return spec in subroutine call "
"at %L", where);
- return 0;
+ return false;
}
if (a->expr == NULL)
if (where)
gfc_error ("Unexpected alternate return spec in subroutine "
"call at %L", where);
- return 0;
+ return false;
}
/* Make sure that intrinsic vtables exist for calls to unlimited
gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
"dummy %qs", where, f->sym->name);
- return 0;
+ return false;
}
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
is_elemental, where))
- return 0;
+ return false;
/* TS 29113, 6.3p2. */
if (f->sym->ts.type == BT_ASSUMED
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
if ((f->sym->attr.pointer || f->sym->attr.allocatable)
"pointer dummy argument %qs must have a deferred "
"length type parameter if and only if the dummy has one",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
if (f->sym->ts.type == BT_CLASS)
"elements for dummy argument %qs (%lu/%lu) at %L",
f->sym->name, actual_size, formal_size,
&a->expr->where);
- return 0;
+ return false;
}
skip_size_check:
if (where)
gfc_error ("Expected a procedure pointer for argument %qs at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
/* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
if (where)
gfc_error ("Expected a procedure for argument %qs at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
if (where)
gfc_error ("Actual argument for %qs cannot be an assumed-size"
" array at %L", f->sym->name, where);
- return 0;
+ return false;
}
if (a->expr->expr_type != EXPR_NULL
if (where)
gfc_error ("Actual argument for %qs must be a pointer at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
if (a->expr->expr_type != EXPR_NULL
if (where)
gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
"pointer dummy %qs", &a->expr->where,f->sym->name);
- return 0;
+ return false;
}
gfc_error ("Coindexed actual argument at %L to pointer "
"dummy %qs",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
/* Fortran 2008, 12.5.2.5 (no constraint). */
gfc_error ("Coindexed actual argument at %L to allocatable "
"dummy %qs requires INTENT(IN)",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
/* Fortran 2008, C1237. */
"%L requires that dummy %qs has neither "
"ASYNCHRONOUS nor VOLATILE", &a->expr->where,
f->sym->name);
- return 0;
+ return false;
}
/* Fortran 2008, 12.5.2.4 (no constraint). */
gfc_error ("Coindexed actual argument at %L with allocatable "
"ultimate component to dummy %qs requires either VALUE "
"or INTENT(IN)", &a->expr->where, f->sym->name);
- return 0;
+ return false;
}
if (f->sym->ts.type == BT_CLASS
if (where)
gfc_error ("Actual CLASS array argument for %qs must be a full "
"array at %L", f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
if (a->expr->expr_type != EXPR_NULL
- && compare_allocatable (f->sym, a->expr) == 0)
+ && !compare_allocatable (f->sym, a->expr))
{
if (where)
gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
/* Check intent = OUT/INOUT for definable actual argument. */
&& 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))
- return 0;
+ return false;
if (!gfc_check_vardef_context (a->expr, false, false, false, context))
- return 0;
+ return false;
}
if ((f->sym->attr.intent == INTENT_OUT
"INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
"of the dummy argument %qs",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
/* C1232 (R1221) For an actual argument which is an array section or
"incompatible with the non-assumed-shape "
"dummy argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
- return 0;
+ return false;
}
/* Find the last array_ref. */
"incompatible with the non-assumed-shape "
"dummy argument %qs due to VOLATILE attribute",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
/* C1233 (R1221) For an actual argument which is a pointer array, the
"an assumed-shape or pointer-array dummy "
"argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
- return 0;
+ return false;
}
match:
if (where)
gfc_error ("Missing alternate return spec in subroutine call "
"at %L", where);
- return 0;
+ return false;
}
if (!f->sym->attr.optional)
{
if (where)
gfc_error ("Missing actual argument for argument %qs at %L",
f->sym->name, where);
- return 0;
+ return false;
}
}
if (a->expr == NULL && a->label == NULL)
a->missing_arg_type = f->sym->ts.type;
- return 1;
+ return true;
}
projects / gcc.git / commitdiff