#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "intrinsic.h"
static try
type_check (gfc_expr * e, int n, bt type)
{
if (e->ts.type == type)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
gfc_basic_typename (type));
return FAILURE;
}
static try
numeric_check (gfc_expr * e, int n)
{
if (gfc_numeric_ts (&e->ts))
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
static try
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 or REAL",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
return SUCCESS;
}
static try
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 or COMPLEX",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
return SUCCESS;
}
static try
kind_check (gfc_expr * k, int n, bt type)
{
int kind;
if (k == NULL)
return SUCCESS;
if (type_check (k, n, BT_INTEGER) == FAILURE)
return FAILURE;
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
return FAILURE;
}
if (gfc_extract_int (k, &kind) != NULL
|| gfc_validate_kind (type, kind, true) < 0)
{
gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
&k->where);
return FAILURE;
}
return SUCCESS;
}
static try
double_check (gfc_expr * d, int n)
{
if (type_check (d, n, BT_REAL) == FAILURE)
return FAILURE;
if (d->ts.kind != gfc_default_double_kind)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be double precision",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
return FAILURE;
}
return SUCCESS;
}
static try
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 array",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
return FAILURE;
}
return SUCCESS;
}
static try
array_check (gfc_expr * e, int n)
{
if (e->rank != 0)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
static try
scalar_check (gfc_expr * e, int n)
{
if (e->rank == 0)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
static try
same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
{
if (gfc_compare_types (&e->ts, &f->ts))
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
"and kind as '%s'", gfc_current_intrinsic_arg[m],
gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
return FAILURE;
}
static try
rank_check (gfc_expr * e, int n, int rank)
{
if (e->rank == rank)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where, rank);
return FAILURE;
}
static try
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_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where);
}
return SUCCESS;
}
static try
kind_value_check (gfc_expr * e, int n, int k)
{
if (e->ts.kind == k)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where, k);
return FAILURE;
}
static try
variable_check (gfc_expr * e, int n)
{
if ((e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER)
|| (e->expr_type == EXPR_FUNCTION
&& e->symtree->n.sym->result == e->symtree->n.sym))
return SUCCESS;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where);
return FAILURE;
}
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
static try
dim_check (gfc_expr * dim, int n, int optional)
{
if (optional && dim == NULL)
return SUCCESS;
if (dim == NULL)
{
gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
gfc_current_intrinsic, gfc_current_intrinsic_where);
return FAILURE;
}
if (type_check (dim, n, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (dim, n) == FAILURE)
return FAILURE;
if (nonoptional_check (dim, n) == FAILURE)
return FAILURE;
return SUCCESS;
}
static try
dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
{
gfc_array_ref *ar;
int rank;
if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
return SUCCESS;
ar = gfc_find_array_ref (array);
rank = array->rank;
if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
rank--;
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 "
"dimension index", gfc_current_intrinsic, &dim->where);
return FAILURE;
}
return SUCCESS;
}
static int
identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
{
mpz_t a_size, b_size;
int ret;
gcc_assert (a->rank > ai);
gcc_assert (b->rank > bi);
ret = 1;
if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
{
if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
{
if (mpz_cmp (a_size, b_size) != 0)
ret = 0;
mpz_clear (b_size);
}
mpz_clear (a_size);
}
return ret;
}
static try
non_init_transformational (void)
{
gfc_error ("transformational intrinsic '%s' at %L is not permitted "
"in an initialization expression", gfc_current_intrinsic,
gfc_current_intrinsic_where);
return FAILURE;
}
static try
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;
return SUCCESS;
}
try
gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
{
return check_a_kind (a, kind, BT_INTEGER);
}
try
gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
{
return check_a_kind (a, kind, BT_REAL);
}
try
gfc_check_abs (gfc_expr * a)
{
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_achar (gfc_expr * a)
{
if (type_check (a, 0, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (type_check (mode, 1, BT_CHARACTER) == FAILURE
|| scalar_check (mode, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_allocated (gfc_expr * array)
{
symbol_attribute attr;
if (variable_check (array, 0) == FAILURE)
return FAILURE;
if (array_check (array, 0) == FAILURE)
return FAILURE;
attr = gfc_variable_attr (array, NULL);
if (!attr.allocatable)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
&array->where);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_a_p (gfc_expr * a, gfc_expr * p)
{
if (int_or_real_check (a, 0) == FAILURE)
return FAILURE;
if (a->ts.type != p->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
&p->where);
return FAILURE;
}
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;
}
return SUCCESS;
}
try
gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
{
symbol_attribute attr;
int i;
try t;
locus *where;
where = &pointer->where;
if (pointer->expr_type == EXPR_VARIABLE)
attr = gfc_variable_attr (pointer, NULL);
else if (pointer->expr_type == EXPR_FUNCTION)
attr = pointer->symtree->n.sym->attr;
else if (pointer->expr_type == EXPR_NULL)
goto null_arg;
else
gcc_assert (0);
if (!attr.pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
&pointer->where);
return FAILURE;
}
if (target == NULL)
return SUCCESS;
where = &target->where;
if (target->expr_type == EXPR_NULL)
goto null_arg;
if (target->expr_type == EXPR_VARIABLE)
attr = gfc_variable_attr (target, NULL);
else if (target->expr_type == EXPR_FUNCTION)
attr = target->symtree->n.sym->attr;
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
"or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &target->where);
return FAILURE;
}
if (!attr.pointer && !attr.target)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
"or a TARGET", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &target->where);
return FAILURE;
}
t = SUCCESS;
if (same_type_check (pointer, 0, target, 1) == FAILURE)
t = FAILURE;
if (rank_check (target, 0, pointer->rank) == FAILURE)
t = FAILURE;
if (target->rank > 0)
{
for (i = 0; i < target->rank; i++)
if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
{
gfc_error ("Array section with a vector subscript at %L shall not "
"be the target of a pointer",
&target->where);
t = FAILURE;
break;
}
}
return t;
null_arg:
gfc_error ("NULL pointer at %L is not permitted as actual argument "
"of '%s' intrinsic function", where, gfc_current_intrinsic);
return FAILURE;
}
try
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;
return SUCCESS;
}
try
gfc_check_besn (gfc_expr * n, gfc_expr * x)
{
if (scalar_check (n, 0) == FAILURE)
return FAILURE;
if (type_check (n, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (x, 1) == FAILURE)
return FAILURE;
if (type_check (x, 1, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_btest (gfc_expr * i, gfc_expr * pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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;
return SUCCESS;
}
try
gfc_check_chdir (gfc_expr * dir)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_chmod (gfc_expr * name, gfc_expr * mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_chmod_sub (gfc_expr * name, gfc_expr * mode, gfc_expr * status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
if (y != NULL)
{
if (numeric_check (y, 1) == FAILURE)
return FAILURE;
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
"present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &y->where);
return FAILURE;
}
}
if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_complex (gfc_expr * x, gfc_expr * y)
{
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
return FAILURE;
}
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
return FAILURE;
}
if (scalar_check (y, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_count (gfc_expr * mask, gfc_expr * dim)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (array->rank == 1)
{
if (scalar_check (shift, 1) == FAILURE)
return FAILURE;
}
else
{
}
if (dim_check (dim, 2, 1) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_ctime (gfc_expr * time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
if (type_check (time, 0, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
if (y != NULL)
{
if (numeric_check (y, 1) == FAILURE)
return FAILURE;
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
"present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &y->where);
return FAILURE;
}
}
return SUCCESS;
}
try
gfc_check_dble (gfc_expr * x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_digits (gfc_expr * x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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;
break;
case BT_INTEGER:
case BT_REAL:
case BT_COMPLEX:
if (numeric_check (vector_b, 1) == FAILURE)
return FAILURE;
break;
default:
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &vector_a->where);
return FAILURE;
}
if (rank_check (vector_a, 0, 1) == FAILURE)
return FAILURE;
if (rank_check (vector_b, 1, 1) == FAILURE)
return FAILURE;
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],
gfc_current_intrinsic_arg[1],
&vector_a->where);
return FAILURE;
}
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
gfc_expr * dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (array->rank == 1)
{
if (scalar_check (shift, 2) == FAILURE)
return FAILURE;
}
else
{
}
if (boundary != NULL)
{
if (same_type_check (array, 0, boundary, 2) == FAILURE)
return FAILURE;
}
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_fn_c (gfc_expr * a)
{
if (type_check (a, 0, BT_COMPLEX) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_fn_r (gfc_expr * a)
{
if (type_check (a, 0, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_fn_rc (gfc_expr * a)
{
if (real_or_complex_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_fnum (gfc_expr * unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_g77_math1 (gfc_expr * x)
{
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_huge (gfc_expr * x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_i (gfc_expr * i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_iand (gfc_expr * i, gfc_expr * j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
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;
}
return SUCCESS;
}
try
gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (len, 2, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ichar_iachar (gfc_expr * c)
{
int i;
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
{
gfc_expr *start;
gfc_expr *end;
gfc_ref *ref;
ref = c->ref;
while (ref && ref->type != REF_SUBSTRING)
ref = ref->next;
gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
if (!ref)
{
if (c->ts.cl && c->ts.cl->length)
{
if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
return SUCCESS;
i = mpz_get_si (c->ts.cl->length->value.integer);
}
else
return SUCCESS;
}
else
{
start = ref->u.ss.start;
end = ref->u.ss.end;
gcc_assert (start);
if (end == NULL || end->expr_type != EXPR_CONSTANT
|| start->expr_type != EXPR_CONSTANT)
return SUCCESS;
i = mpz_get_si (end->value.integer) + 1
- mpz_get_si (start->value.integer);
}
}
else
return SUCCESS;
if (i != 1)
{
gfc_error ("Argument of %s at %L must be of length one",
gfc_current_intrinsic, &c->where);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_idnint (gfc_expr * a)
{
if (double_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ieor (gfc_expr * i, gfc_expr * j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
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;
}
return SUCCESS;
}
try
gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
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],
gfc_current_intrinsic, &substring->where,
gfc_current_intrinsic_arg[0]);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_int (gfc_expr * x, gfc_expr * kind)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
if (kind != NULL)
{
if (type_check (kind, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (kind, 1) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_intconv (gfc_expr * x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ior (gfc_expr * i, gfc_expr * j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
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;
}
return SUCCESS;
}
try
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;
return SUCCESS;
}
try
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 (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
{
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
{
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (pid, 0) == FAILURE)
return FAILURE;
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (sig, 1) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_kind (gfc_expr * x)
{
if (x->ts.type == BT_DERIVED)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
"non-derived type", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &x->where);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 1) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_link (gfc_expr * path1, gfc_expr * path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_loc (gfc_expr *expr)
{
return variable_check (expr, 0);
}
try
gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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;
return SUCCESS;
}
static try
min_max_args (gfc_actual_arglist * arg)
{
if (arg == NULL || arg->next == NULL)
{
gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
gfc_current_intrinsic, gfc_current_intrinsic_where);
return FAILURE;
}
return SUCCESS;
}
static try
check_rest (bt type, int kind, gfc_actual_arglist * arg)
{
gfc_expr *x;
int n;
if (min_max_args (arg) == FAILURE)
return FAILURE;
n = 1;
for (; arg; arg = arg->next, n++)
{
x = arg->expr;
if (x->ts.type != type || x->ts.kind != kind)
{
if (x->ts.type == type)
{
if (gfc_notify_std (GFC_STD_GNU,
"Extension: Different type kinds at %L", &x->where)
== FAILURE)
return FAILURE;
}
else
{
gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
n, gfc_current_intrinsic, &x->where,
gfc_basic_typename (type), kind);
return FAILURE;
}
}
}
return SUCCESS;
}
try
gfc_check_min_max (gfc_actual_arglist * arg)
{
gfc_expr *x;
if (min_max_args (arg) == FAILURE)
return FAILURE;
x = arg->expr;
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
gfc_error
("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
gfc_current_intrinsic, &x->where);
return FAILURE;
}
return check_rest (x->ts.type, x->ts.kind, arg);
}
try
gfc_check_min_max_integer (gfc_actual_arglist * arg)
{
return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
}
try
gfc_check_min_max_real (gfc_actual_arglist * arg)
{
return check_rest (BT_REAL, gfc_default_real_kind, arg);
}
try
gfc_check_min_max_double (gfc_actual_arglist * arg)
{
return check_rest (BT_REAL, gfc_default_double_kind, arg);
}
try
gfc_check_malloc (gfc_expr * size)
{
if (type_check (size, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (size, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
{
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &matrix_a->where);
return FAILURE;
}
if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &matrix_b->where);
return FAILURE;
}
switch (matrix_a->rank)
{
case 1:
if (rank_check (matrix_b, 1, 2) == FAILURE)
return FAILURE;
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_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1],
&matrix_a->where);
return FAILURE;
}
break;
case 2:
if (matrix_b->rank != 2)
{
if (rank_check (matrix_b, 1, 1) == FAILURE)
return FAILURE;
}
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 "
"matmul", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], &matrix_a->where);
return FAILURE;
}
break;
default:
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
"1 or 2", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &matrix_a->where);
return FAILURE;
}
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
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;
d = ap->next->expr;
m = ap->next->next->expr;
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
&& ap->next->name == NULL)
{
m = d;
d = NULL;
ap->next->expr = NULL;
ap->next->next->expr = m;
}
if (dim_check (d, 1, 1) == FAILURE)
return FAILURE;
if (d && dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
if (m != NULL)
{
char buffer[80];
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, a, m) == FAILURE)
return FAILURE;
}
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
static try
check_reduction (gfc_actual_arglist * ap)
{
gfc_expr *a, *m, *d;
a = ap->expr;
d = ap->next->expr;
m = ap->next->next->expr;
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
&& ap->next->name == NULL)
{
m = d;
d = NULL;
ap->next->expr = NULL;
ap->next->next->expr = m;
}
if (dim_check (d, 1, 1) == FAILURE)
return FAILURE;
if (d && dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
if (m != NULL)
{
char buffer[80];
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, a, m) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
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 (gfc_init_expr)
return non_init_transformational ();
return check_reduction (ap);
}
try
gfc_check_product_sum (gfc_actual_arglist * ap)
{
if (numeric_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return check_reduction (ap);
}
try
gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
{
char buffer[80];
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
return FAILURE;
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
return FAILURE;
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
{
symbol_attribute attr;
if (variable_check (from, 0) == FAILURE)
return FAILURE;
if (array_check (from, 0) == FAILURE)
return FAILURE;
attr = gfc_variable_attr (from, NULL);
if (!attr.allocatable)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
&from->where);
return FAILURE;
}
if (variable_check (to, 0) == FAILURE)
return FAILURE;
if (array_check (to, 0) == FAILURE)
return FAILURE;
attr = gfc_variable_attr (to, NULL);
if (!attr.allocatable)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
&to->where);
return FAILURE;
}
if (same_type_check (from, 0, to, 1) == FAILURE)
return FAILURE;
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],
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
&to->where, from->rank, to->rank);
return FAILURE;
}
if (to->ts.kind != from->ts.kind)
{
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],
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
&to->where, from->ts.kind, to->ts.kind);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
if (type_check (s, 1, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_new_line (gfc_expr * a)
{
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_null (gfc_expr * mold)
{
symbol_attribute attr;
if (mold == NULL)
return SUCCESS;
if (variable_check (mold, 0) == FAILURE)
return FAILURE;
attr = gfc_variable_attr (mold, NULL);
if (!attr.pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &mold->where);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
{
char buffer[80];
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
return FAILURE;
snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, array, mask) == FAILURE)
return FAILURE;
if (vector != NULL)
{
if (same_type_check (array, 0, vector, 2) == FAILURE)
return FAILURE;
if (rank_check (vector, 2, 1) == FAILURE)
return FAILURE;
}
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_precision (gfc_expr * x)
{
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
"REAL or COMPLEX", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &x->where);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_present (gfc_expr * a)
{
gfc_symbol *sym;
if (variable_check (a, 0) == FAILURE)
return FAILURE;
sym = a->symtree->n.sym;
if (!sym->attr.dummy)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
"dummy variable", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &a->where);
return FAILURE;
}
if (!sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
"an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &a->where);
return FAILURE;
}
if (a->ref != NULL
&& !(a->ref->next == NULL
&& a->ref->type == REF_ARRAY
&& a->ref->u.ar.type == AR_FULL))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-"
"object of '%s'", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &a->where, sym->name);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_radix (gfc_expr * x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_range (gfc_expr * x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_real (gfc_expr * a, gfc_expr * kind)
{
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
if (kind_check (kind, 1, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_repeat (gfc_expr * x, gfc_expr * y)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
if (type_check (y, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (y, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
gfc_expr * pad, gfc_expr * order)
{
mpz_t size;
mpz_t nelems;
int m;
if (array_check (source, 0) == FAILURE)
return FAILURE;
if (rank_check (shape, 1, 1) == FAILURE)
return FAILURE;
if (type_check (shape, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (gfc_array_size (shape, &size) != SUCCESS)
{
gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
"array of constant size", &shape->where);
return FAILURE;
}
m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
mpz_clear (size);
if (m > 0)
{
gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
return FAILURE;
}
if (pad != NULL)
{
if (same_type_check (source, 0, pad, 2) == FAILURE)
return FAILURE;
if (array_check (pad, 2) == FAILURE)
return FAILURE;
}
if (order != NULL && array_check (order, 3) == FAILURE)
return FAILURE;
if (pad == NULL
&& shape->expr_type == EXPR_ARRAY
&& gfc_is_constant_expr (shape)
&& !(source->expr_type == EXPR_VARIABLE
&& source->symtree->n.sym->as
&& source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
{
if (gfc_array_size (source, &nelems) == SUCCESS)
{
gfc_constructor *c;
bool test;
c = shape->value.constructor;
mpz_init_set_ui (size, 1);
for (; c; c = c->next)
mpz_mul (size, size, c->expr->value.integer);
test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
mpz_clear (nelems);
mpz_clear (size);
if (test)
{
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 SUCCESS;
}
try
gfc_check_scale (gfc_expr * x, gfc_expr * i)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
if (type_check (i, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (y, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
if (same_type_check (x, 0, y, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_secnds (gfc_expr * r)
{
if (type_check (r, 0, BT_REAL) == FAILURE)
return FAILURE;
if (kind_value_check (r, 0, 4) == FAILURE)
return FAILURE;
if (scalar_check (r, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_selected_int_kind (gfc_expr * r)
{
if (type_check (r, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (r, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
{
if (p == NULL && r == NULL)
{
gfc_error ("Missing arguments to %s intrinsic at %L",
gfc_current_intrinsic, gfc_current_intrinsic_where);
return FAILURE;
}
if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
if (type_check (i, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_shape (gfc_expr * source)
{
gfc_array_ref *ar;
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
return SUCCESS;
ar = gfc_find_array_ref (source);
if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
{
gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
"an assumed size array", &source->where);
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_sign (gfc_expr * a, gfc_expr * b)
{
if (int_or_real_check (a, 0) == FAILURE)
return FAILURE;
if (same_type_check (a, 0, b, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_size (gfc_expr * array, gfc_expr * dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
if (type_check (dim, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 0) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_sleep_sub (gfc_expr * seconds)
{
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (seconds, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 "
"than rank %d", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
return FAILURE;
}
if (dim_check (dim, 1, 0) == FAILURE)
return FAILURE;
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (ncopies, 2) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
if (type_check (c, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
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;
return SUCCESS;
}
try
gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
{
return gfc_check_fgetputc_sub (unit, c, NULL);
}
try
gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
{
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
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;
return SUCCESS;
}
try
gfc_check_fgetput (gfc_expr * c)
{
return gfc_check_fgetput_sub (c, NULL);
}
try
gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
if (type_check (array, 1, BT_INTEGER) == FAILURE
|| kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (array_check (array, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
if (type_check (array, 1, BT_INTEGER) == FAILURE
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (array_check (array, 1) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE
|| kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ftell (gfc_expr * unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
if (type_check (offset, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (offset, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_stat (gfc_expr * name, gfc_expr * array)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (array, 1, BT_INTEGER) == FAILURE
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (array_check (array, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (type_check (array, 1, BT_INTEGER) == FAILURE
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (array_check (array, 1) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
gfc_expr * mold ATTRIBUTE_UNUSED,
gfc_expr * size)
{
if (size != NULL)
{
if (type_check (size, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (size, 2) == FAILURE)
return FAILURE;
if (nonoptional_check (size, 2) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_transpose (gfc_expr * matrix)
{
if (rank_check (matrix, 0, 2) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 0) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
{
if (rank_check (vector, 0, 1) == FAILURE)
return FAILURE;
if (array_check (mask, 1) == FAILURE)
return FAILURE;
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
return FAILURE;
if (same_type_check (vector, 0, field, 2) == FAILURE)
return FAILURE;
if (gfc_init_expr)
return non_init_transformational ();
return SUCCESS;
}
try
gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (same_type_check (x, 0, y, 1) == FAILURE)
return FAILURE;
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_trim (gfc_expr * x)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ttynam (gfc_expr * unit)
{
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_x (gfc_expr * x)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_cpu_time (gfc_expr * time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
if (type_check (time, 0, BT_REAL) == FAILURE)
return FAILURE;
if (variable_check (time, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (scalar_check (date, 0) == FAILURE)
return FAILURE;
if (variable_check (date, 0) == FAILURE)
return FAILURE;
}
if (time != NULL)
{
if (type_check (time, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (scalar_check (time, 1) == FAILURE)
return FAILURE;
if (variable_check (time, 1) == FAILURE)
return FAILURE;
}
if (zone != NULL)
{
if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
return FAILURE;
if (scalar_check (zone, 2) == FAILURE)
return FAILURE;
if (variable_check (zone, 2) == FAILURE)
return FAILURE;
}
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) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
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 (frompos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (len, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (same_type_check (from, 0, to, 3) == FAILURE)
return FAILURE;
if (variable_check (to, 3) == FAILURE)
return FAILURE;
if (type_check (topos, 4, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_random_number (gfc_expr * harvest)
{
if (type_check (harvest, 0, BT_REAL) == FAILURE)
return FAILURE;
if (variable_check (harvest, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
{
if (size != NULL)
{
if (scalar_check (size, 0) == FAILURE)
return FAILURE;
if (type_check (size, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (variable_check (size, 0) == FAILURE)
return FAILURE;
if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
return FAILURE;
}
if (put != NULL)
{
if (size != NULL)
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
&put->where);
if (array_check (put, 1) == FAILURE)
return FAILURE;
if (rank_check (put, 1, 1) == FAILURE)
return FAILURE;
if (type_check (put, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
}
if (get != NULL)
{
if (size != NULL || put != NULL)
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
&get->where);
if (array_check (get, 2) == FAILURE)
return FAILURE;
if (rank_check (get, 2, 1) == FAILURE)
return FAILURE;
if (type_check (get, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (variable_check (get, 2) == FAILURE)
return FAILURE;
if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_second_sub (gfc_expr * time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
if (type_check (time, 0, BT_REAL) == FAILURE)
return FAILURE;
if (kind_value_check(time, 0, 4) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (type_check (count, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (variable_check (count, 0) == FAILURE)
return FAILURE;
}
if (count_rate != NULL)
{
if (scalar_check (count_rate, 1) == FAILURE)
return FAILURE;
if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (variable_check (count_rate, 1) == FAILURE)
return FAILURE;
if (count != NULL
&& same_type_check (count, 0, count_rate, 1) == FAILURE)
return FAILURE;
}
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 (variable_check (count_max, 2) == FAILURE)
return FAILURE;
if (count != NULL
&& same_type_check (count, 0, count_max, 2) == FAILURE)
return FAILURE;
if (count_rate != NULL
&& same_type_check (count_rate, 1, count_max, 2) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
try
gfc_check_irand (gfc_expr * x)
{
if (x == NULL)
return SUCCESS;
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
if (type_check (x, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check(x, 0, 4) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
return FAILURE;
}
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
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;
return SUCCESS;
}
try
gfc_check_rand (gfc_expr * x)
{
if (x == NULL)
return SUCCESS;
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
if (type_check (x, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check(x, 0, 4) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_srand (gfc_expr * x)
{
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
if (type_check (x, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check(x, 0, 4) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (type_check (result, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_etime (gfc_expr * x)
{
if (array_check (x, 0) == FAILURE)
return FAILURE;
if (rank_check (x, 0, 1) == FAILURE)
return FAILURE;
if (variable_check (x, 0) == FAILURE)
return FAILURE;
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
if (kind_value_check(x, 0, 4) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
{
if (array_check (values, 0) == FAILURE)
return FAILURE;
if (rank_check (values, 0, 1) == FAILURE)
return FAILURE;
if (variable_check (values, 0) == FAILURE)
return FAILURE;
if (type_check (values, 0, BT_REAL) == FAILURE)
return FAILURE;
if (kind_value_check(values, 0, 4) == FAILURE)
return FAILURE;
if (scalar_check (time, 1) == FAILURE)
return FAILURE;
if (type_check (time, 1, BT_REAL) == FAILURE)
return FAILURE;
if (kind_value_check(time, 1, 4) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_fdate_sub (gfc_expr * date)
{
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_gerror (gfc_expr * msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
{
if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_getlog (gfc_expr * msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_exit (gfc_expr * status)
{
if (status == NULL)
return SUCCESS;
if (type_check (status, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_flush (gfc_expr * unit)
{
if (unit == NULL)
return SUCCESS;
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_free (gfc_expr * i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (i, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_hostnm (gfc_expr * name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_itime_idate (gfc_expr * values)
{
if (array_check (values, 0) == FAILURE)
return FAILURE;
if (rank_check (values, 0, 1) == FAILURE)
return FAILURE;
if (variable_check (values, 0) == FAILURE)
return FAILURE;
if (type_check (values, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ltime_gmtime (gfc_expr * time, gfc_expr * values)
{
if (type_check (time, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
if (array_check (values, 1) == FAILURE)
return FAILURE;
if (rank_check (values, 1, 1) == FAILURE)
return FAILURE;
if (variable_check (values, 1) == FAILURE)
return FAILURE;
if (type_check (values, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
{
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (name, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_isatty (gfc_expr * unit)
{
if (unit == NULL)
return FAILURE;
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_perror (gfc_expr * string)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_umask (gfc_expr * mask)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (mask, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (mask, 0) == FAILURE)
return FAILURE;
if (old == NULL)
return SUCCESS;
if (scalar_check (old, 1) == FAILURE)
return FAILURE;
if (type_check (old, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_unlink (gfc_expr * name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
return FAILURE;
}
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
return FAILURE;
}
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
{
if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
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 or LOGICAL",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
return FAILURE;
}
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
gfc_error (
"'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
return FAILURE;
}
if (i->ts.type != j->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
&j->where);
return FAILURE;
}
if (scalar_check (i, 0) == FAILURE)
return FAILURE;
if (scalar_check (j, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}