diff options
Diffstat (limited to 'gcc/fortran/check.c')
| -rw-r--r-- | gcc/fortran/check.c | 3766 |
1 files changed, 1891 insertions, 1875 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 99174bcc75b..870ca757192 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -37,67 +37,66 @@ along with GCC; see the file COPYING3. If not see /* Make sure an expression is a scalar. */ -static gfc_try +static bool scalar_check (gfc_expr *e, int n) { if (e->rank == 0) - return SUCCESS; + return true; gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } /* Check the type of an expression. */ -static gfc_try +static bool type_check (gfc_expr *e, int n, bt type) { if (e->ts.type == type) - return SUCCESS; + return true; gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, gfc_basic_typename (type)); - return FAILURE; + return false; } /* Check that the expression is a numeric type. */ -static gfc_try +static bool numeric_check (gfc_expr *e, int n) { if (gfc_numeric_ts (&e->ts)) - return SUCCESS; + return true; /* If the expression has not got a type, check if its namespace can offer a default type. */ if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) && e->symtree->n.sym->ts.type == BT_UNKNOWN - && gfc_set_default_type (e->symtree->n.sym, 0, - e->symtree->n.sym->ns) == SUCCESS + && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns) && gfc_numeric_ts (&e->symtree->n.sym->ts)) { e->ts = e->symtree->n.sym->ts; - return SUCCESS; + return true; } gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } /* Check that an expression is integer or real. */ -static gfc_try +static bool int_or_real_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) @@ -105,16 +104,16 @@ int_or_real_check (gfc_expr *e, int n) gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " "or REAL", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Check that an expression is real or complex. */ -static gfc_try +static bool real_or_complex_check (gfc_expr *e, int n) { if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) @@ -122,16 +121,16 @@ real_or_complex_check (gfc_expr *e, int n) gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL " "or COMPLEX", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Check that an expression is INTEGER or PROCEDURE. */ -static gfc_try +static bool int_or_proc_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) @@ -139,36 +138,36 @@ int_or_proc_check (gfc_expr *e, int n) gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Check that the expression is an optional constant integer and that it specifies a valid kind for that type. */ -static gfc_try +static bool kind_check (gfc_expr *k, int n, bt type) { int kind; if (k == NULL) - return SUCCESS; + return true; - if (type_check (k, n, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (k, n, BT_INTEGER)) + return false; - if (scalar_check (k, n) == FAILURE) - return FAILURE; + if (!scalar_check (k, n)) + return false; - if (gfc_check_init_expr (k) != SUCCESS) + if (!gfc_check_init_expr (k)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &k->where); - return FAILURE; + return false; } if (gfc_extract_int (k, &kind) != NULL @@ -176,34 +175,34 @@ kind_check (gfc_expr *k, int n, bt type) { gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), &k->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Make sure the expression is a double precision real. */ -static gfc_try +static bool double_check (gfc_expr *d, int n) { - if (type_check (d, n, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (d, n, BT_REAL)) + return false; if (d->ts.kind != gfc_default_double_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be double " "precision", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &d->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -static gfc_try +static bool coarray_check (gfc_expr *e, int n) { if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok @@ -211,7 +210,7 @@ coarray_check (gfc_expr *e, int n) && CLASS_DATA (e)->as->corank) { gfc_add_class_array_ref (e); - return SUCCESS; + return true; } if (!gfc_is_coarray (e)) @@ -219,16 +218,16 @@ coarray_check (gfc_expr *e, int n) gfc_error ("Expected coarray variable as '%s' argument to the %s " "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Make sure the expression is a logical array. */ -static gfc_try +static bool logical_array_check (gfc_expr *array, int n) { if (array->ts.type != BT_LOGICAL || array->rank == 0) @@ -236,16 +235,16 @@ logical_array_check (gfc_expr *array, int n) gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical " "array", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &array->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Make sure an expression is an array. */ -static gfc_try +static bool array_check (gfc_expr *e, int n) { if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok @@ -253,24 +252,24 @@ array_check (gfc_expr *e, int n) && CLASS_DATA (e)->as->rank) { gfc_add_class_array_ref (e); - return SUCCESS; + return true; } if (e->rank != 0 && e->ts.type != BT_PROCEDURE) - return SUCCESS; + return true; gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } /* If expr is a constant, then check to ensure that it is greater than of equal to zero. */ -static gfc_try +static bool nonnegative_check (const char *arg, gfc_expr *expr) { int i; @@ -281,18 +280,18 @@ nonnegative_check (const char *arg, gfc_expr *expr) if (i < 0) { gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } /* If expr2 is constant, then check that the value is less than (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ -static gfc_try +static bool less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, gfc_expr *expr2, bool or_equal) { @@ -314,7 +313,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, gfc_error ("The absolute value of SHIFT at %L must be less " "than or equal to BIT_SIZE('%s')", &expr2->where, arg1); - return FAILURE; + return false; } } @@ -325,7 +324,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, gfc_error ("'%s' at %L must be less than " "or equal to BIT_SIZE('%s')", arg2, &expr2->where, arg1); - return FAILURE; + return false; } } else @@ -334,25 +333,25 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, { gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", arg2, &expr2->where, arg1); - return FAILURE; + return false; } } } - return SUCCESS; + return true; } /* If expr is constant, then check that the value is less than or equal to the bit_size of the kind k. */ -static gfc_try +static bool less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) { int i, val; if (expr->expr_type != EXPR_CONSTANT) - return SUCCESS; + return true; i = gfc_validate_kind (BT_INTEGER, k, false); gfc_extract_int (expr, &val); @@ -361,17 +360,17 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) { gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of " "INTEGER(KIND=%d)", arg, &expr->where, k); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* If expr2 and expr3 are constants, then check that the value is less than or equal to bit_size(expr1). */ -static gfc_try +static bool less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, gfc_expr *expr2, const char *arg3, gfc_expr *expr3) { @@ -388,49 +387,49 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, gfc_error ("'%s + %s' at %L must be less than or equal " "to BIT_SIZE('%s')", arg2, arg3, &expr2->where, arg1); - return FAILURE; + return false; } } - return SUCCESS; + return true; } /* Make sure two expressions have the same type. */ -static gfc_try +static bool same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) { if (gfc_compare_types (&e->ts, &f->ts)) - return SUCCESS; + return true; gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type " "and kind as '%s'", gfc_current_intrinsic_arg[m]->name, gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]->name); - return FAILURE; + return false; } /* Make sure that an expression has a certain (nonzero) rank. */ -static gfc_try +static bool rank_check (gfc_expr *e, int n, int rank) { if (e->rank == rank) - return SUCCESS; + return true; gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, rank); - return FAILURE; + return false; } /* Make sure a variable expression is not an optional dummy argument. */ -static gfc_try +static bool nonoptional_check (gfc_expr *e, int n) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) @@ -442,13 +441,13 @@ nonoptional_check (gfc_expr *e, int n) /* TODO: Recursive check on nonoptional variables? */ - return SUCCESS; + return true; } /* Check for ALLOCATABLE attribute. */ -static gfc_try +static bool allocatable_check (gfc_expr *e, int n) { symbol_attribute attr; @@ -459,32 +458,32 @@ allocatable_check (gfc_expr *e, int n) gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Check that an expression has a particular kind. */ -static gfc_try +static bool kind_value_check (gfc_expr *e, int n, int k) { if (e->ts.kind == k) - return SUCCESS; + return true; gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, k); - return FAILURE; + return false; } /* Make sure an expression is a variable. */ -static gfc_try +static bool variable_check (gfc_expr *e, int n, bool allow_proc) { if (e->expr_type == EXPR_VARIABLE @@ -515,14 +514,14 @@ variable_check (gfc_expr *e, int n, bool allow_proc) gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be " "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } } if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.flavor != FL_PARAMETER && (allow_proc || !e->symtree->n.sym->attr.function)) - return SUCCESS; + return true; if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function && e->symtree->n.sym == e->symtree->n.sym->result) @@ -530,41 +529,41 @@ variable_check (gfc_expr *e, int n, bool allow_proc) gfc_namespace *ns; for (ns = gfc_current_ns; ns; ns = ns->parent) if (ns->proc_name == e->symtree->n.sym) - return SUCCESS; + return true; } gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - return FAILURE; + return false; } /* Check the common DIM parameter for correctness. */ -static gfc_try +static bool dim_check (gfc_expr *dim, int n, bool optional) { if (dim == NULL) - return SUCCESS; + return true; - if (type_check (dim, n, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (dim, n, BT_INTEGER)) + return false; - if (scalar_check (dim, n) == FAILURE) - return FAILURE; + if (!scalar_check (dim, n)) + return false; - if (!optional && nonoptional_check (dim, n) == FAILURE) - return FAILURE; + if (!optional && !nonoptional_check (dim, n)) + return false; - return SUCCESS; + return true; } /* If a coarray DIM parameter is a constant, make sure that it is greater than zero and less than or equal to the corank of the given array. */ -static gfc_try +static bool dim_corank_check (gfc_expr *dim, gfc_expr *array) { int corank; @@ -572,10 +571,10 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array) gcc_assert (array->expr_type == EXPR_VARIABLE); if (dim->expr_type != EXPR_CONSTANT) - return SUCCESS; + return true; if (array->ts.type == BT_CLASS) - return SUCCESS; + return true; corank = gfc_get_corank (array); @@ -585,10 +584,10 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array) gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " "codimension index", gfc_current_intrinsic, &dim->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -597,20 +596,20 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array) allow_assumed is zero then dim must be less than the rank of the array for assumed size arrays. */ -static gfc_try +static bool dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) { gfc_array_ref *ar; int rank; if (dim == NULL) - return SUCCESS; + return true; if (dim->expr_type != EXPR_CONSTANT) - return SUCCESS; + return true; if (array->ts.type == BT_CLASS) - return SUCCESS; + return true; if (array->expr_type == EXPR_FUNCTION && array->value.function.isym && array->value.function.isym->id == GFC_ISYM_SPREAD) @@ -638,10 +637,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " "dimension index", gfc_current_intrinsic, &dim->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -660,9 +659,9 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) ret = 1; - if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS) + if (gfc_array_dimen_size (a, ai, &a_size)) { - if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS) + if (gfc_array_dimen_size (b, bi, &b_size)) { if (mpz_cmp (a_size, b_size) != 0) ret = 0; @@ -723,10 +722,10 @@ gfc_var_strlen (const gfc_expr *a) } /* Check whether two character expressions have the same length; - returns SUCCESS if they have or if the length cannot be determined, - otherwise return FAILURE and raise a gfc_error. */ + returns true if they have or if the length cannot be determined, + otherwise return false and raise a gfc_error. */ -gfc_try +bool gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) { long len_a, len_b; @@ -735,12 +734,12 @@ gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) len_b = gfc_var_strlen(b); if (len_a == -1 || len_b == -1 || len_a == len_b) - return SUCCESS; + return true; else { gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", len_a, len_b, name, &a->where); - return FAILURE; + return false; } } @@ -750,21 +749,21 @@ gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) /* Check subroutine suitable for intrinsics taking a real argument and a kind argument for the result. */ -static gfc_try +static bool check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) { - if (type_check (a, 0, BT_REAL) == FAILURE) - return FAILURE; - if (kind_check (kind, 1, type) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_REAL)) + return false; + if (!kind_check (kind, 1, type)) + return false; - return SUCCESS; + return true; } /* Check subroutine suitable for ceiling, floor and nint. */ -gfc_try +bool gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) { return check_a_kind (a, kind, BT_INTEGER); @@ -773,90 +772,90 @@ gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) /* Check subroutine suitable for aint, anint. */ -gfc_try +bool gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) { return check_a_kind (a, kind, BT_REAL); } -gfc_try +bool gfc_check_abs (gfc_expr *a) { - if (numeric_check (a, 0) == FAILURE) - return FAILURE; + if (!numeric_check (a, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_achar (gfc_expr *a, gfc_expr *kind) { - if (type_check (a, 0, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind_check (kind, 1, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_INTEGER)) + return false; + if (!kind_check (kind, 1, BT_CHARACTER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_access_func (gfc_expr *name, gfc_expr *mode) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE - || scalar_check (name, 0) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER) + || !scalar_check (name, 0)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - if (type_check (mode, 1, BT_CHARACTER) == FAILURE - || scalar_check (mode, 1) == FAILURE) - return FAILURE; - if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (mode, 1, BT_CHARACTER) + || !scalar_check (mode, 1)) + return false; + if (!kind_value_check (mode, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) { - if (logical_array_check (mask, 0) == FAILURE) - return FAILURE; + if (!logical_array_check (mask, 0)) + return false; - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, false)) + return false; - if (dim_rank_check (dim, mask, 0) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, mask, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_allocated (gfc_expr *array) { - if (variable_check (array, 0, false) == FAILURE) - return FAILURE; - if (allocatable_check (array, 0) == FAILURE) - return FAILURE; + if (!variable_check (array, 0, false)) + return false; + if (!allocatable_check (array, 0)) + return false; - return SUCCESS; + return true; } /* Common check function where the first argument must be real or integer and the second argument must be the same as the first. */ -gfc_try +bool gfc_check_a_p (gfc_expr *a, gfc_expr *p) { - if (int_or_real_check (a, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (a, 0)) + return false; if (a->ts.type != p->ts.type) { @@ -864,36 +863,36 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) "have the same type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &p->where); - return FAILURE; + return false; } if (a->ts.kind != p->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &p->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", + &p->where)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_x_yd (gfc_expr *x, gfc_expr *y) { - if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE) - return FAILURE; + if (!double_check (x, 0) || !double_check (y, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_associated (gfc_expr *pointer, gfc_expr *target) { symbol_attribute attr1, attr2; int i; - gfc_try t; + bool t; locus *where; where = &pointer->where; @@ -908,7 +907,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); - return FAILURE; + return false; } /* F2008, C1242. */ @@ -917,12 +916,12 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); - return FAILURE; + return false; } /* Target argument is optional. */ if (target == NULL) - return SUCCESS; + return true; where = &target->where; if (target->expr_type == EXPR_NULL) @@ -936,7 +935,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); - return FAILURE; + return false; } if (attr1.pointer && !attr2.pointer && !attr2.target) @@ -944,7 +943,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " "or a TARGET", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); - return FAILURE; + return false; } /* F2008, C1242. */ @@ -953,14 +952,14 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); - return FAILURE; + return false; } - t = SUCCESS; - if (same_type_check (pointer, 0, target, 1) == FAILURE) - t = FAILURE; - if (rank_check (target, 0, pointer->rank) == FAILURE) - t = FAILURE; + t = true; + if (!same_type_check (pointer, 0, target, 1)) + t = false; + if (!rank_check (target, 0, pointer->rank)) + t = false; if (target->rank > 0) { for (i = 0; i < target->rank; i++) @@ -969,7 +968,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) gfc_error ("Array section with a vector subscript at %L shall not " "be the target of a pointer", &target->where); - t = FAILURE; + t = false; break; } } @@ -979,37 +978,37 @@ null_arg: gfc_error ("NULL pointer at %L is not permitted as actual argument " "of '%s' intrinsic function", where, gfc_current_intrinsic); - return FAILURE; + return false; } -gfc_try +bool gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) { /* gfc_notify_std would be a waste of time as the return value is seemingly used only for the generic resolution. The error will be: Too many arguments. */ if ((gfc_option.allow_std & GFC_STD_F2008) == 0) - return FAILURE; + return false; return gfc_check_atan2 (y, x); } -gfc_try +bool gfc_check_atan2 (gfc_expr *y, gfc_expr *x) { - if (type_check (y, 0, BT_REAL) == FAILURE) - return FAILURE; - if (same_type_check (y, 0, x, 1) == FAILURE) - return FAILURE; + if (!type_check (y, 0, BT_REAL)) + return false; + if (!same_type_check (y, 0, x, 1)) + return false; - return SUCCESS; + return true; } -static gfc_try +static bool gfc_check_atomic (gfc_expr *atom, gfc_expr *value) { if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind) @@ -1019,14 +1018,14 @@ gfc_check_atomic (gfc_expr *atom, gfc_expr *value) gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " "integer of ATOMIC_INT_KIND or a logical of " "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic); - return FAILURE; + return false; } if (!gfc_expr_attr (atom).codimension) { gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a " "coarray or coindexed", &atom->where, gfc_current_intrinsic); - return FAILURE; + return false; } if (atom->ts.type != value->ts.type) @@ -1034,41 +1033,41 @@ gfc_check_atomic (gfc_expr *atom, gfc_expr *value) gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall " "have the same type at %L", gfc_current_intrinsic, &value->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value) { - if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE) - return FAILURE; + if (!scalar_check (atom, 0) || !scalar_check (value, 1)) + return false; - if (gfc_check_vardef_context (atom, false, false, false, NULL) == FAILURE) + if (!gfc_check_vardef_context (atom, false, false, false, NULL)) { gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " "definable", gfc_current_intrinsic, &atom->where); - return FAILURE; + return false; } return gfc_check_atomic (atom, value); } -gfc_try +bool gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom) { - if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE) - return FAILURE; + if (!scalar_check (value, 0) || !scalar_check (atom, 1)) + return false; - if (gfc_check_vardef_context (value, false, false, false, NULL) == FAILURE) + if (!gfc_check_vardef_context (value, false, false, false, NULL)) { gfc_error ("VALUE argument of the %s intrinsic function at %L shall be " "definable", gfc_current_intrinsic, &value->where); - return FAILURE; + return false; } return gfc_check_atomic (atom, value); @@ -1077,184 +1076,184 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom) /* BESJN and BESYN functions. */ -gfc_try +bool gfc_check_besn (gfc_expr *n, gfc_expr *x) { - if (type_check (n, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (n, 0, BT_INTEGER)) + return false; if (n->expr_type == EXPR_CONSTANT) { int i; gfc_extract_int (n, &i); - if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Negative argument " - "N at %L", &n->where) == FAILURE) - return FAILURE; + if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument " + "N at %L", &n->where)) + return false; } - if (type_check (x, 1, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 1, BT_REAL)) + return false; - return SUCCESS; + return true; } /* Transformational version of the Bessel JN and YN functions. */ -gfc_try +bool gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) { - if (type_check (n1, 0, BT_INTEGER) == FAILURE) - return FAILURE; - if (scalar_check (n1, 0) == FAILURE) - return FAILURE; - if (nonnegative_check("N1", n1) == FAILURE) - return FAILURE; - - if (type_check (n2, 1, BT_INTEGER) == FAILURE) - return FAILURE; - if (scalar_check (n2, 1) == FAILURE) - return FAILURE; - if (nonnegative_check("N2", n2) == FAILURE) - return FAILURE; - - if (type_check (x, 2, BT_REAL) == FAILURE) - return FAILURE; - if (scalar_check (x, 2) == FAILURE) - return FAILURE; + if (!type_check (n1, 0, BT_INTEGER)) + return false; + if (!scalar_check (n1, 0)) + return false; + if (!nonnegative_check ("N1", n1)) + return false; + + if (!type_check (n2, 1, BT_INTEGER)) + return false; + if (!scalar_check (n2, 1)) + return false; + if (!nonnegative_check ("N2", n2)) + return false; + + if (!type_check (x, 2, BT_REAL)) + return false; + if (!scalar_check (x, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (j, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (j, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (pos, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (pos, 1, BT_INTEGER)) + return false; - if (nonnegative_check ("pos", pos) == FAILURE) - return FAILURE; + if (!nonnegative_check ("pos", pos)) + return false; - if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE) - return FAILURE; + if (!less_than_bitsize1 ("i", i, "pos", pos, false)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_char (gfc_expr *i, gfc_expr *kind) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind_check (kind, 1, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; + if (!kind_check (kind, 1, BT_CHARACTER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_chdir (gfc_expr *dir) { - if (type_check (dir, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (dir, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (dir, 0, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) { - if (type_check (dir, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (dir, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (dir, 0, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 1, BT_INTEGER) == FAILURE) - return FAILURE; - if (scalar_check (status, 1) == FAILURE) - return FAILURE; + if (!type_check (status, 1, BT_INTEGER)) + return false; + if (!scalar_check (status, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_chmod (gfc_expr *name, gfc_expr *mode) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - if (type_check (mode, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (mode, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (mode, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - if (type_check (mode, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (mode, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (mode, 1, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER)) + return false; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) { - if (numeric_check (x, 0) == FAILURE) - return FAILURE; + if (!numeric_check (x, 0)) + return false; if (y != NULL) { - if (numeric_check (y, 1) == FAILURE) - return FAILURE; + if (!numeric_check (y, 1)) + return false; if (x->ts.type == BT_COMPLEX) { @@ -1262,7 +1261,7 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); - return FAILURE; + return false; } if (y->ts.type == BT_COMPLEX) @@ -1271,13 +1270,13 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) "of either REAL or INTEGER", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); - return FAILURE; + return false; } } - if (kind_check (kind, 2, BT_COMPLEX) == FAILURE) - return FAILURE; + if (!kind_check (kind, 2, BT_COMPLEX)) + return false; if (!kind && gfc_option.gfc_warn_conversion && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind) @@ -1290,66 +1289,66 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) "might loose precision, consider using the KIND argument", gfc_typename (&y->ts), gfc_default_real_kind, &y->where); - return SUCCESS; + return true; } -gfc_try +bool gfc_check_complex (gfc_expr *x, gfc_expr *y) { - if (int_or_real_check (x, 0) == FAILURE) - return FAILURE; - if (scalar_check (x, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (x, 0)) + return false; + if (!scalar_check (x, 0)) + return false; - if (int_or_real_check (y, 1) == FAILURE) - return FAILURE; - if (scalar_check (y, 1) == FAILURE) - return FAILURE; + if (!int_or_real_check (y, 1)) + return false; + if (!scalar_check (y, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) { - if (logical_array_check (mask, 0) == FAILURE) - return FAILURE; - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; - if (dim_rank_check (dim, mask, 0) == FAILURE) - return FAILURE; - if (kind_check (kind, 2, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!logical_array_check (mask, 0)) + return false; + if (!dim_check (dim, 1, false)) + return false; + if (!dim_rank_check (dim, mask, 0)) + return false; + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) { - if (array_check (array, 0) == FAILURE) - return FAILURE; + if (!array_check (array, 0)) + return false; - if (type_check (shift, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (shift, 1, BT_INTEGER)) + return false; - if (dim_check (dim, 2, true) == FAILURE) - return FAILURE; + if (!dim_check (dim, 2, true)) + return false; - if (dim_rank_check (dim, array, false) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, array, false)) + return false; if (array->rank == 1 || shift->rank == 0) { - if (scalar_check (shift, 1) == FAILURE) - return FAILURE; + if (!scalar_check (shift, 1)) + return false; } else if (shift->rank == array->rank - 1) { @@ -1375,7 +1374,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) gfc_current_intrinsic, &shift->where, i + 1, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); - return FAILURE; + return false; } j += 1; @@ -1387,44 +1386,44 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ctime (gfc_expr *time) { - if (scalar_check (time, 0) == FAILURE) - return FAILURE; + if (!scalar_check (time, 0)) + return false; - if (type_check (time, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (time, 0, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x) +bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x) { - if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE) - return FAILURE; + if (!double_check (y, 0) || !double_check (x, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) { - if (numeric_check (x, 0) == FAILURE) - return FAILURE; + if (!numeric_check (x, 0)) + return false; if (y != NULL) { - if (numeric_check (y, 1) == FAILURE) - return FAILURE; + if (!numeric_check (y, 1)) + return false; if (x->ts.type == BT_COMPLEX) { @@ -1432,7 +1431,7 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); - return FAILURE; + return false; } if (y->ts.type == BT_COMPLEX) @@ -1441,89 +1440,89 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) "of either REAL or INTEGER", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_dble (gfc_expr *x) { - if (numeric_check (x, 0) == FAILURE) - return FAILURE; + if (!numeric_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_digits (gfc_expr *x) { - if (int_or_real_check (x, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) { switch (vector_a->ts.type) { case BT_LOGICAL: - if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE) - return FAILURE; + if (!type_check (vector_b, 1, BT_LOGICAL)) + return false; break; case BT_INTEGER: case BT_REAL: case BT_COMPLEX: - if (numeric_check (vector_b, 1) == FAILURE) - return FAILURE; + if (!numeric_check (vector_b, 1)) + return false; break; default: gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector_a->where); - return FAILURE; + return false; } - if (rank_check (vector_a, 0, 1) == FAILURE) - return FAILURE; + if (!rank_check (vector_a, 0, 1)) + return false; - if (rank_check (vector_b, 1, 1) == FAILURE) - return FAILURE; + if (!rank_check (vector_b, 1, 1)) + return false; if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) { gfc_error ("Different shape for arguments '%s' and '%s' at %L for " "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &vector_a->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_dprod (gfc_expr *x, gfc_expr *y) { - if (type_check (x, 0, BT_REAL) == FAILURE - || type_check (y, 1, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL) + || !type_check (y, 1, BT_REAL)) + return false; if (x->ts.kind != gfc_default_real_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " "real", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); - return FAILURE; + return false; } if (y->ts.kind != gfc_default_real_kind) @@ -1531,75 +1530,75 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " "real", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (j, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (j, 1, BT_INTEGER)) + return false; if (i->is_boz && j->is_boz) { gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal " "constants", &i->where, &j->where); - return FAILURE; + return false; } - if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE) - return FAILURE; + if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1)) + return false; - if (type_check (shift, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (shift, 2, BT_INTEGER)) + return false; - if (nonnegative_check ("SHIFT", shift) == FAILURE) - return FAILURE; + if (!nonnegative_check ("SHIFT", shift)) + return false; if (i->is_boz) { - if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE) - return FAILURE; + if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true)) + return false; i->ts.kind = j->ts.kind; } else { - if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE) - return FAILURE; + if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) + return false; j->ts.kind = i->ts.kind; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { - if (array_check (array, 0) == FAILURE) - return FAILURE; + if (!array_check (array, 0)) + return false; - if (type_check (shift, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (shift, 1, BT_INTEGER)) + return false; - if (dim_check (dim, 3, true) == FAILURE) - return FAILURE; + if (!dim_check (dim, 3, true)) + return false; - if (dim_rank_check (dim, array, false) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, array, false)) + return false; if (array->rank == 1 || shift->rank == 0) { - if (scalar_check (shift, 1) == FAILURE) - return FAILURE; + if (!scalar_check (shift, 1)) + return false; } else if (shift->rank == array->rank - 1) { @@ -1625,7 +1624,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_current_intrinsic, &shift->where, i + 1, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); - return FAILURE; + return false; } j += 1; @@ -1637,28 +1636,28 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); - return FAILURE; + return false; } if (boundary != NULL) { - if (same_type_check (array, 0, boundary, 2) == FAILURE) - return FAILURE; + if (!same_type_check (array, 0, boundary, 2)) + return false; if (array->rank == 1 || boundary->rank == 0) { - if (scalar_check (boundary, 2) == FAILURE) - return FAILURE; + if (!scalar_check (boundary, 2)) + return false; } else if (boundary->rank == array->rank - 1) { - if (gfc_check_conformance (shift, boundary, - "arguments '%s' and '%s' for " - "intrinsic %s", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic ) == FAILURE) - return FAILURE; + if (!gfc_check_conformance (shift, boundary, + "arguments '%s' and '%s' for " + "intrinsic %s", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic)) + return false; } else { @@ -1666,197 +1665,197 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, "rank %d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); - return FAILURE; + return false; } } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_float (gfc_expr *a) { - if (type_check (a, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_INTEGER)) + return false; if ((a->ts.kind != gfc_default_integer_kind) - && gfc_notify_std (GFC_STD_GNU, "non-default INTEGER " - "kind argument to %s intrinsic at %L", - gfc_current_intrinsic, &a->where) == FAILURE ) - return FAILURE; + && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER " + "kind argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where)) + return false; - return SUCCESS; + return true; } /* A single complex argument. */ -gfc_try +bool gfc_check_fn_c (gfc_expr *a) { - if (type_check (a, 0, BT_COMPLEX) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_COMPLEX)) + return false; - return SUCCESS; + return true; } /* A single real argument. */ -gfc_try +bool gfc_check_fn_r (gfc_expr *a) { - if (type_check (a, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_REAL)) + return false; - return SUCCESS; + return true; } /* A single double argument. */ -gfc_try +bool gfc_check_fn_d (gfc_expr *a) { - if (double_check (a, 0) == FAILURE) - return FAILURE; + if (!double_check (a, 0)) + return false; - return SUCCESS; + return true; } /* A single real or complex argument. */ -gfc_try +bool gfc_check_fn_rc (gfc_expr *a) { - if (real_or_complex_check (a, 0) == FAILURE) - return FAILURE; + if (!real_or_complex_check (a, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_fn_rc2008 (gfc_expr *a) { - if (real_or_complex_check (a, 0) == FAILURE) - return FAILURE; + if (!real_or_complex_check (a, 0)) + return false; if (a->ts.type == BT_COMPLEX - && gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' " - "argument of '%s' intrinsic at %L", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' " + "argument of '%s' intrinsic at %L", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_fnum (gfc_expr *unit) { - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_huge (gfc_expr *x) { - if (int_or_real_check (x, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_hypot (gfc_expr *x, gfc_expr *y) { - if (type_check (x, 0, BT_REAL) == FAILURE) - return FAILURE; - if (same_type_check (x, 0, y, 1) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL)) + return false; + if (!same_type_check (x, 0, y, 1)) + return false; - return SUCCESS; + return true; } /* Check that the single argument is an integer. */ -gfc_try +bool gfc_check_i (gfc_expr *i) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_iand (gfc_expr *i, gfc_expr *j) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (j, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (j, 1, BT_INTEGER)) + return false; if (i->ts.kind != j->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &i->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", + &i->where)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (pos, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (pos, 1, BT_INTEGER)) + return false; - if (type_check (len, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (len, 2, BT_INTEGER)) + return false; - if (nonnegative_check ("pos", pos) == FAILURE) - return FAILURE; + if (!nonnegative_check ("pos", pos)) + return false; - if (nonnegative_check ("len", len) == FAILURE) - return FAILURE; + if (!nonnegative_check ("len", len)) + return false; - if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE) - return FAILURE; + if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) { int i; - if (type_check (c, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (c, 0, BT_CHARACTER)) + return false; - if (kind_check (kind, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!kind_check (kind, 1, BT_INTEGER)) + return false; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING) { @@ -1879,11 +1878,11 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) { /* If we already have a length for this expression then use it. */ if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return SUCCESS; + return true; i = mpz_get_si (c->ts.u.cl->length->value.integer); } else - return SUCCESS; + return true; } else { @@ -1893,73 +1892,73 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) gcc_assert (start); if (end == NULL || end->expr_type != EXPR_CONSTANT || start->expr_type != EXPR_CONSTANT) - return SUCCESS; + return true; i = mpz_get_si (end->value.integer) + 1 - mpz_get_si (start->value.integer); } } else - return SUCCESS; + return true; if (i != 1) { gfc_error ("Argument of %s at %L must be of length one", gfc_current_intrinsic, &c->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_idnint (gfc_expr *a) { - if (double_check (a, 0) == FAILURE) - return FAILURE; + if (!double_check (a, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ieor (gfc_expr *i, gfc_expr *j) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (j, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (j, 1, BT_INTEGER)) + return false; if (i->ts.kind != j->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &i->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", + &i->where)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, gfc_expr *kind) { - if (type_check (string, 0, BT_CHARACTER) == FAILURE - || type_check (substring, 1, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (string, 0, BT_CHARACTER) + || !type_check (substring, 1, BT_CHARACTER)) + return false; - if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE) - return FAILURE; + if (back != NULL && !type_check (back, 2, BT_LOGICAL)) + return false; - if (kind_check (kind, 3, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 3, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; if (string->ts.kind != substring->ts.kind) { @@ -1967,86 +1966,86 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, "kind as '%s'", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &substring->where, gfc_current_intrinsic_arg[0]->name); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_int (gfc_expr *x, gfc_expr *kind) { - if (numeric_check (x, 0) == FAILURE) - return FAILURE; + if (!numeric_check (x, 0)) + return false; - if (kind_check (kind, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!kind_check (kind, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_intconv (gfc_expr *x) { - if (numeric_check (x, 0) == FAILURE) - return FAILURE; + if (!numeric_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ior (gfc_expr *i, gfc_expr *j) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (j, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (j, 1, BT_INTEGER)) + return false; if (i->ts.kind != j->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &i->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", + &i->where)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ishft (gfc_expr *i, gfc_expr *shift) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (shift, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER) + || !type_check (shift, 1, BT_INTEGER)) + return false; - if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE) - return FAILURE; + if (!less_than_bitsize1 ("I", i, NULL, shift, true)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (shift, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER) + || !type_check (shift, 1, BT_INTEGER)) + return false; if (size != NULL) { int i2, i3; - if (type_check (size, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (size, 2, BT_INTEGER)) + return false; - if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE) - return FAILURE; + if (!less_than_bitsize1 ("I", i, "SIZE", size, true)) + return false; if (size->expr_type == EXPR_CONSTANT) { @@ -2054,7 +2053,7 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) if (i3 <= 0) { gfc_error ("SIZE at %L must be positive", &size->where); - return FAILURE; + return false; } if (shift->expr_type == EXPR_CONSTANT) @@ -2068,60 +2067,60 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) gfc_error ("The absolute value of SHIFT at %L must be less " "than or equal to SIZE at %L", &shift->where, &size->where); - return FAILURE; + return false; } } } } - else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE) - return FAILURE; + else if (!less_than_bitsize1 ("I", i, NULL, shift, true)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_kill (gfc_expr *pid, gfc_expr *sig) { - if (type_check (pid, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (pid, 0, BT_INTEGER)) + return false; - if (type_check (sig, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (sig, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) { - if (type_check (pid, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (pid, 0, BT_INTEGER)) + return false; - if (scalar_check (pid, 0) == FAILURE) - return FAILURE; + if (!scalar_check (pid, 0)) + return false; - if (type_check (sig, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (sig, 1, BT_INTEGER)) + return false; - if (scalar_check (sig, 1) == FAILURE) - return FAILURE; + if (!scalar_check (sig, 1)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER)) + return false; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_kind (gfc_expr *x) { if (x->ts.type == BT_DERIVED) @@ -2129,220 +2128,220 @@ gfc_check_kind (gfc_expr *x) gfc_error ("'%s' argument of '%s' intrinsic at %L must be a " "non-derived type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - if (array_check (array, 0) == FAILURE) - return FAILURE; + if (!array_check (array, 0)) + return false; - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, false)) + return false; - if (dim_rank_check (dim, array, 1) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, array, 1)) + return false; - if (kind_check (kind, 2, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) { if (gfc_option.coarray == GFC_FCOARRAY_NONE) { gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return FAILURE; + return false; } - if (coarray_check (coarray, 0) == FAILURE) - return FAILURE; + if (!coarray_check (coarray, 0)) + return false; if (dim != NULL) { - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, false)) + return false; - if (dim_corank_check (dim, coarray) == FAILURE) - return FAILURE; + if (!dim_corank_check (dim, coarray)) + return false; } - if (kind_check (kind, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!kind_check (kind, 2, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) { - if (type_check (s, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (s, 0, BT_CHARACTER)) + return false; - if (kind_check (kind, 1, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) { - if (type_check (a, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (a, 0, gfc_default_character_kind)) + return false; - if (type_check (b, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (b, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (b, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_link (gfc_expr *path1, gfc_expr *path2) { - if (type_check (path1, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; - if (type_check (path2, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { - if (type_check (path1, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; - if (type_check (path2, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 0, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER)) + return false; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_loc (gfc_expr *expr) { return variable_check (expr, 0, true); } -gfc_try +bool gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) { - if (type_check (path1, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; - if (type_check (path2, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { - if (type_check (path1, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; - if (type_check (path2, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER)) + return false; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_logical (gfc_expr *a, gfc_expr *kind) { - if (type_check (a, 0, BT_LOGICAL) == FAILURE) - return FAILURE; - if (kind_check (kind, 1, BT_LOGICAL) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_LOGICAL)) + return false; + if (!kind_check (kind, 1, BT_LOGICAL)) + return false; - return SUCCESS; + return true; } /* Min/max family. */ -static gfc_try +static bool min_max_args (gfc_actual_arglist *arg) { if (arg == NULL || arg->next == NULL) { gfc_error ("Intrinsic '%s' at %L must have at least two arguments", gfc_current_intrinsic, gfc_current_intrinsic_where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -static gfc_try +static bool check_rest (bt type, int kind, gfc_actual_arglist *arglist) { gfc_actual_arglist *arg, *tmp; @@ -2350,8 +2349,8 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) gfc_expr *x; int m, n; - if (min_max_args (arglist) == FAILURE) - return FAILURE; + if (!min_max_args (arglist)) + return false; for (arg = arglist, n=1; arg; arg = arg->next, n++) { @@ -2360,74 +2359,74 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) { if (x->ts.type == type) { - if (gfc_notify_std (GFC_STD_GNU, "Different type " - "kinds at %L", &x->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_GNU, "Different type " + "kinds at %L", &x->where)) + return false; } else { gfc_error ("'a%d' argument of '%s' intrinsic at %L must be " "%s(%d)", n, gfc_current_intrinsic, &x->where, gfc_basic_typename (type), kind); - return FAILURE; + return false; } } for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) - if (gfc_check_conformance (tmp->expr, x, - "arguments 'a%d' and 'a%d' for " - "intrinsic '%s'", m, n, - gfc_current_intrinsic) == FAILURE) - return FAILURE; + if (!gfc_check_conformance (tmp->expr, x, + "arguments 'a%d' and 'a%d' for " + "intrinsic '%s'", m, n, + gfc_current_intrinsic)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_min_max (gfc_actual_arglist *arg) { gfc_expr *x; - if (min_max_args (arg) == FAILURE) - return FAILURE; + if (!min_max_args (arg)) + return false; x = arg->expr; if (x->ts.type == BT_CHARACTER) { - if (gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with CHARACTER argument at %L", - gfc_current_intrinsic, &x->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with CHARACTER argument at %L", + gfc_current_intrinsic, &x->where)) + return false; } else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) { gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, " "REAL or CHARACTER", gfc_current_intrinsic, &x->where); - return FAILURE; + return false; } return check_rest (x->ts.type, x->ts.kind, arg); } -gfc_try +bool gfc_check_min_max_integer (gfc_actual_arglist *arg) { return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); } -gfc_try +bool gfc_check_min_max_real (gfc_actual_arglist *arg) { return check_rest (BT_REAL, gfc_default_real_kind, arg); } -gfc_try +bool gfc_check_min_max_double (gfc_actual_arglist *arg) { return check_rest (BT_REAL, gfc_default_double_kind, arg); @@ -2436,20 +2435,20 @@ gfc_check_min_max_double (gfc_actual_arglist *arg) /* End of min/max family. */ -gfc_try +bool gfc_check_malloc (gfc_expr *size) { - if (type_check (size, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (size, 0, BT_INTEGER)) + return false; - if (scalar_check (size, 0) == FAILURE) - return FAILURE; + if (!scalar_check (size, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) @@ -2457,7 +2456,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); - return FAILURE; + return false; } if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) @@ -2465,7 +2464,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &matrix_b->where); - return FAILURE; + return false; } if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) @@ -2474,14 +2473,14 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)", gfc_current_intrinsic, &matrix_a->where, gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); - return FAILURE; + return false; } switch (matrix_a->rank) { case 1: - if (rank_check (matrix_b, 1, 2) == FAILURE) - return FAILURE; + if (!rank_check (matrix_b, 1, 2)) + return false; /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) { @@ -2489,15 +2488,15 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) "and '%s' at %L for intrinsic matmul", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &matrix_a->where); - return FAILURE; + return false; } break; case 2: if (matrix_b->rank != 2) { - if (rank_check (matrix_b, 1, 1) == FAILURE) - return FAILURE; + if (!rank_check (matrix_b, 1, 1)) + return false; } /* matrix_b has rank 1 or 2 here. Common check for the cases - matrix_a has shape (n,m) and matrix_b has shape (m, k) @@ -2508,7 +2507,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) "dimension 1 for argument '%s' at %L for intrinsic " "matmul", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &matrix_a->where); - return FAILURE; + return false; } break; @@ -2516,10 +2515,10 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank " "1 or 2", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } @@ -2537,14 +2536,14 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) I.e. in the case of minloc(array,mask), mask will be in the second position of the argument list and we'll have to fix that up. */ -gfc_try +bool gfc_check_minloc_maxloc (gfc_actual_arglist *ap) { gfc_expr *a, *m, *d; a = ap->expr; - if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (a, 0) || !array_check (a, 0)) + return false; d = ap->next->expr; m = ap->next->next->expr; @@ -2558,24 +2557,24 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) ap->next->next->expr = m; } - if (dim_check (d, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (d, 1, false)) + return false; - if (dim_rank_check (d, a, 0) == FAILURE) - return FAILURE; + if (!dim_rank_check (d, a, 0)) + return false; - if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE) - return FAILURE; + if (m != NULL && !type_check (m, 2, BT_LOGICAL)) + return false; if (m != NULL - && gfc_check_conformance (a, m, - "arguments '%s' and '%s' for intrinsic %s", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic ) == FAILURE) - return FAILURE; + && !gfc_check_conformance (a, m, + "arguments '%s' and '%s' for intrinsic %s", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic)) + return false; - return SUCCESS; + return true; } @@ -2594,7 +2593,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) I.e. in the case of minval(array,mask), mask will be in the second position of the argument list and we'll have to fix that up. */ -static gfc_try +static bool check_reduction (gfc_actual_arglist *ap) { gfc_expr *a, *m, *d; @@ -2612,44 +2611,44 @@ check_reduction (gfc_actual_arglist *ap) ap->next->next->expr = m; } - if (dim_check (d, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (d, 1, false)) + return false; - if (dim_rank_check (d, a, 0) == FAILURE) - return FAILURE; + if (!dim_rank_check (d, a, 0)) + return false; - if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE) - return FAILURE; + if (m != NULL && !type_check (m, 2, BT_LOGICAL)) + return false; if (m != NULL - && gfc_check_conformance (a, m, - "arguments '%s' and '%s' for intrinsic %s", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic) == FAILURE) - return FAILURE; + && !gfc_check_conformance (a, m, + "arguments '%s' and '%s' for intrinsic %s", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_minval_maxval (gfc_actual_arglist *ap) { - if (int_or_real_check (ap->expr, 0) == FAILURE - || array_check (ap->expr, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (ap->expr, 0) + || !array_check (ap->expr, 0)) + return false; return check_reduction (ap); } -gfc_try +bool gfc_check_product_sum (gfc_actual_arglist *ap) { - if (numeric_check (ap->expr, 0) == FAILURE - || array_check (ap->expr, 0) == FAILURE) - return FAILURE; + if (!numeric_check (ap->expr, 0) + || !array_check (ap->expr, 0)) + return false; return check_reduction (ap); } @@ -2657,33 +2656,33 @@ gfc_check_product_sum (gfc_actual_arglist *ap) /* For IANY, IALL and IPARITY. */ -gfc_try +bool gfc_check_mask (gfc_expr *i, gfc_expr *kind) { int k; - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (nonnegative_check ("I", i) == FAILURE) - return FAILURE; + if (!nonnegative_check ("I", i)) + return false; - if (kind_check (kind, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!kind_check (kind, 1, BT_INTEGER)) + return false; if (kind) gfc_extract_int (kind, &k); else k = gfc_default_integer_kind; - if (less_than_bitsizekind ("I", i, k) == FAILURE) - return FAILURE; + if (!less_than_bitsizekind ("I", i, k)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) { if (ap->expr->ts.type != BT_INTEGER) @@ -2691,77 +2690,77 @@ gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &ap->expr->where); - return FAILURE; + return false; } - if (array_check (ap->expr, 0) == FAILURE) - return FAILURE; + if (!array_check (ap->expr, 0)) + return false; return check_reduction (ap); } -gfc_try +bool gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { - if (same_type_check (tsource, 0, fsource, 1) == FAILURE) - return FAILURE; + if (!same_type_check (tsource, 0, fsource, 1)) + return false; - if (type_check (mask, 2, BT_LOGICAL) == FAILURE) - return FAILURE; + if (!type_check (mask, 2, BT_LOGICAL)) + return false; if (tsource->ts.type == BT_CHARACTER) return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic"); - return SUCCESS; + return true; } -gfc_try +bool gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (j, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (j, 1, BT_INTEGER)) + return false; - if (type_check (mask, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (mask, 2, BT_INTEGER)) + return false; - if (same_type_check (i, 0, j, 1) == FAILURE) - return FAILURE; + if (!same_type_check (i, 0, j, 1)) + return false; - if (same_type_check (i, 0, mask, 2) == FAILURE) - return FAILURE; + if (!same_type_check (i, 0, mask, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) { - if (variable_check (from, 0, false) == FAILURE) - return FAILURE; - if (allocatable_check (from, 0) == FAILURE) - return FAILURE; + if (!variable_check (from, 0, false)) + return false; + if (!allocatable_check (from, 0)) + return false; if (gfc_is_coindexed (from)) { gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be " "coindexed", &from->where); - return FAILURE; + return false; } - if (variable_check (to, 1, false) == FAILURE) - return FAILURE; - if (allocatable_check (to, 1) == FAILURE) - return FAILURE; + if (!variable_check (to, 1, false)) + return false; + if (!allocatable_check (to, 1)) + return false; if (gfc_is_coindexed (to)) { gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be " "coindexed", &to->where); - return FAILURE; + return false; } if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) @@ -2769,18 +2768,18 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " "polymorphic if FROM is polymorphic", &to->where); - return FAILURE; + return false; } - if (same_type_check (to, 1, from, 0) == FAILURE) - return FAILURE; + if (!same_type_check (to, 1, from, 0)) + return false; if (to->rank != from->rank) { gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " "must have the same rank %d/%d", &to->where, from->rank, to->rank); - return FAILURE; + return false; } /* IR F08/0040; cf. 12-006A. */ @@ -2789,7 +2788,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " "must have the same corank %d/%d", &to->where, gfc_get_corank (from), gfc_get_corank (to)); - return FAILURE; + return false; } /* CLASS arguments: Make sure the vtab of from is present. */ @@ -2801,18 +2800,18 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) gfc_find_intrinsic_vtab (&from->ts); } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_nearest (gfc_expr *x, gfc_expr *s) { - if (type_check (x, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL)) + return false; - if (type_check (s, 1, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (s, 1, BT_REAL)) + return false; if (s->expr_type == EXPR_CONSTANT) { @@ -2820,49 +2819,49 @@ gfc_check_nearest (gfc_expr *x, gfc_expr *s) { gfc_error ("Argument 'S' of NEAREST at %L shall not be zero", &s->where); - return FAILURE; + return false; } } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_new_line (gfc_expr *a) { - if (type_check (a, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_CHARACTER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) { - if (type_check (array, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (array, 0, BT_REAL)) + return false; - if (array_check (array, 0) == FAILURE) - return FAILURE; + if (!array_check (array, 0)) + return false; - if (dim_rank_check (dim, array, false) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, array, false)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_null (gfc_expr *mold) { symbol_attribute attr; if (mold == NULL) - return SUCCESS; + return true; - if (variable_check (mold, 0, true) == FAILURE) - return FAILURE; + if (!variable_check (mold, 0, true)) + return false; attr = gfc_variable_attr (mold, NULL); @@ -2872,13 +2871,13 @@ gfc_check_null (gfc_expr *mold) "ALLOCATABLE or procedure pointer", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); - return FAILURE; + return false; } if (attr.allocatable - && gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " - "allocatable MOLD at %L", &mold->where) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " + "allocatable MOLD at %L", &mold->where)) + return false; /* F2008, C1242. */ if (gfc_is_coindexed (mold)) @@ -2886,44 +2885,44 @@ gfc_check_null (gfc_expr *mold) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) { - if (array_check (array, 0) == FAILURE) - return FAILURE; + if (!array_check (array, 0)) + return false; - if (type_check (mask, 1, BT_LOGICAL) == FAILURE) - return FAILURE; + if (!type_check (mask, 1, BT_LOGICAL)) + return false; - if (gfc_check_conformance (array, mask, - "arguments '%s' and '%s' for intrinsic '%s'", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic) == FAILURE) - return FAILURE; + if (!gfc_check_conformance (array, mask, + "arguments '%s' and '%s' for intrinsic '%s'", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic)) + return false; if (vector != NULL) { mpz_t array_size, vector_size; bool have_array_size, have_vector_size; - if (same_type_check (array, 0, vector, 2) == FAILURE) - return FAILURE; + if (!same_type_check (array, 0, vector, 2)) + return false; - if (rank_check (vector, 2, 1) == FAILURE) - return FAILURE; + if (!rank_check (vector, 2, 1)) + return false; /* VECTOR requires at least as many elements as MASK has .TRUE. values. */ - have_array_size = gfc_array_size (array, &array_size) == SUCCESS; - have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS; + have_array_size = gfc_array_size(array, &array_size); + have_vector_size = gfc_array_size(vector, &vector_size); if (have_vector_size && (mask->expr_type == EXPR_ARRAY @@ -2962,7 +2961,7 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) gfc_current_intrinsic, &vector->where, gfc_current_intrinsic_arg[1]->name, mpz_get_si (vector_size), mask_true_values); - return FAILURE; + return false; } } @@ -2972,43 +2971,43 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) mpz_clear (vector_size); } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_parity (gfc_expr *mask, gfc_expr *dim) { - if (type_check (mask, 0, BT_LOGICAL) == FAILURE) - return FAILURE; + if (!type_check (mask, 0, BT_LOGICAL)) + return false; - if (array_check (mask, 0) == FAILURE) - return FAILURE; + if (!array_check (mask, 0)) + return false; - if (dim_rank_check (dim, mask, false) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, mask, false)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_precision (gfc_expr *x) { - if (real_or_complex_check (x, 0) == FAILURE) - return FAILURE; + if (!real_or_complex_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_present (gfc_expr *a) { gfc_symbol *sym; - if (variable_check (a, 0, true) == FAILURE) - return FAILURE; + if (!variable_check (a, 0, true)) + return false; sym = a->symtree->n.sym; if (!sym->attr.dummy) @@ -3016,7 +3015,7 @@ gfc_check_present (gfc_expr *a) gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a " "dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); - return FAILURE; + return false; } if (!sym->attr.optional) @@ -3025,7 +3024,7 @@ gfc_check_present (gfc_expr *a) "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); - return FAILURE; + return false; } /* 13.14.82 PRESENT(A) @@ -3043,34 +3042,34 @@ gfc_check_present (gfc_expr *a) gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a " "subobject of '%s'", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where, sym->name); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_radix (gfc_expr *x) { - if (int_or_real_check (x, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_range (gfc_expr *x) { - if (numeric_check (x, 0) == FAILURE) - return FAILURE; + if (!numeric_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED) { /* Any data object is allowed; a "data object" is a "constant (4.1.3), @@ -3090,90 +3089,90 @@ gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED) { gfc_error ("The argument of the RANK intrinsic at %L must be a data " "object", &a->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* real, float, sngl. */ -gfc_try +bool gfc_check_real (gfc_expr *a, gfc_expr *kind) { - if (numeric_check (a, 0) == FAILURE) - return FAILURE; + if (!numeric_check (a, 0)) + return false; - if (kind_check (kind, 1, BT_REAL) == FAILURE) - return FAILURE; + if (!kind_check (kind, 1, BT_REAL)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_rename (gfc_expr *path1, gfc_expr *path2) { - if (type_check (path1, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; - if (type_check (path2, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { - if (type_check (path1, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; - if (type_check (path2, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER)) + return false; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_repeat (gfc_expr *x, gfc_expr *y) { - if (type_check (x, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_CHARACTER)) + return false; - if (scalar_check (x, 0) == FAILURE) - return FAILURE; + if (!scalar_check (x, 0)) + return false; - if (type_check (y, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (y, 0, BT_INTEGER)) + return false; - if (scalar_check (y, 1) == FAILURE) - return FAILURE; + if (!scalar_check (y, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_expr *pad, gfc_expr *order) { @@ -3181,20 +3180,20 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, mpz_t nelems; int shape_size; - if (array_check (source, 0) == FAILURE) - return FAILURE; + if (!array_check (source, 0)) + return false; - if (rank_check (shape, 1, 1) == FAILURE) - return FAILURE; + if (!rank_check (shape, 1, 1)) + return false; - if (type_check (shape, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (shape, 1, BT_INTEGER)) + return false; - if (gfc_array_size (shape, &size) != SUCCESS) + if (!gfc_array_size (shape, &size)) { gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an " "array of constant size", &shape->where); - return FAILURE; + return false; } shape_size = mpz_get_ui (size); @@ -3205,13 +3204,13 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_error ("'%s' argument of '%s' intrinsic at %L is empty", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shape->where); - return FAILURE; + return false; } else if (shape_size > GFC_MAX_DIMENSIONS) { gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more " "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); - return FAILURE; + return false; } else if (shape->expr_type == EXPR_ARRAY) { @@ -3230,27 +3229,27 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, "negative element (%d)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &e->where, extent); - return FAILURE; + return false; } } } if (pad != NULL) { - if (same_type_check (source, 0, pad, 2) == FAILURE) - return FAILURE; + if (!same_type_check (source, 0, pad, 2)) + return false; - if (array_check (pad, 2) == FAILURE) - return FAILURE; + if (!array_check (pad, 2)) + return false; } if (order != NULL) { - if (array_check (order, 3) == FAILURE) - return FAILURE; + if (!array_check (order, 3)) + return false; - if (type_check (order, 3, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (order, 3, BT_INTEGER)) + return false; if (order->expr_type == EXPR_ARRAY) { @@ -3271,7 +3270,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &order->where, order_size, shape_size); - return FAILURE; + return false; } for (i = 1; i <= order_size; ++i) @@ -3288,7 +3287,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, "has out-of-range dimension (%d)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); - return FAILURE; + return false; } if (perm[dim-1] != 0) @@ -3298,7 +3297,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, "'%d' duplicated)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); - return FAILURE; + return false; } perm[dim-1] = 1; @@ -3312,7 +3311,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE)) { /* Check the match in size between source and destination. */ - if (gfc_array_size (source, &nelems) == SUCCESS) + if (gfc_array_size (source, &nelems)) { gfc_constructor *c; bool test; @@ -3332,16 +3331,16 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_error ("Without padding, there are not enough elements " "in the intrinsic RESHAPE source at %L to match " "the shape", &source->where); - return FAILURE; + return false; } } } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) { if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) @@ -3351,7 +3350,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where, gfc_typename (&a->ts)); - return FAILURE; + return false; } if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) @@ -3360,7 +3359,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) "must be of an extensible type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); - return FAILURE; + return false; } if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) @@ -3370,7 +3369,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &b->where, gfc_typename (&b->ts)); - return FAILURE; + return false; } if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) @@ -3379,162 +3378,162 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) "must be of an extensible type", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &b->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_scale (gfc_expr *x, gfc_expr *i) { - if (type_check (x, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL)) + return false; - if (type_check (i, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) { - if (type_check (x, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_CHARACTER)) + return false; - if (type_check (y, 1, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (y, 1, BT_CHARACTER)) + return false; - if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE) - return FAILURE; + if (z != NULL && !type_check (z, 2, BT_LOGICAL)) + return false; - if (kind_check (kind, 3, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 3, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - if (same_type_check (x, 0, y, 1) == FAILURE) - return FAILURE; + if (!same_type_check (x, 0, y, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_secnds (gfc_expr *r) { - if (type_check (r, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (r, 0, BT_REAL)) + return false; - if (kind_value_check (r, 0, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (r, 0, 4)) + return false; - if (scalar_check (r, 0) == FAILURE) - return FAILURE; + if (!scalar_check (r, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_selected_char_kind (gfc_expr *name) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - if (scalar_check (name, 0) == FAILURE) - return FAILURE; + if (!scalar_check (name, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_selected_int_kind (gfc_expr *r) { - if (type_check (r, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (r, 0, BT_INTEGER)) + return false; - if (scalar_check (r, 0) == FAILURE) - return FAILURE; + if (!scalar_check (r, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) { if (p == NULL && r == NULL - && gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" - " neither 'P' nor 'R' argument at %L", - gfc_current_intrinsic_where) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" + " neither 'P' nor 'R' argument at %L", + gfc_current_intrinsic_where)) + return false; if (p) { - if (type_check (p, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (p, 0, BT_INTEGER)) + return false; - if (scalar_check (p, 0) == FAILURE) - return FAILURE; + if (!scalar_check (p, 0)) + return false; } if (r) { - if (type_check (r, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (r, 1, BT_INTEGER)) + return false; - if (scalar_check (r, 1) == FAILURE) - return FAILURE; + if (!scalar_check (r, 1)) + return false; } if (radix) { - if (type_check (radix, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (radix, 1, BT_INTEGER)) + return false; - if (scalar_check (radix, 1) == FAILURE) - return FAILURE; + if (!scalar_check (radix, 1)) + return false; - if (gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with " - "RADIX argument at %L", gfc_current_intrinsic, - &radix->where) == FAILURE) - return FAILURE; + if (!gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with " + "RADIX argument at %L", gfc_current_intrinsic, + &radix->where)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) { - if (type_check (x, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL)) + return false; - if (type_check (i, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_shape (gfc_expr *source, gfc_expr *kind) { gfc_array_ref *ar; if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) - return SUCCESS; + return true; ar = gfc_find_array_ref (source); @@ -3542,77 +3541,77 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind) { gfc_error ("'source' argument of 'shape' intrinsic at %L must not be " "an assumed size array", &source->where); - return FAILURE; + return false; } - if (kind_check (kind, 1, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_shift (gfc_expr *i, gfc_expr *shift) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (type_check (shift, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (shift, 0, BT_INTEGER)) + return false; - if (nonnegative_check ("SHIFT", shift) == FAILURE) - return FAILURE; + if (!nonnegative_check ("SHIFT", shift)) + return false; - if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE) - return FAILURE; + if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_sign (gfc_expr *a, gfc_expr *b) { - if (int_or_real_check (a, 0) == FAILURE) - return FAILURE; + if (!int_or_real_check (a, 0)) + return false; - if (same_type_check (a, 0, b, 1) == FAILURE) - return FAILURE; + if (!same_type_check (a, 0, b, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - if (array_check (array, 0) == FAILURE) - return FAILURE; + if (!array_check (array, 0)) + return false; - if (dim_check (dim, 1, true) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, true)) + return false; - if (dim_rank_check (dim, array, 0) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, array, 0)) + return false; - if (kind_check (kind, 2, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_sizeof (gfc_expr *arg) { if (arg->ts.type == BT_PROCEDURE) @@ -3620,7 +3619,7 @@ gfc_check_sizeof (gfc_expr *arg) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); - return FAILURE; + return false; } if (arg->ts.type == BT_ASSUMED) @@ -3628,7 +3627,7 @@ gfc_check_sizeof (gfc_expr *arg) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); - return FAILURE; + return false; } if (arg->rank && arg->expr_type == EXPR_VARIABLE @@ -3639,21 +3638,22 @@ gfc_check_sizeof (gfc_expr *arg) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an " "assumed-size array", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } /* Check whether an expression is interoperable. When returning false, msg is set to a string telling why the expression is not interoperable, otherwise, it is set to NULL. The msg string can be used in diagnostics. - If all_len_okay is true, all length-type parameters (for character) are - allowed. Required for C_LOC (cf. Fortran 2003corr5 or Fortran 2008). */ + If c_loc is true, character with len > 1 are allowed (cf. Fortran + 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape + arrays are permitted. */ static bool -is_c_interoperable (gfc_expr *expr, const char **msg, bool all_len_okay) +is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc) { *msg = NULL; @@ -3703,10 +3703,10 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool all_len_okay) } if (expr->ts.u.cl && expr->ts.u.cl->length - && gfc_simplify_expr (expr, 0) == FAILURE) + && !gfc_simplify_expr (expr, 0)) gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed"); - if (!all_len_okay && expr->ts.u.cl + if (!c_loc && expr->ts.u.cl && (!expr->ts.u.cl->length || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)) @@ -3726,7 +3726,7 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool all_len_okay) return false; } - if (expr->rank > 0 && expr->expr_type != EXPR_ARRAY) + if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY) { gfc_array_ref *ar = gfc_find_array_ref (expr); if (ar->type != AR_FULL) @@ -3745,18 +3745,18 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool all_len_okay) } -gfc_try +bool gfc_check_c_sizeof (gfc_expr *arg) { const char *msg; - if (is_c_interoperable (arg, &msg, false) != SUCCESS) + if (!is_c_interoperable (arg, &msg, false)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be an " "interoperable data entity: %s", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where, msg); - return FAILURE; + return false; } if (arg->ts.type == BT_ASSUMED) @@ -3765,7 +3765,7 @@ gfc_check_c_sizeof (gfc_expr *arg) "TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); - return FAILURE; + return false; } if (arg->rank && arg->expr_type == EXPR_VARIABLE @@ -3776,14 +3776,14 @@ gfc_check_c_sizeof (gfc_expr *arg) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an " "assumed-size array", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) { if (c_ptr_1->ts.type != BT_DERIVED @@ -3793,11 +3793,11 @@ gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) { gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); - return FAILURE; + return false; } - if (scalar_check (c_ptr_1, 0) == FAILURE) - return FAILURE; + if (!scalar_check (c_ptr_1, 0)) + return false; if (c_ptr_2 && (c_ptr_2->ts.type != BT_DERIVED @@ -3809,17 +3809,17 @@ gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where, gfc_typename (&c_ptr_1->ts), gfc_typename (&c_ptr_2->ts)); - return FAILURE; + return false; } - if (c_ptr_2 && scalar_check (c_ptr_2, 1) == FAILURE) - return FAILURE; + if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) { symbol_attribute attr; @@ -3831,11 +3831,11 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) { gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the " "type TYPE(C_PTR)", &cptr->where); - return FAILURE; + return false; } - if (scalar_check (cptr, 0) == FAILURE) - return FAILURE; + if (!scalar_check (cptr, 0)) + return false; attr = gfc_expr_attr (fptr); @@ -3843,53 +3843,53 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) { gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer", &fptr->where); - return FAILURE; + return false; } if (fptr->ts.type == BT_CLASS) { gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic", &fptr->where); - return FAILURE; + return false; } if (gfc_is_coindexed (fptr)) { gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be " "coindexed", &fptr->where); - return FAILURE; + return false; } if (fptr->rank == 0 && shape) { gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar " "FPTR", &fptr->where); - return FAILURE; + return false; } else if (fptr->rank && !shape) { gfc_error ("Expected SHAPE argument to C_F_POINTER with array " "FPTR at %L", &fptr->where); - return FAILURE; + return false; } - if (shape && rank_check (shape, 2, 1) == FAILURE) - return FAILURE; + if (shape && !rank_check (shape, 2, 1)) + return false; - if (shape && type_check (shape, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (shape && !type_check (shape, 2, BT_INTEGER)) + return false; if (shape) { mpz_t size; - if (gfc_array_size (shape, &size) == SUCCESS + if (gfc_array_size (shape, &size) && mpz_cmp_ui (size, fptr->rank) != 0) { mpz_clear (size); gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same " "size as the RANK of FPTR", &shape->where); - return FAILURE; + return false; } mpz_clear (size); } @@ -3897,18 +3897,18 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) if (fptr->ts.type == BT_CLASS) { gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where); - return FAILURE; + return false; } if (!is_c_interoperable (fptr, &msg, false) && fptr->rank) return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR " "at %L to C_F_POINTER: %s", &fptr->where, msg); - return SUCCESS; + return true; } -gfc_try +bool gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr) { symbol_attribute attr; @@ -3919,11 +3919,11 @@ gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr) { gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the " "type TYPE(C_FUNPTR)", &cptr->where); - return FAILURE; + return false; } - if (scalar_check (cptr, 0) == FAILURE) - return FAILURE; + if (!scalar_check (cptr, 0)) + return false; attr = gfc_expr_attr (fptr); @@ -3931,25 +3931,25 @@ gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr) { gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure " "pointer", &fptr->where); - return FAILURE; + return false; } if (gfc_is_coindexed (fptr)) { gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be " "coindexed", &fptr->where); - return FAILURE; + return false; } if (!attr.is_bind_c) return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure " "pointer at %L to C_F_PROCPOINTER", &fptr->where); - return SUCCESS; + return true; } -gfc_try +bool gfc_check_c_funloc (gfc_expr *x) { symbol_attribute attr; @@ -3958,7 +3958,7 @@ gfc_check_c_funloc (gfc_expr *x) { gfc_error ("Argument X at %L to C_FUNLOC shall not be " "coindexed", &x->where); - return FAILURE; + return false; } attr = gfc_expr_attr (x); @@ -3973,7 +3973,7 @@ gfc_check_c_funloc (gfc_expr *x) { gfc_error ("Function result '%s' at %L is invalid as X argument " "to C_FUNLOC", x->symtree->n.sym->name, &x->where); - return FAILURE; + return false; } } @@ -3981,17 +3981,17 @@ gfc_check_c_funloc (gfc_expr *x) { gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure " "or a procedure pointer", &x->where); - return FAILURE; + return false; } if (!attr.is_bind_c) return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure " "at %L to C_FUNLOC", &x->where); - return SUCCESS; + return true; } -gfc_try +bool gfc_check_c_loc (gfc_expr *x) { symbol_attribute attr; @@ -4000,14 +4000,14 @@ gfc_check_c_loc (gfc_expr *x) if (gfc_is_coindexed (x)) { gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where); - return FAILURE; + return false; } if (x->ts.type == BT_CLASS) { gfc_error ("X argument at %L to C_LOC shall not be polymorphic", &x->where); - return FAILURE; + return false; } attr = gfc_expr_attr (x); @@ -4018,7 +4018,7 @@ gfc_check_c_loc (gfc_expr *x) { gfc_error ("Argument X at %L to C_LOC shall have either " "the POINTER or the TARGET attribute", &x->where); - return FAILURE; + return false; } if (x->ts.type == BT_CHARACTER @@ -4026,7 +4026,7 @@ gfc_check_c_loc (gfc_expr *x) { gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized " "string", &x->where); - return FAILURE; + return false; } if (!is_c_interoperable (x, &msg, true)) @@ -4035,47 +4035,64 @@ gfc_check_c_loc (gfc_expr *x) { gfc_error ("Argument at %L to C_LOC shall not be polymorphic", &x->where); - return FAILURE; + return false; } if (x->rank - && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array at %L as" - " argument to C_LOC: %s", &x->where, msg) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_F2008_TS, + "Noninteroperable array at %L as" + " argument to C_LOC: %s", &x->where, msg)) + return false; } + else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008)) + { + gfc_array_ref *ar = gfc_find_array_ref (x); - return SUCCESS; + if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE + && !attr.allocatable + && !gfc_notify_std (GFC_STD_F2008, + "Array of interoperable type at %L " + "to C_LOC which is nonallocatable and neither " + "assumed size nor explicit size", &x->where)) + return false; + else if (ar->type != AR_FULL + && !gfc_notify_std (GFC_STD_F2008, "Array section at %L " + "to C_LOC", &x->where)) + return false; + } + + return true; } -gfc_try +bool gfc_check_sleep_sub (gfc_expr *seconds) { - if (type_check (seconds, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (seconds, 0, BT_INTEGER)) + return false; - if (scalar_check (seconds, 0) == FAILURE) - return FAILURE; + if (!scalar_check (seconds, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_sngl (gfc_expr *a) { - if (type_check (a, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (a, 0, BT_REAL)) + return false; if ((a->ts.kind != gfc_default_double_kind) - && gfc_notify_std (GFC_STD_GNU, "non double precision " - "REAL argument to %s intrinsic at %L", - gfc_current_intrinsic, &a->where) == FAILURE) - return FAILURE; + && !gfc_notify_std (GFC_STD_GNU, "non double precision " + "REAL argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) { if (source->rank >= GFC_MAX_DIMENSIONS) @@ -4084,14 +4101,14 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) "than rank %d", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); - return FAILURE; + return false; } if (dim == NULL) - return FAILURE; + return false; - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, false)) + return false; /* dim_rank_check() does not apply here. */ if (dim @@ -4102,251 +4119,251 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid " "dimension index", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &dim->where); - return FAILURE; + return false; } - if (type_check (ncopies, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (ncopies, 2, BT_INTEGER)) + return false; - if (scalar_check (ncopies, 2) == FAILURE) - return FAILURE; + if (!scalar_check (ncopies, 2)) + return false; - return SUCCESS; + return true; } /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and functions). */ -gfc_try +bool gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) { - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - if (type_check (c, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (c, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (c, 1, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE - || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE - || scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER) + || !kind_value_check (status, 2, gfc_default_integer_kind) + || !scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) { return gfc_check_fgetputc_sub (unit, c, NULL); } -gfc_try +bool gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) { - if (type_check (c, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (c, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (c, 0, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 1, BT_INTEGER) == FAILURE - || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE - || scalar_check (status, 1) == FAILURE) - return FAILURE; + if (!type_check (status, 1, BT_INTEGER) + || !kind_value_check (status, 1, gfc_default_integer_kind) + || !scalar_check (status, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_fgetput (gfc_expr *c) { return gfc_check_fgetput_sub (c, NULL); } -gfc_try +bool gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) { - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - if (type_check (offset, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (offset, 1, BT_INTEGER)) + return false; - if (scalar_check (offset, 1) == FAILURE) - return FAILURE; + if (!scalar_check (offset, 1)) + return false; - if (type_check (whence, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (whence, 2, BT_INTEGER)) + return false; - if (scalar_check (whence, 2) == FAILURE) - return FAILURE; + if (!scalar_check (whence, 2)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 3, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 3, BT_INTEGER)) + return false; - if (kind_value_check (status, 3, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (status, 3, 4)) + return false; - if (scalar_check (status, 3) == FAILURE) - return FAILURE; + if (!scalar_check (status, 3)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_fstat (gfc_expr *unit, gfc_expr *array) { - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - if (type_check (array, 1, BT_INTEGER) == FAILURE - || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (unit, 0, gfc_default_integer_kind)) + return false; - if (array_check (array, 1) == FAILURE) - return FAILURE; + if (!array_check (array, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) { - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - if (type_check (array, 1, BT_INTEGER) == FAILURE - || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; - if (array_check (array, 1) == FAILURE) - return FAILURE; + if (!array_check (array, 1)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE - || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER) + || !kind_value_check (status, 2, gfc_default_integer_kind)) + return false; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ftell (gfc_expr *unit) { - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) { - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - if (type_check (offset, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (offset, 1, BT_INTEGER)) + return false; - if (scalar_check (offset, 1) == FAILURE) - return FAILURE; + if (!scalar_check (offset, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_stat (gfc_expr *name, gfc_expr *array) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - if (type_check (array, 1, BT_INTEGER) == FAILURE - || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; - if (array_check (array, 1) == FAILURE) - return FAILURE; + if (!array_check (array, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - if (type_check (array, 1, BT_INTEGER) == FAILURE - || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; - if (array_check (array, 1) == FAILURE) - return FAILURE; + if (!array_check (array, 1)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE - || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) { mpz_t nelems; @@ -4354,20 +4371,20 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) if (gfc_option.coarray == GFC_FCOARRAY_NONE) { gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return FAILURE; + return false; } - if (coarray_check (coarray, 0) == FAILURE) - return FAILURE; + if (!coarray_check (coarray, 0)) + return false; if (sub->rank != 1) { gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", gfc_current_intrinsic_arg[1]->name, &sub->where); - return FAILURE; + return false; } - if (gfc_array_size (sub, &nelems) == SUCCESS) + if (gfc_array_size (sub, &nelems)) { int corank = gfc_get_corank (coarray); @@ -4377,53 +4394,53 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) "IMAGE_INDEX at %L shall be %d (corank) not %d", &sub->where, corank, (int) mpz_get_si (nelems)); mpz_clear (nelems); - return FAILURE; + return false; } mpz_clear (nelems); } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim) { if (gfc_option.coarray == GFC_FCOARRAY_NONE) { gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return FAILURE; + return false; } if (dim != NULL && coarray == NULL) { gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE " "intrinsic at %L", &dim->where); - return FAILURE; + return false; } if (coarray == NULL) - return SUCCESS; + return true; - if (coarray_check (coarray, 0) == FAILURE) - return FAILURE; + if (!coarray_check (coarray, 0)) + return false; if (dim != NULL) { - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, false)) + return false; - if (dim_corank_check (dim, coarray) == FAILURE) - return FAILURE; + if (!dim_corank_check (dim, coarray)) + return false; } - return SUCCESS; + return true; } /* Calculate the sizes for transfer, used by gfc_check_transfer and also - by gfc_simplify_transfer. Return FAILURE if we cannot do so. */ + by gfc_simplify_transfer. Return false if we cannot do so. */ -gfc_try +bool gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, size_t *source_size, size_t *result_size, size_t *result_length_p) @@ -4433,19 +4450,19 @@ gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, gfc_expr *mold_element; if (source->expr_type == EXPR_FUNCTION) - return FAILURE; + return false; if (size && size->expr_type != EXPR_CONSTANT) - return FAILURE; + return false; /* Calculate the size of the source. */ if (source->expr_type == EXPR_ARRAY - && gfc_array_size (source, &tmp) == FAILURE) - return FAILURE; + && !gfc_array_size (source, &tmp)) + return false; *source_size = gfc_target_expr_size (source); if (*source_size == 0) - return FAILURE; + return false; mold_element = mold->expr_type == EXPR_ARRAY ? gfc_constructor_first (mold->value.constructor)->expr @@ -4454,7 +4471,7 @@ gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, /* Determine the size of the element. */ result_elt_size = gfc_target_expr_size (mold_element); if (result_elt_size == 0) - return FAILURE; + return false; if (mold->expr_type == EXPR_ARRAY || mold->rank || size) { @@ -4476,11 +4493,11 @@ gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, else *result_size = result_elt_size; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) { size_t source_size; @@ -4490,120 +4507,120 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) { gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s", &mold->where, gfc_basic_typename (BT_HOLLERITH)); - return FAILURE; + return false; } if (size != NULL) { - if (type_check (size, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (size, 2, BT_INTEGER)) + return false; - if (scalar_check (size, 2) == FAILURE) - return FAILURE; + if (!scalar_check (size, 2)) + return false; - if (nonoptional_check (size, 2) == FAILURE) - return FAILURE; + if (!nonoptional_check (size, 2)) + return false; } if (!gfc_option.warn_surprising) - return SUCCESS; + return true; /* If we can't calculate the sizes, we cannot check any more. - Return SUCCESS for that case. */ + Return true for that case. */ - if (gfc_calculate_transfer_sizes (source, mold, size, &source_size, - &result_size, NULL) == FAILURE) - return SUCCESS; + if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, + &result_size, NULL)) + return true; if (source_size < result_size) gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: " "source size %ld < result size %ld", &source->where, (long) source_size, (long) result_size); - return SUCCESS; + return true; } -gfc_try +bool gfc_check_transpose (gfc_expr *matrix) { - if (rank_check (matrix, 0, 2) == FAILURE) - return FAILURE; + if (!rank_check (matrix, 0, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - if (array_check (array, 0) == FAILURE) - return FAILURE; + if (!array_check (array, 0)) + return false; - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, false)) + return false; - if (dim_rank_check (dim, array, 0) == FAILURE) - return FAILURE; + if (!dim_rank_check (dim, array, 0)) + return false; - if (kind_check (kind, 2, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) { if (gfc_option.coarray == GFC_FCOARRAY_NONE) { gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return FAILURE; + return false; } - if (coarray_check (coarray, 0) == FAILURE) - return FAILURE; + if (!coarray_check (coarray, 0)) + return false; if (dim != NULL) { - if (dim_check (dim, 1, false) == FAILURE) - return FAILURE; + if (!dim_check (dim, 1, false)) + return false; - if (dim_corank_check (dim, coarray) == FAILURE) - return FAILURE; + if (!dim_corank_check (dim, coarray)) + return false; } - if (kind_check (kind, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!kind_check (kind, 2, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { mpz_t vector_size; - if (rank_check (vector, 0, 1) == FAILURE) - return FAILURE; + if (!rank_check (vector, 0, 1)) + return false; - if (array_check (mask, 1) == FAILURE) - return FAILURE; + if (!array_check (mask, 1)) + return false; - if (type_check (mask, 1, BT_LOGICAL) == FAILURE) - return FAILURE; + if (!type_check (mask, 1, BT_LOGICAL)) + return false; - if (same_type_check (vector, 0, field, 2) == FAILURE) - return FAILURE; + if (!same_type_check (vector, 0, field, 2)) + return false; if (mask->expr_type == EXPR_ARRAY - && gfc_array_size (vector, &vector_size) == SUCCESS) + && gfc_array_size (vector, &vector_size)) { int mask_true_count = 0; gfc_constructor *mask_ctor; @@ -4630,7 +4647,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector->where, gfc_current_intrinsic_arg[1]->name, mpz_get_si (vector_size), mask_true_count); - return FAILURE; + return false; } mpz_clear (vector_size); @@ -4642,7 +4659,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) "the same rank as '%s' or be a scalar", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, &field->where, gfc_current_intrinsic_arg[1]->name); - return FAILURE; + return false; } if (mask->rank == field->rank) @@ -4659,202 +4676,201 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) } } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) { - if (type_check (x, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_CHARACTER)) + return false; - if (same_type_check (x, 0, y, 1) == FAILURE) - return FAILURE; + if (!same_type_check (x, 0, y, 1)) + return false; - if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE) - return FAILURE; + if (z != NULL && !type_check (z, 2, BT_LOGICAL)) + return false; - if (kind_check (kind, 3, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where) == FAILURE) - return FAILURE; + if (!kind_check (kind, 3, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_trim (gfc_expr *x) { - if (type_check (x, 0, BT_CHARACTER) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_CHARACTER)) + return false; - if (scalar_check (x, 0) == FAILURE) - return FAILURE; + if (!scalar_check (x, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ttynam (gfc_expr *unit) { - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - return SUCCESS; + return true; } /* Common check function for the half a dozen intrinsics that have a single real argument. */ -gfc_try +bool gfc_check_x (gfc_expr *x) { - if (type_check (x, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL)) + return false; - return SUCCESS; + return true; } /************* Check functions for intrinsic subroutines *************/ -gfc_try +bool gfc_check_cpu_time (gfc_expr *time) { - if (scalar_check (time, 0) == FAILURE) - return FAILURE; + if (!scalar_check (time, 0)) + return false; - if (type_check (time, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (time, 0, BT_REAL)) + return false; - if (variable_check (time, 0, false) == FAILURE) - return FAILURE; + if (!variable_check (time, 0, false)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, gfc_expr *zone, gfc_expr *values) { if (date != NULL) { - if (type_check (date, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; - if (scalar_check (date, 0) == FAILURE) - return FAILURE; - if (variable_check (date, 0, false) == FAILURE) - return FAILURE; + if (!type_check (date, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (date, 0, gfc_default_character_kind)) + return false; + if (!scalar_check (date, 0)) + return false; + if (!variable_check (date, 0, false)) + return false; } if (time != NULL) { - if (type_check (time, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; - if (scalar_check (time, 1) == FAILURE) - return FAILURE; - if (variable_check (time, 1, false) == FAILURE) - return FAILURE; + if (!type_check (time, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (time, 1, gfc_default_character_kind)) + return false; + if (!scalar_check (time, 1)) + return false; + if (!variable_check (time, 1, false)) + return false; } if (zone != NULL) { - if (type_check (zone, 2, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE) - return FAILURE; - if (scalar_check (zone, 2) == FAILURE) - return FAILURE; - if (variable_check (zone, 2, false) == FAILURE) - return FAILURE; + if (!type_check (zone, 2, BT_CHARACTER)) + return false; + if (!kind_value_check (zone, 2, gfc_default_character_kind)) + return false; + if (!scalar_check (zone, 2)) + return false; + if (!variable_check (zone, 2, false)) + return false; } if (values != NULL) { - if (type_check (values, 3, BT_INTEGER) == FAILURE) - return FAILURE; - if (array_check (values, 3) == FAILURE) - return FAILURE; - if (rank_check (values, 3, 1) == FAILURE) - return FAILURE; - if (variable_check (values, 3, false) == FAILURE) - return FAILURE; + if (!type_check (values, 3, BT_INTEGER)) + return false; + if (!array_check (values, 3)) + return false; + if (!rank_check (values, 3, 1)) + return false; + if (!variable_check (values, 3, false)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, gfc_expr *to, gfc_expr *topos) { - if (type_check (from, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (from, 0, BT_INTEGER)) + return false; - if (type_check (frompos, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (frompos, 1, BT_INTEGER)) + return false; - if (type_check (len, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (len, 2, BT_INTEGER)) + return false; - if (same_type_check (from, 0, to, 3) == FAILURE) - return FAILURE; + if (!same_type_check (from, 0, to, 3)) + return false; - if (variable_check (to, 3, false) == FAILURE) - return FAILURE; + if (!variable_check (to, 3, false)) + return false; - if (type_check (topos, 4, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (topos, 4, BT_INTEGER)) + return false; - if (nonnegative_check ("frompos", frompos) == FAILURE) - return FAILURE; + if (!nonnegative_check ("frompos", frompos)) + return false; - if (nonnegative_check ("topos", topos) == FAILURE) - return FAILURE; + if (!nonnegative_check ("topos", topos)) + return false; - if (nonnegative_check ("len", len) == FAILURE) - return FAILURE; + if (!nonnegative_check ("len", len)) + return false; - if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len) - == FAILURE) - return FAILURE; + if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)) + return false; - if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE) - return FAILURE; + if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_random_number (gfc_expr *harvest) { - if (type_check (harvest, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (harvest, 0, BT_REAL)) + return false; - if (variable_check (harvest, 0, false) == FAILURE) - return FAILURE; + if (!variable_check (harvest, 0, false)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) { unsigned int nargs = 0, kiss_size; @@ -4874,17 +4890,17 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) || !size->symtree->n.sym->attr.optional) nargs++; - if (scalar_check (size, 0) == FAILURE) - return FAILURE; + if (!scalar_check (size, 0)) + return false; - if (type_check (size, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (size, 0, BT_INTEGER)) + return false; - if (variable_check (size, 0, false) == FAILURE) - return FAILURE; + if (!variable_check (size, 0, false)) + return false; - if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (size, 0, gfc_default_integer_kind)) + return false; } if (put != NULL) @@ -4896,19 +4912,19 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) where = &put->where; } - if (array_check (put, 1) == FAILURE) - return FAILURE; + if (!array_check (put, 1)) + return false; - if (rank_check (put, 1, 1) == FAILURE) - return FAILURE; + if (!rank_check (put, 1, 1)) + return false; - if (type_check (put, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (put, 1, BT_INTEGER)) + return false; - if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (put, 1, gfc_default_integer_kind)) + return false; - if (gfc_array_size (put, &put_size) == SUCCESS + if (gfc_array_size (put, &put_size) && mpz_get_ui (put_size) < kiss_size) gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " "too small (%i/%i)", @@ -4925,22 +4941,22 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) where = &get->where; } - if (array_check (get, 2) == FAILURE) - return FAILURE; + if (!array_check (get, 2)) + return false; - if (rank_check (get, 2, 1) == FAILURE) - return FAILURE; + if (!rank_check (get, 2, 1)) + return false; - if (type_check (get, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (get, 2, BT_INTEGER)) + return false; - if (variable_check (get, 2, false) == FAILURE) - return FAILURE; + if (!variable_check (get, 2, false)) + return false; - if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (get, 2, gfc_default_integer_kind)) + return false; - if (gfc_array_size (get, &get_size) == SUCCESS + if (gfc_array_size (get, &get_size) && mpz_get_ui (get_size) < kiss_size) gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " "too small (%i/%i)", @@ -4952,287 +4968,287 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) if (nargs > 1) gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where); - return SUCCESS; + return true; } -gfc_try +bool gfc_check_second_sub (gfc_expr *time) { - if (scalar_check (time, 0) == FAILURE) - return FAILURE; + if (!scalar_check (time, 0)) + return false; - if (type_check (time, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (time, 0, BT_REAL)) + return false; - if (kind_value_check(time, 0, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (time, 0, 4)) + return false; - return SUCCESS; + return true; } /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note, count, count_rate, and count_max are all optional arguments */ -gfc_try +bool gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, gfc_expr *count_max) { if (count != NULL) { - if (scalar_check (count, 0) == FAILURE) - return FAILURE; + if (!scalar_check (count, 0)) + return false; - if (type_check (count, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (count, 0, BT_INTEGER)) + return false; - if (variable_check (count, 0, false) == FAILURE) - return FAILURE; + if (!variable_check (count, 0, false)) + return false; } if (count_rate != NULL) { - if (scalar_check (count_rate, 1) == FAILURE) - return FAILURE; + if (!scalar_check (count_rate, 1)) + return false; - if (type_check (count_rate, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (count_rate, 1, BT_INTEGER)) + return false; - if (variable_check (count_rate, 1, false) == FAILURE) - return FAILURE; + if (!variable_check (count_rate, 1, false)) + return false; if (count != NULL - && same_type_check (count, 0, count_rate, 1) == FAILURE) - return FAILURE; + && !same_type_check (count, 0, count_rate, 1)) + return false; } if (count_max != NULL) { - if (scalar_check (count_max, 2) == FAILURE) - return FAILURE; + if (!scalar_check (count_max, 2)) + return false; - if (type_check (count_max, 2, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (count_max, 2, BT_INTEGER)) + return false; - if (variable_check (count_max, 2, false) == FAILURE) - return FAILURE; + if (!variable_check (count_max, 2, false)) + return false; if (count != NULL - && same_type_check (count, 0, count_max, 2) == FAILURE) - return FAILURE; + && !same_type_check (count, 0, count_max, 2)) + return false; if (count_rate != NULL - && same_type_check (count_rate, 1, count_max, 2) == FAILURE) - return FAILURE; + && !same_type_check (count_rate, 1, count_max, 2)) + return false; } - return SUCCESS; + return true; } -gfc_try +bool gfc_check_irand (gfc_expr *x) { if (x == NULL) - return SUCCESS; + return true; - if (scalar_check (x, 0) == FAILURE) - return FAILURE; + if (!scalar_check (x, 0)) + return false; - if (type_check (x, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_INTEGER)) + return false; - if (kind_value_check(x, 0, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (x, 0, 4)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) { - if (scalar_check (seconds, 0) == FAILURE) - return FAILURE; - if (type_check (seconds, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!scalar_check (seconds, 0)) + return false; + if (!type_check (seconds, 0, BT_INTEGER)) + return false; - if (int_or_proc_check (handler, 1) == FAILURE) - return FAILURE; - if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) - return FAILURE; + if (!int_or_proc_check (handler, 1)) + return false; + if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; - if (type_check (status, 2, BT_INTEGER) == FAILURE) - return FAILURE; - if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!scalar_check (status, 2)) + return false; + if (!type_check (status, 2, BT_INTEGER)) + return false; + if (!kind_value_check (status, 2, gfc_default_integer_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_rand (gfc_expr *x) { if (x == NULL) - return SUCCESS; + return true; - if (scalar_check (x, 0) == FAILURE) - return FAILURE; + if (!scalar_check (x, 0)) + return false; - if (type_check (x, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_INTEGER)) + return false; - if (kind_value_check(x, 0, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (x, 0, 4)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_srand (gfc_expr *x) { - if (scalar_check (x, 0) == FAILURE) - return FAILURE; + if (!scalar_check (x, 0)) + return false; - if (type_check (x, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_INTEGER)) + return false; - if (kind_value_check(x, 0, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (x, 0, 4)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) { - if (scalar_check (time, 0) == FAILURE) - return FAILURE; - if (type_check (time, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!scalar_check (time, 0)) + return false; + if (!type_check (time, 0, BT_INTEGER)) + return false; - if (type_check (result, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (result, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (result, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_dtime_etime (gfc_expr *x) { - if (array_check (x, 0) == FAILURE) - return FAILURE; + if (!array_check (x, 0)) + return false; - if (rank_check (x, 0, 1) == FAILURE) - return FAILURE; + if (!rank_check (x, 0, 1)) + return false; - if (variable_check (x, 0, false) == FAILURE) - return FAILURE; + if (!variable_check (x, 0, false)) + return false; - if (type_check (x, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL)) + return false; - if (kind_value_check(x, 0, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (x, 0, 4)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) { - if (array_check (values, 0) == FAILURE) - return FAILURE; + if (!array_check (values, 0)) + return false; - if (rank_check (values, 0, 1) == FAILURE) - return FAILURE; + if (!rank_check (values, 0, 1)) + return false; - if (variable_check (values, 0, false) == FAILURE) - return FAILURE; + if (!variable_check (values, 0, false)) + return false; - if (type_check (values, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (values, 0, BT_REAL)) + return false; - if (kind_value_check(values, 0, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (values, 0, 4)) + return false; - if (scalar_check (time, 1) == FAILURE) - return FAILURE; + if (!scalar_check (time, 1)) + return false; - if (type_check (time, 1, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (time, 1, BT_REAL)) + return false; - if (kind_value_check(time, 1, 4) == FAILURE) - return FAILURE; + if (!kind_value_check (time, 1, 4)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_fdate_sub (gfc_expr *date) { - if (type_check (date, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (date, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (date, 0, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_gerror (gfc_expr *msg) { - if (type_check (msg, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (msg, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (msg, 0, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) { - if (type_check (cwd, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (cwd, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (cwd, 0, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (scalar_check (status, 1) == FAILURE) - return FAILURE; + if (!scalar_check (status, 1)) + return false; - if (type_check (status, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_getarg (gfc_expr *pos, gfc_expr *value) { - if (type_check (pos, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (pos, 0, BT_INTEGER)) + return false; if (pos->ts.kind > gfc_default_integer_kind) { @@ -5240,350 +5256,350 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value) "not wider than the default kind (%d)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pos->where, gfc_default_integer_kind); - return FAILURE; + return false; } - if (type_check (value, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (value, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (value, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_getlog (gfc_expr *msg) { - if (type_check (msg, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (msg, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (msg, 0, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_exit (gfc_expr *status) { if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 0, BT_INTEGER)) + return false; - if (scalar_check (status, 0) == FAILURE) - return FAILURE; + if (!scalar_check (status, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_flush (gfc_expr *unit) { if (unit == NULL) - return SUCCESS; + return true; - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_free (gfc_expr *i) { - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (i, 0, BT_INTEGER)) + return false; - if (scalar_check (i, 0) == FAILURE) - return FAILURE; + if (!scalar_check (i, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_hostnm (gfc_expr *name) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (scalar_check (status, 1) == FAILURE) - return FAILURE; + if (!scalar_check (status, 1)) + return false; - if (type_check (status, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_itime_idate (gfc_expr *values) { - if (array_check (values, 0) == FAILURE) - return FAILURE; + if (!array_check (values, 0)) + return false; - if (rank_check (values, 0, 1) == FAILURE) - return FAILURE; + if (!rank_check (values, 0, 1)) + return false; - if (variable_check (values, 0, false) == FAILURE) - return FAILURE; + if (!variable_check (values, 0, false)) + return false; - if (type_check (values, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (values, 0, BT_INTEGER)) + return false; - if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (values, 0, gfc_default_integer_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) { - if (type_check (time, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (time, 0, BT_INTEGER)) + return false; - if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (time, 0, gfc_default_integer_kind)) + return false; - if (scalar_check (time, 0) == FAILURE) - return FAILURE; + if (!scalar_check (time, 0)) + return false; - if (array_check (values, 1) == FAILURE) - return FAILURE; + if (!array_check (values, 1)) + return false; - if (rank_check (values, 1, 1) == FAILURE) - return FAILURE; + if (!rank_check (values, 1, 1)) + return false; - if (variable_check (values, 1, false) == FAILURE) - return FAILURE; + if (!variable_check (values, 1, false)) + return false; - if (type_check (values, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (values, 1, BT_INTEGER)) + return false; - if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (values, 1, gfc_default_integer_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) { - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (type_check (name, 1, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 1, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_isatty (gfc_expr *unit) { if (unit == NULL) - return FAILURE; + return false; - if (type_check (unit, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (unit, 0, BT_INTEGER)) + return false; - if (scalar_check (unit, 0) == FAILURE) - return FAILURE; + if (!scalar_check (unit, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_isnan (gfc_expr *x) { - if (type_check (x, 0, BT_REAL) == FAILURE) - return FAILURE; + if (!type_check (x, 0, BT_REAL)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_perror (gfc_expr *string) { - if (type_check (string, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (string, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (string, 0, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_umask (gfc_expr *mask) { - if (type_check (mask, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (mask, 0, BT_INTEGER)) + return false; - if (scalar_check (mask, 0) == FAILURE) - return FAILURE; + if (!scalar_check (mask, 0)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) { - if (type_check (mask, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (mask, 0, BT_INTEGER)) + return false; - if (scalar_check (mask, 0) == FAILURE) - return FAILURE; + if (!scalar_check (mask, 0)) + return false; if (old == NULL) - return SUCCESS; + return true; - if (scalar_check (old, 1) == FAILURE) - return FAILURE; + if (!scalar_check (old, 1)) + return false; - if (type_check (old, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (old, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_unlink (gfc_expr *name) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) { - if (type_check (name, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (scalar_check (status, 1) == FAILURE) - return FAILURE; + if (!scalar_check (status, 1)) + return false; - if (type_check (status, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 1, BT_INTEGER)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_signal (gfc_expr *number, gfc_expr *handler) { - if (scalar_check (number, 0) == FAILURE) - return FAILURE; - if (type_check (number, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!scalar_check (number, 0)) + return false; + if (!type_check (number, 0, BT_INTEGER)) + return false; - if (int_or_proc_check (handler, 1) == FAILURE) - return FAILURE; - if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) - return FAILURE; + if (!int_or_proc_check (handler, 1)) + return false; + if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) { - if (scalar_check (number, 0) == FAILURE) - return FAILURE; - if (type_check (number, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (!scalar_check (number, 0)) + return false; + if (!type_check (number, 0, BT_INTEGER)) + return false; - if (int_or_proc_check (handler, 1) == FAILURE) - return FAILURE; - if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) - return FAILURE; + if (!int_or_proc_check (handler, 1)) + return false; + if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) + return false; if (status == NULL) - return SUCCESS; + return true; - if (type_check (status, 2, BT_INTEGER) == FAILURE) - return FAILURE; - if (scalar_check (status, 2) == FAILURE) - return FAILURE; + if (!type_check (status, 2, BT_INTEGER)) + return false; + if (!scalar_check (status, 2)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) { - if (type_check (cmd, 0, BT_CHARACTER) == FAILURE) - return FAILURE; - if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE) - return FAILURE; + if (!type_check (cmd, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (cmd, 0, gfc_default_character_kind)) + return false; - if (scalar_check (status, 1) == FAILURE) - return FAILURE; + if (!scalar_check (status, 1)) + return false; - if (type_check (status, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (status, 1, BT_INTEGER)) + return false; - if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE) - return FAILURE; + if (!kind_value_check (status, 1, gfc_default_integer_kind)) + return false; - return SUCCESS; + return true; } /* This is used for the GNU intrinsics AND, OR and XOR. */ -gfc_try +bool gfc_check_and (gfc_expr *i, gfc_expr *j) { if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) @@ -5591,7 +5607,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &i->where); - return FAILURE; + return false; } if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) @@ -5599,7 +5615,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); - return FAILURE; + return false; } if (i->ts.type != j->ts.type) @@ -5608,20 +5624,20 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) "have the same type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); - return FAILURE; + return false; } - if (scalar_check (i, 0) == FAILURE) - return FAILURE; + if (!scalar_check (i, 0)) + return false; - if (scalar_check (j, 1) == FAILURE) - return FAILURE; + if (!scalar_check (j, 1)) + return false; - return SUCCESS; + return true; } -gfc_try +bool gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) { if (a->ts.type == BT_ASSUMED) @@ -5629,7 +5645,7 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); - return FAILURE; + return false; } if (a->ts.type == BT_PROCEDURE) @@ -5637,25 +5653,25 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a " "procedure", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); - return FAILURE; + return false; } if (kind == NULL) - return SUCCESS; + return true; - if (type_check (kind, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (!type_check (kind, 1, BT_INTEGER)) + return false; - if (scalar_check (kind, 1) == FAILURE) - return FAILURE; + if (!scalar_check (kind, 1)) + return false; if (kind->expr_type != EXPR_CONSTANT) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &kind->where); - return FAILURE; + return false; } - return SUCCESS; + return true; } |