/* Check functions
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- Free Software Foundation, Inc.
+ Copyright (C) 2002-2017 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
#include "config.h"
#include "system.h"
-#include "flags.h"
+#include "coretypes.h"
+#include "options.h"
#include "gfortran.h"
#include "intrinsic.h"
#include "constructor.h"
/* 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_error ("%qs argument of %qs 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_error ("%qs argument of %qs 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)
{
+ /* Users sometime use a subroutine designator as an actual argument to
+ an intrinsic subprogram that expects an argument with a numeric type. */
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+ goto error;
+
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_VARIABLE)
+ 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",
+error:
+
+ gfc_error ("%qs argument of %qs intrinsic at %L must have 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
+ gfc_error ("%qs argument of %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs 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 (k->expr_type != EXPR_CONSTANT)
+ if (!gfc_check_init_expr (k))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+ gfc_error ("%qs argument of %qs 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
{
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 "
+ gfc_error ("%qs argument of %qs 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
&& CLASS_DATA (e)->as->corank)
{
gfc_add_class_array_ref (e);
- return SUCCESS;
+ return true;
}
if (!gfc_is_coarray (e))
{
- gfc_error ("Expected coarray variable as '%s' argument to the %s "
+ gfc_error ("Expected coarray variable as %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
+ gfc_error ("%qs argument of %qs 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
&& CLASS_DATA (e)->as->rank)
{
gfc_add_class_array_ref (e);
- return SUCCESS;
+ return true;
}
- if (e->rank != 0)
- return SUCCESS;
+ if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
+ return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
+ gfc_error ("%qs argument of %qs 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;
gfc_extract_int (expr, &i);
if (i < 0)
{
- gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
- return FAILURE;
+ gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
+ 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)
{
{
gfc_extract_int (expr2, &i2);
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
-
+
/* For ISHFT[C], check that |shift| <= bit_size(i). */
if (arg2 == NULL)
{
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("The absolute value of SHIFT at %L must be less "
- "than or equal to BIT_SIZE('%s')",
+ "than or equal to BIT_SIZE(%qs)",
&expr2->where, arg1);
- return FAILURE;
+ return false;
}
}
{
if (i2 > gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s' at %L must be less than "
- "or equal to BIT_SIZE('%s')",
+ gfc_error ("%qs at %L must be less than "
+ "or equal to BIT_SIZE(%qs)",
arg2, &expr2->where, arg1);
- return FAILURE;
+ return false;
}
}
else
{
if (i2 >= gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
+ gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
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);
if (val > gfc_integer_kinds[i].bit_size)
{
- gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
+ gfc_error ("%qs 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)
{
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
if (i2 > gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s + %s' at %L must be less than or equal "
- "to BIT_SIZE('%s')",
+ gfc_error ("%<%s + %s%> at %L must be less than or equal "
+ "to BIT_SIZE(%qs)",
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;
+ gfc_typespec *ets = &e->ts;
+ gfc_typespec *fts = &f->ts;
+
+ if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
+ ets = &e->symtree->n.sym->ts;
+ if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
+ fts = &f->symtree->n.sym->ts;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
- "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
+ if (gfc_compare_types (ets, fts))
+ return true;
+
+ gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
+ "and kind as %qs", 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_error ("%qs argument of %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
}
/* 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;
attr = gfc_variable_attr (e, NULL);
- if (!attr.allocatable)
+ if (!attr.allocatable || attr.associate_var)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_error ("%qs argument of %qs 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_error ("%qs argument of %qs 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
|| (ref->u.c.component->ts.type != BT_CLASS
&& ref->u.c.component->attr.pointer)))
break;
- }
+ }
if (!ref)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
+ gfc_error ("%qs argument of %qs 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)
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_error ("%qs argument of %qs 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;
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);
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
{
- gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
"codimension index", gfc_current_intrinsic, &dim->where);
- return FAILURE;
+ return false;
}
- return SUCCESS;
+ return true;
}
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;
-
- 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)
else
rank = array->rank;
+ /* Assumed-rank array. */
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+
if (array->expr_type == EXPR_VARIABLE)
{
ar = gfc_find_array_ref (array);
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
{
- gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic, &dim->where);
- return FAILURE;
+ return false;
}
- return SUCCESS;
+ return true;
}
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;
-
+
mpz_clear (b_size);
}
mpz_clear (a_size);
{
long start_a, end_a;
- if (ra->u.ss.start->expr_type == EXPR_CONSTANT
+ if (!ra->u.ss.end)
+ return -1;
+
+ if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
&& ra->u.ss.end->expr_type == EXPR_CONSTANT)
{
- start_a = mpz_get_si (ra->u.ss.start->value.integer);
+ start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
+ : 1;
end_a = mpz_get_si (ra->u.ss.end->value.integer);
- return end_a - start_a + 1;
+ return (end_a < start_a) ? 0 : end_a - start_a + 1;
}
- else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
+ else if (ra->u.ss.start
+ && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
return 1;
else
return -1;
}
/* 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;
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;
}
}
/* 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);
/* 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;
-
- return SUCCESS;
+ /* Tests on allocated components of coarrays need to detour the check to
+ argument of the _caf_get. */
+ if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
+ && array->value.function.isym
+ && array->value.function.isym->id == GFC_ISYM_CAF_GET)
+ {
+ array = array->value.function.actual->expr;
+ if (!array->ref)
+ return false;
+ }
+
+ if (!variable_check (array, 0, false))
+ return false;
+ if (!allocatable_check (array, 0))
+ return false;
+
+ 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)
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"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, "Extension: 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;
- if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
- attr1 = gfc_expr_attr (pointer);
- else if (pointer->expr_type == EXPR_NULL)
+ if (pointer->expr_type == EXPR_NULL)
goto null_arg;
- else
- gcc_assert (0); /* Pointer must be a variable or a function. */
+
+ attr1 = gfc_expr_attr (pointer);
if (!attr1.pointer && !attr1.proc_pointer)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pointer->where);
- return FAILURE;
+ return false;
}
/* F2008, C1242. */
if (attr1.pointer && gfc_is_coindexed (pointer))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs 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)
attr2 = gfc_expr_attr (target);
else
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
"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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
+ gfc_error ("%qs argument of %qs 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. */
if (attr1.pointer && gfc_is_coindexed (target))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs 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++)
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;
}
}
null_arg:
gfc_error ("NULL pointer at %L is not permitted as actual argument "
- "of '%s' intrinsic function", where, gfc_current_intrinsic);
- return FAILURE;
+ "of %qs intrinsic function", where, gfc_current_intrinsic);
+ 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
-gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
+static bool
+gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
+ gfc_expr *stat, int stat_no)
{
+ if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no))
+ return false;
+
if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
&& !(atom->ts.type == BT_LOGICAL
&& atom->ts.kind == gfc_atomic_logical_kind))
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)
+ if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom))
{
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)
{
- 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;
+ gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
+ "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
+ gfc_current_intrinsic, &value->where,
+ gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
+ return false;
}
- return SUCCESS;
+ if (stat != NULL)
+ {
+ if (!type_check (stat, stat_no, BT_INTEGER))
+ return false;
+ if (!scalar_check (stat, stat_no))
+ return false;
+ if (!variable_check (stat, stat_no, false))
+ return false;
+ if (!kind_value_check (stat, stat_no, gfc_default_integer_kind))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L",
+ gfc_current_intrinsic, &stat->where))
+ return false;
+ }
+
+ return true;
}
-gfc_try
-gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
+bool
+gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
{
- if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
- return FAILURE;
+ if (atom->expr_type == EXPR_FUNCTION
+ && atom->value.function.isym
+ && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
+ atom = atom->value.function.actual->expr;
- if (gfc_check_vardef_context (atom, 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);
+ return gfc_check_atomic (atom, 0, value, 1, stat, 2);
}
-gfc_try
-gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
+bool
+gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
{
- if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
- return FAILURE;
+ if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
+ {
+ gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+ "integer of ATOMIC_INT_KIND", &atom->where,
+ gfc_current_intrinsic);
+ return false;
+ }
+
+ return gfc_check_atomic_def (atom, value, stat);
+}
- if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
+
+bool
+gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
+{
+ if (atom->expr_type == EXPR_FUNCTION
+ && atom->value.function.isym
+ && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
+ atom = atom->value.function.actual->expr;
+
+ 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, 1, value, 0, stat, 2);
+}
+
+
+bool
+gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
+ gfc_expr *new_val, gfc_expr *stat)
+{
+ if (atom->expr_type == EXPR_FUNCTION
+ && atom->value.function.isym
+ && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
+ atom = atom->value.function.actual->expr;
+
+ if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4))
+ return false;
+
+ if (!scalar_check (old, 1) || !scalar_check (compare, 2))
+ return false;
+
+ if (!same_type_check (atom, 0, old, 1))
+ return false;
+
+ if (!same_type_check (atom, 0, compare, 2))
+ return false;
+
+ 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 false;
+ }
+
+ if (!gfc_check_vardef_context (old, false, false, false, NULL))
+ {
+ gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &old->where);
+ return false;
}
- return gfc_check_atomic (atom, value);
+ return true;
+}
+
+bool
+gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
+{
+ if (event->ts.type != BT_DERIVED
+ || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
+ "shall be of type EVENT_TYPE", &event->where);
+ return false;
+ }
+
+ if (!scalar_check (event, 0))
+ return false;
+
+ if (!gfc_check_vardef_context (count, false, false, false, NULL))
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall be definable", &count->where);
+ return false;
+ }
+
+ if (!type_check (count, 1, BT_INTEGER))
+ return false;
+
+ int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
+ int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+ if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall have at least the range of the default integer",
+ &count->where);
+ return false;
+ }
+
+ if (stat != NULL)
+ {
+ if (!type_check (stat, 2, BT_INTEGER))
+ return false;
+ if (!scalar_check (stat, 2))
+ return false;
+ if (!variable_check (stat, 2, false))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L",
+ gfc_current_intrinsic, &stat->where))
+ return false;
+ }
+
+ return true;
+}
+
+
+bool
+gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
+ gfc_expr *stat)
+{
+ if (atom->expr_type == EXPR_FUNCTION
+ && atom->value.function.isym
+ && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
+ atom = atom->value.function.actual->expr;
+
+ if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
+ {
+ gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+ "integer of ATOMIC_INT_KIND", &atom->where,
+ gfc_current_intrinsic);
+ return false;
+ }
+
+ if (!gfc_check_atomic (atom, 0, value, 1, stat, 3))
+ return false;
+
+ if (!scalar_check (old, 2))
+ return false;
+
+ if (!same_type_check (atom, 0, old, 2))
+ return false;
+
+ 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 false;
+ }
+
+ if (!gfc_check_vardef_context (old, false, false, false, NULL))
+ {
+ gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &old->where);
+ return false;
+ }
+
+ return true;
}
/* 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, "Extension: 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 (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) == FAILURE)
- return FAILURE;
- if (scalar_check (n2, 1) == FAILURE)
- return FAILURE;
- if (nonnegative_check("N2", n2) == FAILURE)
- return FAILURE;
+ 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) == FAILURE)
- return FAILURE;
- if (scalar_check (x, 2) == FAILURE)
- return FAILURE;
+ 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
- "present if 'x' is COMPLEX",
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be "
+ "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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"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))
+ return false;
+
+ if (!kind && warn_conversion
+ && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
+ gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
+ "COMPLEX(%d) at %L might lose precision, consider using "
+ "the KIND argument", gfc_typename (&x->ts),
+ gfc_default_real_kind, &x->where);
+ else if (y && !kind && warn_conversion
+ && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
+ gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
+ "COMPLEX(%d) at %L might lose precision, consider using "
+ "the KIND argument", gfc_typename (&y->ts),
+ gfc_default_real_kind, &y->where);
+ return true;
+}
+
+
+static bool
+check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
+ gfc_expr *errmsg, bool co_reduce)
+{
+ if (!variable_check (a, 0, false))
+ return false;
+
+ if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with "
+ "INTENT(INOUT)"))
+ return false;
+
+ /* Fortran 2008, 12.5.2.4, paragraph 18. */
+ if (gfc_has_vector_subscript (a))
+ {
+ gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
+ "subroutine %s shall not have a vector subscript",
+ &a->where, gfc_current_intrinsic);
+ return false;
+ }
+
+ if (gfc_is_coindexed (a))
+ {
+ gfc_error ("The A argument at %L to the intrinsic %s shall not be "
+ "coindexed", &a->where, gfc_current_intrinsic);
+ return false;
+ }
+
+ if (image_idx != NULL)
+ {
+ if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
+ return false;
+ if (!scalar_check (image_idx, co_reduce ? 2 : 1))
+ return false;
+ }
+
+ if (stat != NULL)
+ {
+ if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER))
+ return false;
+ if (!scalar_check (stat, co_reduce ? 3 : 2))
+ return false;
+ if (!variable_check (stat, co_reduce ? 3 : 2, false))
+ return false;
+ if (stat->ts.kind != 4)
+ {
+ gfc_error ("The stat= argument at %L must be a kind=4 integer "
+ "variable", &stat->where);
+ return false;
}
+ }
+ if (errmsg != NULL)
+ {
+ if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER))
+ return false;
+ if (!scalar_check (errmsg, co_reduce ? 4 : 3))
+ return false;
+ if (!variable_check (errmsg, co_reduce ? 4 : 3, false))
+ return false;
+ if (errmsg->ts.kind != 1)
+ {
+ gfc_error ("The errmsg= argument at %L must be a default-kind "
+ "character variable", &errmsg->where);
+ return false;
+ }
}
- if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
- return FAILURE;
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
+ &a->where);
+ return false;
+ }
- return SUCCESS;
+ return true;
}
-gfc_try
+bool
+gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
+ gfc_expr *errmsg)
+{
+ if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
+ {
+ gfc_error ("Support for the A argument at %L which is polymorphic A "
+ "argument or has allocatable components is not yet "
+ "implemented", &a->where);
+ return false;
+ }
+ return check_co_collective (a, source_image, stat, errmsg, false);
+}
+
+
+bool
+gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
+ gfc_expr *stat, gfc_expr *errmsg)
+{
+ symbol_attribute attr;
+ gfc_formal_arglist *formal;
+ gfc_symbol *sym;
+
+ if (a->ts.type == BT_CLASS)
+ {
+ gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
+ &a->where);
+ return false;
+ }
+
+ if (gfc_expr_attr (a).alloc_comp)
+ {
+ gfc_error ("Support for the A argument at %L with allocatable components"
+ " is not yet implemented", &a->where);
+ return false;
+ }
+
+ if (!check_co_collective (a, result_image, stat, errmsg, true))
+ return false;
+
+ if (!gfc_resolve_expr (op))
+ return false;
+
+ attr = gfc_expr_attr (op);
+ if (!attr.pure || !attr.function)
+ {
+ gfc_error ("OPERATOR argument at %L must be a PURE function",
+ &op->where);
+ return false;
+ }
+
+ if (attr.intrinsic)
+ {
+ /* None of the intrinsics fulfills the criteria of taking two arguments,
+ returning the same type and kind as the arguments and being permitted
+ as actual argument. */
+ gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
+ op->symtree->n.sym->name, &op->where);
+ return false;
+ }
+
+ if (gfc_is_proc_ptr_comp (op))
+ {
+ gfc_component *comp = gfc_get_proc_ptr_comp (op);
+ sym = comp->ts.interface;
+ }
+ else
+ sym = op->symtree->n.sym;
+
+ formal = sym->formal;
+
+ if (!formal || !formal->next || formal->next->next)
+ {
+ gfc_error ("The function passed as OPERATOR at %L shall have two "
+ "arguments", &op->where);
+ return false;
+ }
+
+ if (sym->result->ts.type == BT_UNKNOWN)
+ gfc_set_default_type (sym->result, 0, NULL);
+
+ if (!gfc_compare_types (&a->ts, &sym->result->ts))
+ {
+ gfc_error ("A argument at %L has type %s but the function passed as "
+ "OPERATOR at %L returns %s",
+ &a->where, gfc_typename (&a->ts), &op->where,
+ gfc_typename (&sym->result->ts));
+ return false;
+ }
+ if (!gfc_compare_types (&a->ts, &formal->sym->ts)
+ || !gfc_compare_types (&a->ts, &formal->next->sym->ts))
+ {
+ gfc_error ("The function passed as OPERATOR at %L has arguments of type "
+ "%s and %s but shall have type %s", &op->where,
+ gfc_typename (&formal->sym->ts),
+ gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts));
+ return false;
+ }
+ if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
+ || formal->next->sym->as || formal->sym->attr.allocatable
+ || formal->next->sym->attr.allocatable || formal->sym->attr.pointer
+ || formal->next->sym->attr.pointer)
+ {
+ gfc_error ("The function passed as OPERATOR at %L shall have scalar "
+ "nonallocatable nonpointer arguments and return a "
+ "nonallocatable nonpointer scalar", &op->where);
+ return false;
+ }
+
+ if (formal->sym->attr.value != formal->next->sym->attr.value)
+ {
+ gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
+ "attribute either for none or both arguments", &op->where);
+ return false;
+ }
+
+ if (formal->sym->attr.target != formal->next->sym->attr.target)
+ {
+ gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
+ "attribute either for none or both arguments", &op->where);
+ return false;
+ }
+
+ if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
+ {
+ gfc_error ("The function passed as OPERATOR at %L shall have the "
+ "ASYNCHRONOUS attribute either for none or both arguments",
+ &op->where);
+ return false;
+ }
+
+ if (formal->sym->attr.optional || formal->next->sym->attr.optional)
+ {
+ gfc_error ("The function passed as OPERATOR at %L shall not have the "
+ "OPTIONAL attribute for either of the arguments", &op->where);
+ return false;
+ }
+
+ if (a->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *cl;
+ unsigned long actual_size, formal_size1, formal_size2, result_size;
+
+ cl = a->ts.u.cl;
+ actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+ ? mpz_get_ui (cl->length->value.integer) : 0;
+
+ cl = formal->sym->ts.u.cl;
+ formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+ ? mpz_get_ui (cl->length->value.integer) : 0;
+
+ cl = formal->next->sym->ts.u.cl;
+ formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+ ? mpz_get_ui (cl->length->value.integer) : 0;
+
+ cl = sym->ts.u.cl;
+ result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+ ? mpz_get_ui (cl->length->value.integer) : 0;
+
+ if (actual_size
+ && ((formal_size1 && actual_size != formal_size1)
+ || (formal_size2 && actual_size != formal_size2)))
+ {
+ gfc_error ("The character length of the A argument at %L and of the "
+ "arguments of the OPERATOR at %L shall be the same",
+ &a->where, &op->where);
+ return false;
+ }
+ if (actual_size && result_size && actual_size != result_size)
+ {
+ gfc_error ("The character length of the A argument at %L and of the "
+ "function result of the OPERATOR at %L shall be the same",
+ &a->where, &op->where);
+ return false;
+ }
+ }
+
+ return true;
+}
+
+
+bool
+gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
+ gfc_expr *errmsg)
+{
+ if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
+ && a->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
+ "integer, real or character",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &a->where);
+ return false;
+ }
+ return check_co_collective (a, result_image, stat, errmsg, false);
+}
+
+
+bool
+gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
+ gfc_expr *errmsg)
+{
+ if (!numeric_check (a, 0))
+ return false;
+ return check_co_collective (a, result_image, stat, errmsg, false);
+}
+
+
+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, "Fortran 2003: '%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, "%qs 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)
{
{
if (!identical_dimen_shape (array, i, shift, j))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
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;
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ gfc_error ("%qs argument of intrinsic %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
- "present if 'x' is COMPLEX",
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be "
+ "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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"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 "
+ gfc_error ("%qs argument of %qs 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_error ("Different shape for arguments %qs and %qs 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 "
+ gfc_error ("%qs argument of %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ gfc_error ("%qs argument of %qs 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;
+ gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
+ "constants", &i->where, &j->where);
+ 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)
{
{
if (!identical_dimen_shape (array, i, shift, j))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
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;
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ gfc_error ("%qs argument of intrinsic %qs 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
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+ gfc_error ("%qs argument of intrinsic %qs 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_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, "GNU extension: 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, "Fortran 2008: 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 %qs "
+ "of %qs 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, "Extension: 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, "Fortran 2003: '%s' intrinsic "
- "with KIND argument at %L",
- gfc_current_intrinsic, &kind->where) == FAILURE)
- return FAILURE;
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where))
+ return false;
if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
{
{
/* 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;
+ else
+ return true;
}
else
{
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_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, "Extension: 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, "Fortran 2003: '%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, "%qs intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where))
+ return false;
if (string->ts.kind != substring->ts.kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
- "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
+ "kind as %qs", 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, "Extension: 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)
+ 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)
{
if (i3 <= 0)
{
gfc_error ("SIZE at %L must be positive", &size->where);
- return FAILURE;
+ return false;
}
if (shift->expr_type == EXPR_CONSTANT)
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)
+ if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
- "non-derived type", gfc_current_intrinsic_arg[0]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of "
+ "intrinsic type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
- return FAILURE;
+ return false;
+ }
+ if (x->ts.type == BT_PROCEDURE)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &x->where);
+ 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, "Fortran 2003: '%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, "%qs 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)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return FAILURE;
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ 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, "Fortran 2003: '%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, "%qs 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
-min_max_args (gfc_actual_arglist *arg)
+static bool
+min_max_args (gfc_actual_arglist *args)
{
- if (arg == NULL || arg->next == NULL)
+ gfc_actual_arglist *arg;
+ int i, j, nargs, *nlabels, nlabelless;
+ bool a1 = false, a2 = false;
+
+ if (args == NULL || args->next == NULL)
{
- gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
+ gfc_error ("Intrinsic %qs at %L must have at least two arguments",
gfc_current_intrinsic, gfc_current_intrinsic_where);
- return FAILURE;
- }
-
- return SUCCESS;
-}
-
-
-static gfc_try
+ return false;
+ }
+
+ if (!args->name)
+ a1 = true;
+
+ if (!args->next->name)
+ a2 = true;
+
+ nargs = 0;
+ for (arg = args; arg; arg = arg->next)
+ if (arg->name)
+ nargs++;
+
+ if (nargs == 0)
+ return true;
+
+ /* Note: Having a keywordless argument after an "arg=" is checked before. */
+ nlabelless = 0;
+ nlabels = XALLOCAVEC (int, nargs);
+ for (arg = args, i = 0; arg; arg = arg->next, i++)
+ if (arg->name)
+ {
+ int n;
+ char *endp;
+
+ if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
+ goto unknown;
+ n = strtol (&arg->name[1], &endp, 10);
+ if (endp[0] != '\0')
+ goto unknown;
+ if (n <= 0)
+ goto unknown;
+ if (n <= nlabelless)
+ goto duplicate;
+ nlabels[i] = n;
+ if (n == 1)
+ a1 = true;
+ if (n == 2)
+ a2 = true;
+ }
+ else
+ nlabelless++;
+
+ if (!a1 || !a2)
+ {
+ gfc_error ("Missing %qs argument to the %s intrinsic at %L",
+ !a1 ? "a1" : "a2", gfc_current_intrinsic,
+ gfc_current_intrinsic_where);
+ return false;
+ }
+
+ /* Check for duplicates. */
+ for (i = 0; i < nargs; i++)
+ for (j = i + 1; j < nargs; j++)
+ if (nlabels[i] == nlabels[j])
+ goto duplicate;
+
+ return true;
+
+duplicate:
+ gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
+ &arg->expr->where, gfc_current_intrinsic);
+ return false;
+
+unknown:
+ gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
+ &arg->expr->where, gfc_current_intrinsic);
+ return false;
+}
+
+
+static bool
check_rest (bt type, int kind, gfc_actual_arglist *arglist)
{
gfc_actual_arglist *arg, *tmp;
-
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++)
{
{
if (x->ts.type == type)
{
- if (gfc_notify_std (GFC_STD_GNU, "Extension: 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 "
+ gfc_error ("%<a%d%> argument of %qs 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, "Fortran 2003: '%s' intrinsic "
- "with CHARACTER argument at %L",
- gfc_current_intrinsic, &x->where) == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2003, "%qs 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, "
+ gfc_error ("%<a1%> argument of %qs 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);
/* 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))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ gfc_error ("%qs argument of %qs 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))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ gfc_error ("%qs argument of %qs 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))
|| (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
{
- gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
+ gfc_error ("Argument types of %qs 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))
{
- gfc_error ("Different shape on dimension 1 for arguments '%s' "
- "and '%s' at %L for intrinsic matmul",
+ gfc_error ("Different shape on dimension 1 for arguments %qs "
+ "and %qs 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)
- matrix_a has shape (n,m) and matrix_b has shape (m). */
if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
{
- gfc_error ("Different shape on dimension 2 for argument '%s' and "
- "dimension 1 for argument '%s' at %L for intrinsic "
+ gfc_error ("Different shape on dimension 2 for argument %qs and "
+ "dimension 1 for argument %qs 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;
default:
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
+ gfc_error ("%qs argument of %qs 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;
}
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;
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;
}
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;
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);
}
/* 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
+ gfc_error ("%qs argument of %qs 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 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 false;
+ }
if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
{
gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
"polymorphic if FROM is polymorphic",
- &from->where);
- return FAILURE;
+ &to->where);
+ 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 '%s' and '%s' arguments of '%s' intrinsic at %L must "
- "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &to->where, from->rank, to->rank);
- return FAILURE;
+ 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 false;
}
- if (to->ts.kind != from->ts.kind)
+ /* IR F08/0040; cf. 12-006A. */
+ if (gfc_get_corank (to) != gfc_get_corank (from))
{
- gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
- "be of the same kind %d/%d",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &to->where, from->ts.kind, to->ts.kind);
- return FAILURE;
+ 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 false;
+ }
+
+ /* This is based losely on F2003 12.4.1.7. It is intended to prevent
+ the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
+ and cmp2 are allocatable. After the allocation is transferred,
+ the 'to' chain is broken by the nullification of the 'from'. A bit
+ of reflection reveals that this can only occur for derived types
+ with recursive allocatable components. */
+ if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
+ && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
+ {
+ gfc_ref *to_ref, *from_ref;
+ to_ref = to->ref;
+ from_ref = from->ref;
+ bool aliasing = true;
+
+ for (; from_ref && to_ref;
+ from_ref = from_ref->next, to_ref = to_ref->next)
+ {
+ if (to_ref->type != from->ref->type)
+ aliasing = false;
+ else if (to_ref->type == REF_ARRAY
+ && to_ref->u.ar.type != AR_FULL
+ && from_ref->u.ar.type != AR_FULL)
+ /* Play safe; assume sections and elements are different. */
+ aliasing = false;
+ else if (to_ref->type == REF_COMPONENT
+ && to_ref->u.c.component != from_ref->u.c.component)
+ aliasing = false;
+
+ if (!aliasing)
+ break;
+ }
+
+ if (aliasing)
+ {
+ gfc_error ("The FROM and TO arguments at %L violate aliasing "
+ "restrictions (F2003 12.4.1.7)", &to->where);
+ return false;
+ }
}
/* CLASS arguments: Make sure the vtab of from is present. */
- if (to->ts.type == BT_CLASS)
- gfc_find_derived_vtab (from->ts.u.derived);
+ if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
+ gfc_find_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)
{
if (mpfr_sgn (s->value.real) == 0)
{
- gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
+ 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);
if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
"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, "Fortran 2003: 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))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs 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
if (mpz_get_si (vector_size) < mask_true_values)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
- "are .TRUE. values in '%s' (%ld/%d)",
+ "are .TRUE. values in %qs (%ld/%d)",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic, &vector->where,
gfc_current_intrinsic_arg[1]->name,
mpz_get_si (vector_size), mask_true_values);
- return FAILURE;
+ return false;
}
}
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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
+ gfc_error ("%qs argument of %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of "
"an OPTIONAL dummy variable",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
- return FAILURE;
+ return false;
}
/* 13.14.82 PRESENT(A)
|| (a->ref->u.ar.type == AR_ELEMENT
&& a->ref->u.ar.as->rank == 0))))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
- "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
+ "subobject of %qs", 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
-gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
+bool
+gfc_check_rank (gfc_expr *a)
{
/* Any data object is allowed; a "data object" is a "constant (4.1.3),
variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
bool is_variable = true;
- /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
- if (a->expr_type == EXPR_FUNCTION)
+ /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
+ if (a->expr_type == EXPR_FUNCTION)
is_variable = a->value.function.esym
? a->value.function.esym->result->attr.pointer
: a->symtree->n.sym->result->attr.pointer;
{
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)
{
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 "
+ 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);
if (shape_size <= 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+ gfc_error ("%qs argument of %qs 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 "
+ 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)
+ else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
{
gfc_expr *e;
int i, extent;
gfc_extract_int (e, &extent);
if (extent < 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"negative element (%d)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &e->where, extent);
- return FAILURE;
+ return false;
+ }
+ }
+ }
+ else if (shape->expr_type == EXPR_VARIABLE && shape->ref
+ && shape->ref->u.ar.type == AR_FULL && shape->ref->u.ar.dimen == 1
+ && shape->ref->u.ar.as
+ && shape->ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
+ && shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER
+ && shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT
+ && shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER
+ && shape->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ {
+ int i, extent;
+ gfc_expr *e, *v;
+
+ v = shape->symtree->n.sym->value;
+
+ for (i = 0; i < shape_size; i++)
+ {
+ e = gfc_constructor_lookup_expr (v->value.constructor, i);
+ if (e == NULL)
+ break;
+
+ gfc_extract_int (e, &extent);
+
+ if (extent < 0)
+ {
+ gfc_error ("Element %d of actual argument of RESHAPE at %L "
+ "cannot be negative", i + 1, &shape->where);
+ 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)
+ if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
{
int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
gfc_expr *e;
if (order_size != shape_size)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "has wrong number of elements (%d/%d)",
+ gfc_error ("%qs argument of %qs intrinsic at %L "
+ "has wrong number of elements (%d/%d)",
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)
if (dim < 1 || dim > order_size)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "has out-of-range dimension (%d)",
+ gfc_error ("%qs argument of %qs intrinsic at %L "
+ "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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid permutation of dimensions (dimension "
- "'%d' duplicated)",
+ "%qd duplicated)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
- return FAILURE;
+ return false;
}
perm[dim-1] = 1;
&& 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;
-
+
mpz_init_set_ui (size, 1);
for (c = gfc_constructor_first (shape->value.constructor);
c; c = gfc_constructor_next (c))
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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "must be of a derived type",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
- return FAILURE;
+ gfc_error ("%qs argument of %qs intrinsic at %L "
+ "cannot be of type %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic,
+ &a->where, gfc_typename (&a->ts));
+ return false;
}
- if (!gfc_type_is_extensible (a->ts.u.derived))
+ if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "must be of a derived type",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &b->where);
- return FAILURE;
+ gfc_error ("%qs argument of %qs intrinsic at %L "
+ "cannot be of type %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic,
+ &b->where, gfc_typename (&b->ts));
+ return false;
}
- if (!gfc_type_is_extensible (b->ts.u.derived))
+ if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"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, "Fortran 2003: '%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, "%qs 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, "Fortran 2008: 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, "Fortran 2008: '%s' intrinsic with "
- "RADIX argument at %L", gfc_current_intrinsic,
- &radix->where) == FAILURE)
- return FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2008, "%qs 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);
if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
{
- gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
+ 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, "Fortran 2003: '%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, "%qs 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, "Fortran 2003: '%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, "%qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &arg->where);
+ return false;
+ }
+
+ /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
+ if (arg->ts.type == BT_ASSUMED
+ && (arg->symtree->n.sym->as == NULL
+ || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
+ && arg->symtree->n.sym->as->type != AS_DEFERRED
+ && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
+ {
+ gfc_error ("%qs argument of %qs 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
+ && arg->symtree->n.sym->as != NULL
+ && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
+ && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
+ "assumed-size array", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &arg->where);
+ return false;
}
- return SUCCESS;
+
+ return true;
}
-gfc_try
+/* 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 c_loc is true, character with len > 1 are allowed (cf. Fortran
+ 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
+ arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
+ are permitted. */
+
+static bool
+is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
+{
+ *msg = NULL;
+
+ if (expr->ts.type == BT_CLASS)
+ {
+ *msg = "Expression is polymorphic";
+ return false;
+ }
+
+ if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
+ && !expr->ts.u.derived->ts.is_iso_c)
+ {
+ *msg = "Expression is a noninteroperable derived type";
+ return false;
+ }
+
+ if (expr->ts.type == BT_PROCEDURE)
+ {
+ *msg = "Procedure unexpected as argument";
+ return false;
+ }
+
+ if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
+ {
+ int i;
+ for (i = 0; gfc_logical_kinds[i].kind; i++)
+ if (gfc_logical_kinds[i].kind == expr->ts.kind)
+ return true;
+ *msg = "Extension to use a non-C_Bool-kind LOGICAL";
+ return false;
+ }
+
+ if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
+ && expr->ts.kind != 1)
+ {
+ *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
+ return false;
+ }
+
+ if (expr->ts.type == BT_CHARACTER) {
+ if (expr->ts.deferred)
+ {
+ /* TS 29113 allows deferred-length strings as dummy arguments,
+ but it is not an interoperable type. */
+ *msg = "Expression shall not be a deferred-length string";
+ return false;
+ }
+
+ if (expr->ts.u.cl && expr->ts.u.cl->length
+ && !gfc_simplify_expr (expr->ts.u.cl->length, 0))
+ gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
+
+ 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))
+ {
+ *msg = "Type shall have a character length of 1";
+ return false;
+ }
+ }
+
+ /* Note: The following checks are about interoperatable variables, Fortran
+ 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
+ is allowed, e.g. assumed-shape arrays with TS 29113. */
+
+ if (gfc_is_coarray (expr))
+ {
+ *msg = "Coarrays are not interoperable";
+ return false;
+ }
+
+ 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)
+ {
+ *msg = "Only whole-arrays are interoperable";
+ return false;
+ }
+ if (!c_f_ptr && ar->as->type != AS_EXPLICIT
+ && ar->as->type != AS_ASSUMED_SIZE)
+ {
+ *msg = "Only explicit-size and assumed-size arrays are interoperable";
+ return false;
+ }
+ }
+
+ return true;
+}
+
+
+bool
gfc_check_c_sizeof (gfc_expr *arg)
{
- if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
+ const char *msg;
+
+ if (!is_c_interoperable (arg, &msg, false, false))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
- "interoperable data entity",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be an "
+ "interoperable data entity: %s",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &arg->where, msg);
+ return false;
+ }
+
+ if (arg->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("%qs argument of %qs 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
+ && arg->symtree->n.sym->as != NULL
+ && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
+ && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
+ "assumed-size array", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &arg->where);
+ 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
+ || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
+ && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
+ {
+ 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 false;
+ }
+
+ if (!scalar_check (c_ptr_1, 0))
+ return false;
+
+ if (c_ptr_2
+ && (c_ptr_2->ts.type != BT_DERIVED
+ || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || (c_ptr_1->ts.u.derived->intmod_sym_id
+ != c_ptr_2->ts.u.derived->intmod_sym_id)))
+ {
+ gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
+ "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 false;
+ }
+
+ if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
+ return false;
+
+ return true;
+}
+
+
+bool
+gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
+{
+ symbol_attribute attr;
+ const char *msg;
+
+ if (cptr->ts.type != BT_DERIVED
+ || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
+ {
+ gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
+ "type TYPE(C_PTR)", &cptr->where);
+ return false;
+ }
+
+ if (!scalar_check (cptr, 0))
+ return false;
+
+ attr = gfc_expr_attr (fptr);
+
+ if (!attr.pointer)
+ {
+ gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
+ &fptr->where);
+ 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 false;
+ }
+
+ if (gfc_is_coindexed (fptr))
+ {
+ gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
+ "coindexed", &fptr->where);
+ return false;
+ }
+
+ if (fptr->rank == 0 && shape)
+ {
+ gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
+ "FPTR", &fptr->where);
+ return false;
+ }
+ else if (fptr->rank && !shape)
+ {
+ gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
+ "FPTR at %L", &fptr->where);
+ return false;
+ }
+
+ if (shape && !rank_check (shape, 2, 1))
+ return false;
+
+ if (shape && !type_check (shape, 2, BT_INTEGER))
+ return false;
+
+ if (shape)
+ {
+ mpz_t size;
+ if (gfc_array_size (shape, &size))
+ {
+ if (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 false;
+ }
+ mpz_clear (size);
+ }
+ }
+
+ if (fptr->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
+ return false;
+ }
+
+ if (!is_c_interoperable (fptr, &msg, false, true))
+ return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR "
+ "at %L to C_F_POINTER: %s", &fptr->where, msg);
+
+ return true;
+}
+
+
+bool
+gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
+{
+ symbol_attribute attr;
+
+ if (cptr->ts.type != BT_DERIVED
+ || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
+ {
+ gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
+ "type TYPE(C_FUNPTR)", &cptr->where);
+ return false;
+ }
+
+ if (!scalar_check (cptr, 0))
+ return false;
+
+ attr = gfc_expr_attr (fptr);
+
+ if (!attr.proc_pointer)
+ {
+ gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
+ "pointer", &fptr->where);
+ return false;
+ }
+
+ if (gfc_is_coindexed (fptr))
+ {
+ gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
+ "coindexed", &fptr->where);
+ 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 true;
+}
+
+
+bool
+gfc_check_c_funloc (gfc_expr *x)
+{
+ symbol_attribute attr;
+
+ if (gfc_is_coindexed (x))
+ {
+ gfc_error ("Argument X at %L to C_FUNLOC shall not be "
+ "coindexed", &x->where);
+ return false;
+ }
+
+ attr = gfc_expr_attr (x);
+
+ if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
+ && x->symtree->n.sym == x->symtree->n.sym->result)
+ {
+ gfc_namespace *ns = gfc_current_ns;
+
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (x->symtree->n.sym == ns->proc_name)
+ {
+ gfc_error ("Function result %qs at %L is invalid as X argument "
+ "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
+ return false;
+ }
+ }
+
+ if (attr.flavor != FL_PROCEDURE)
+ {
+ gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
+ "or a procedure pointer", &x->where);
+ 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 true;
+}
+
+
+bool
+gfc_check_c_loc (gfc_expr *x)
+{
+ symbol_attribute attr;
+ const char *msg;
+
+ if (gfc_is_coindexed (x))
+ {
+ gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
+ return false;
+ }
+
+ if (x->ts.type == BT_CLASS)
+ {
+ gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
+ &x->where);
+ return false;
+ }
+
+ attr = gfc_expr_attr (x);
+
+ if (!attr.pointer
+ && (x->expr_type != EXPR_VARIABLE || !attr.target
+ || attr.flavor == FL_PARAMETER))
+ {
+ gfc_error ("Argument X at %L to C_LOC shall have either "
+ "the POINTER or the TARGET attribute", &x->where);
+ return false;
+ }
+
+ if (x->ts.type == BT_CHARACTER
+ && gfc_var_strlen (x) == 0)
+ {
+ gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
+ "string", &x->where);
+ return false;
+ }
+
+ if (!is_c_interoperable (x, &msg, true, false))
+ {
+ if (x->ts.type == BT_CLASS)
+ {
+ gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
+ &x->where);
+ 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))
+ return false;
+ }
+ else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
+ {
+ gfc_array_ref *ar = gfc_find_array_ref (x);
+
+ 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;
+}
+
+
+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, "GNU extension: 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be less "
"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
+ if (dim
&& dim->expr_type == EXPR_CONSTANT
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("%qs argument of %qs 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;
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return FAILURE;
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ 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);
"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;
+}
+
+
+bool
+gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
+{
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return false;
+ }
+
+ if (distance)
+ {
+ if (!type_check (distance, 0, BT_INTEGER))
+ return false;
+
+ if (!nonnegative_check ("DISTANCE", distance))
+ return false;
+
+ if (!scalar_check (distance, 0))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "DISTANCE= argument to "
+ "NUM_IMAGES at %L", &distance->where))
+ return false;
+ }
+
+ if (failed)
+ {
+ if (!type_check (failed, 1, BT_LOGICAL))
+ return false;
+
+ if (!scalar_check (failed, 1))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "FAILED= argument to "
+ "NUM_IMAGES at %L", &distance->where))
+ return false;
+ }
+
+ return true;
}
-gfc_try
-gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
+bool
+gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
{
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return false;
+ }
+
+ if (coarray == NULL && dim == NULL && distance == NULL)
+ return true;
+
+ if (dim != NULL && coarray == NULL)
+ {
+ gfc_error ("DIM argument without COARRAY argument not allowed for "
+ "THIS_IMAGE intrinsic at %L", &dim->where);
+ return false;
+ }
+
+ if (distance && (coarray || dim))
{
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return FAILURE;
+ gfc_error ("The DISTANCE argument may not be specified together with the "
+ "COARRAY or DIM argument in intrinsic at %L",
+ &distance->where);
+ return false;
}
- if (dim != NULL && coarray == NULL)
+ /* Assume that we have "this_image (distance)". */
+ if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
{
- gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
- "intrinsic at %L", &dim->where);
- return FAILURE;
+ if (dim)
+ {
+ gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
+ &coarray->where);
+ return false;
+ }
+ distance = coarray;
}
- if (coarray == NULL)
- return SUCCESS;
+ if (distance)
+ {
+ if (!type_check (distance, 2, BT_INTEGER))
+ return false;
- if (coarray_check (coarray, 0) == FAILURE)
- return FAILURE;
+ if (!nonnegative_check ("DISTANCE", distance))
+ return false;
+
+ if (!scalar_check (distance, 2))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "DISTANCE= argument to "
+ "THIS_IMAGE at %L", &distance->where))
+ return false;
+
+ return true;
+ }
+
+ 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)
-
{
size_t result_elt_size;
- mpz_t tmp;
- gfc_expr *mold_element;
if (source->expr_type == EXPR_FUNCTION)
- return FAILURE;
+ return false;
- /* Calculate the size of the source. */
- if (source->expr_type == EXPR_ARRAY
- && gfc_array_size (source, &tmp) == FAILURE)
- return FAILURE;
+ if (size && size->expr_type != EXPR_CONSTANT)
+ return false;
+ /* Calculate the size of the source. */
*source_size = gfc_target_expr_size (source);
-
- mold_element = mold->expr_type == EXPR_ARRAY
- ? gfc_constructor_first (mold->value.constructor)->expr
- : mold;
+ if (*source_size == 0)
+ return false;
/* Determine the size of the element. */
- result_elt_size = gfc_target_expr_size (mold_element);
+ result_elt_size = gfc_element_size (mold);
if (result_elt_size == 0)
- return FAILURE;
+ return false;
if (mold->expr_type == EXPR_ARRAY || mold->rank || 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;
if (mold->ts.type == BT_HOLLERITH)
{
- gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
- &mold->where, gfc_basic_typename (BT_HOLLERITH));
- return FAILURE;
+ gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
+ " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
+ 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;
+ if (!warn_surprising)
+ 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);
+ gfc_warning (OPT_Wsurprising,
+ "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, "Fortran 2003: '%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, "%qs 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)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return FAILURE;
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ 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;
if (mpz_get_si (vector_size) < mask_true_count)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
- "are .TRUE. values in '%s' (%ld/%d)",
+ "are .TRUE. values in %qs (%ld/%d)",
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);
if (mask->rank != field->rank && field->rank != 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
- "the same rank as '%s' or be a scalar",
+ gfc_error ("%qs argument of %qs intrinsic at %L must have "
+ "the same rank as %qs 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)
for (i = 0; i < field->rank; i++)
if (! identical_dimen_shape (mask, i, field, i))
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
- "must have identical shape.",
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
+ "must have identical shape.",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&field->where);
}
}
- 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, "Fortran 2003: '%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, "%qs 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;
+ unsigned int nargs = 0, seed_size;
locus *where = NULL;
mpz_t put_size, get_size;
- bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
- have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
-
- /* Keep the number of bytes in sync with kiss_size in
- libgfortran/intrinsics/random.c. */
- kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
+ /* Keep the number of bytes in sync with master_state in
+ libgfortran/intrinsics/random.c. +1 due to the integer p which is
+ part of the state too. */
+ seed_size = 128 / gfc_default_integer_kind + 1;
if (size != NULL)
{
|| !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)
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
- && mpz_get_ui (put_size) < kiss_size)
- gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ if (gfc_array_size (put, &put_size)
+ && mpz_get_ui (put_size) < seed_size)
+ gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- where, (int) mpz_get_ui (put_size), kiss_size);
+ where, (int) mpz_get_ui (put_size), seed_size);
}
if (get != NULL)
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
- && mpz_get_ui (get_size) < kiss_size)
- gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ if (gfc_array_size (get, &get_size)
+ && mpz_get_ui (get_size) < seed_size)
+ gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
- where, (int) mpz_get_ui (get_size), kiss_size);
+ where, (int) mpz_get_ui (get_size), seed_size);
}
/* RANDOM_SEED may not have more than one non-optional argument. */
if (nargs > 1)
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
- return SUCCESS;
+ return true;
}
+bool
+gfc_check_fe_runtime_error (gfc_actual_arglist *a)
+{
+ gfc_expr *e;
+ int len, i;
+ int num_percent, nargs;
+
+ e = a->expr;
+ if (e->expr_type != EXPR_CONSTANT)
+ return true;
+
+ len = e->value.character.length;
+ if (e->value.character.string[len-1] != '\0')
+ gfc_internal_error ("fe_runtime_error string must be null terminated");
-gfc_try
+ num_percent = 0;
+ for (i=0; i<len-1; i++)
+ if (e->value.character.string[i] == '%')
+ num_percent ++;
+
+ nargs = 0;
+ for (; a; a = a->next)
+ nargs ++;
+
+ if (nargs -1 != num_percent)
+ gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
+ nargs, num_percent++);
+
+ return true;
+}
+
+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 */
+/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
+ variables in Fortran 95. In Fortran 2003 and later, they can be of any
+ kind, and COUNT_RATE can be of type real. 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))
+ return false;
- if (type_check (count, 0, BT_INTEGER) == FAILURE)
- return FAILURE;
+ if (count->ts.kind != gfc_default_integer_kind
+ && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
+ "SYSTEM_CLOCK at %L has non-default kind",
+ &count->where))
+ 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 (!variable_check (count_rate, 1, false))
+ return false;
- if (variable_check (count_rate, 1, false) == FAILURE)
- return FAILURE;
-
- if (count != NULL
- && same_type_check (count, 0, count_rate, 1) == FAILURE)
- return FAILURE;
+ if (count_rate->ts.type == BT_REAL)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
+ "SYSTEM_CLOCK at %L", &count_rate->where))
+ return false;
+ }
+ else
+ {
+ if (!type_check (count_rate, 1, BT_INTEGER))
+ return false;
+
+ if (count_rate->ts.kind != gfc_default_integer_kind
+ && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
+ "SYSTEM_CLOCK at %L has non-default kind",
+ &count_rate->where))
+ return false;
+ }
}
if (count_max != NULL)
{
- if (scalar_check (count_max, 2) == FAILURE)
- return FAILURE;
-
- if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
- return FAILURE;
+ if (!scalar_check (count_max, 2))
+ return false;
- if (variable_check (count_max, 2, false) == FAILURE)
- return FAILURE;
+ if (!type_check (count_max, 2, BT_INTEGER))
+ return false;
- if (count != NULL
- && same_type_check (count, 0, count_max, 2) == FAILURE)
- return FAILURE;
+ if (count_max->ts.kind != gfc_default_integer_kind
+ && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
+ "SYSTEM_CLOCK at %L has non-default kind",
+ &count_max->where))
+ return false;
- if (count_rate != NULL
- && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
- return FAILURE;
+ if (!variable_check (count_max, 2, false))
+ 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
"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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs 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)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs 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)
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"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
-gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
+bool
+gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
{
+
+ if (a->expr_type == EXPR_NULL)
+ {
+ gfc_error ("Intrinsic function NULL at %L cannot be an actual "
+ "argument to STORAGE_SIZE, because it returns a "
+ "disassociated pointer", &a->where);
+ return false;
+ }
+
+ if (a->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &a->where);
+ return false;
+ }
+
+ if (a->ts.type == BT_PROCEDURE)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
+ "procedure", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &a->where);
+ 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_error ("%qs argument of %qs 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;
}
projects / thirdparty / gcc.git / blobdiff