/* Check functions
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
has been sorted into the right order and has NULL arguments in the
correct places for missing optional arguments. */
-
-#include <stdlib.h>
-#include <stdarg.h>
-
#include "config.h"
#include "system.h"
#include "flags.h"
static void
must_be (gfc_expr * e, int n, const char *thing)
{
-
gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
thing);
static try
type_check (gfc_expr * e, int n, bt type)
{
-
if (e->ts.type == type)
return SUCCESS;
static try
numeric_check (gfc_expr * e, int n)
{
-
if (gfc_numeric_ts (&e->ts))
return SUCCESS;
static try
int_or_real_check (gfc_expr * e, int n)
{
-
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
{
must_be (e, n, "INTEGER or REAL");
}
+/* Check that an expression is real or complex. */
+
+static try
+real_or_complex_check (gfc_expr * e, int n)
+{
+ if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
+ {
+ must_be (e, n, "REAL or COMPLEX");
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* Check that the expression is an optional constant integer
and that it specifies a valid kind for that type. */
}
if (gfc_extract_int (k, &kind) != NULL
- || gfc_validate_kind (type, kind) == -1)
+ || gfc_validate_kind (type, kind, true) < 0)
{
gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
&k->where);
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 ())
+ if (d->ts.kind != gfc_default_double_kind)
{
must_be (d, n, "double precision");
return FAILURE;
static try
logical_array_check (gfc_expr * array, int n)
{
-
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
must_be (array, n, "a logical array");
static try
array_check (gfc_expr * e, int n)
{
-
if (e->rank != 0)
return SUCCESS;
static try
scalar_check (gfc_expr * e, int n)
{
-
if (e->rank == 0)
return SUCCESS;
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",
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
static try
dim_check (gfc_expr * dim, int n, int optional)
{
-
if (optional)
{
if (dim == NULL)
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)
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_all_any (gfc_expr * mask, gfc_expr * dim)
{
-
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
try
gfc_check_allocated (gfc_expr * array)
{
-
if (variable_check (array, 0) == FAILURE)
return FAILURE;
try
gfc_check_a_p (gfc_expr * a, gfc_expr * p)
{
-
if (int_or_real_check (a, 0) == FAILURE)
return FAILURE;
try
-gfc_check_btest (gfc_expr * i, gfc_expr * pos)
+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;
+}
+
+
+/* BESJN and BESYN functions. */
+
+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)
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)
try
-gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
+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_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
+{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
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)
try
gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
{
-
if (array_check (array, 0) == FAILURE)
return FAILURE;
try
gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
{
-
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_dble (gfc_expr * x)
{
-
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_digits (gfc_expr * x)
{
-
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
{
-
switch (vector_a->ts.type)
{
case BT_LOGICAL:
gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
gfc_expr * dim)
{
-
if (array_check (array, 0) == FAILURE)
return FAILURE;
}
+/* A single complex argument. */
try
-gfc_check_huge (gfc_expr * x)
+gfc_check_fn_c (gfc_expr * a)
+{
+ if (type_check (a, 0, BT_COMPLEX) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/* A single real argument. */
+
+try
+gfc_check_fn_r (gfc_expr * a)
+{
+ if (type_check (a, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/* A single real or complex argument. */
+
+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;
+}
+
+
+/* This is used for the g77 one-argument Bessel functions, and the
+ error function. */
+
+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;
try
gfc_check_i (gfc_expr * i)
{
-
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
gfc_check_iand (gfc_expr * i, gfc_expr * j)
{
-
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (j, 1, BT_INTEGER) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (i, 0, j, 1) == 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 (i, 0, BT_INTEGER) == FAILURE
- || type_check (pos, 1, BT_INTEGER) == FAILURE
- || kind_value_check (pos, 1, gfc_default_integer_kind ()) == 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 (i, 0, BT_INTEGER) == FAILURE
- || type_check (pos, 1, BT_INTEGER) == FAILURE
- || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE
- || type_check (len, 2, BT_INTEGER) == 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 (i, 0, BT_INTEGER) == FAILURE
- || type_check (pos, 1, BT_INTEGER) == FAILURE
- || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE)
+ if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_idnint (gfc_expr * a)
+gfc_check_ichar_iachar (gfc_expr * c)
{
+ int i;
+
+ if (type_check (c, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ /* Check that the argument is length one. Non-constant lengths
+ can't be checked here, so assume thay are ok. */
+ if (c->ts.cl && c->ts.cl->length)
+ {
+ /* If we already have a length for this expression then use it. */
+ if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
+ return SUCCESS;
+ i = mpz_get_si (c->ts.cl->length->value.integer);
+ }
+ else if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
+ {
+ gfc_expr *start;
+ gfc_expr *end;
+ gfc_ref *ref;
+
+ /* Substring references don't have the charlength set. */
+ ref = c->ref;
+ while (ref && ref->type != REF_SUBSTRING)
+ ref = ref->next;
+
+ gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
+
+ if (!ref)
+ return SUCCESS;
+
+ 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;
try
gfc_check_ieor (gfc_expr * i, gfc_expr * j)
{
-
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (j, 1, BT_INTEGER) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (i, 0, j, 1) == 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;
try
gfc_check_int (gfc_expr * x, gfc_expr * kind)
{
+ if (numeric_check (x, 0) == FAILURE)
+ return FAILURE;
- if (numeric_check (x, 0) == FAILURE
- || kind_check (kind, 1, BT_INTEGER) == 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_ior (gfc_expr * i, gfc_expr * j)
{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (j, 1, BT_INTEGER) == FAILURE)
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (i, 0, j, 1) == 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;
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;
try
-gfc_check_kind (gfc_expr * x)
+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 (type_check (sig, 1, BT_INTEGER) == 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)
{
must_be (x, 0, "a non-derived type");
try
gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
{
-
if (array_check (array, 0) == FAILURE)
return FAILURE;
try
-gfc_check_logical (gfc_expr * a, gfc_expr * kind)
+gfc_check_link (gfc_expr * path1, gfc_expr * path2)
{
-
- if (type_check (a, 0, BT_LOGICAL) == FAILURE)
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
+
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/* Min/max family. */
-
+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_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;
+}
+
+
+/* Min/max family. */
+
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",
try
gfc_check_min_max_integer (gfc_actual_arglist * arg)
{
-
- return check_rest (BT_INTEGER, gfc_default_integer_kind (), 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);
+ 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);
+ return check_rest (BT_REAL, gfc_default_double_kind, arg);
}
/* End of min/max family. */
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))
{
must_be (matrix_a, 0, "numeric or LOGICAL");
m = ap->next->next->expr;
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name[0] == '\0')
+ && ap->next->name == NULL)
{
m = d;
d = NULL;
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. */
-try
-gfc_check_reduction (gfc_actual_arglist * ap)
+static try
+check_reduction (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;
+ gfc_expr *m, *d;
d = ap->next->expr;
m = ap->next->next->expr;
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name[0] == '\0')
+ && ap->next->name == NULL)
{
m = d;
d = NULL;
try
-gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
+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;
+
+ 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;
+ return check_reduction (ap);
+}
+
+
+try
+gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
+{
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
return FAILURE;
try
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
{
-
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
try
gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
{
-
if (array_check (array, 0) == FAILURE)
return FAILURE;
try
gfc_check_precision (gfc_expr * x)
{
-
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
{
must_be (x, 0, "of type REAL or COMPLEX");
try
gfc_check_radix (gfc_expr * x)
{
-
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_range (gfc_expr * x)
{
-
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_real (gfc_expr * a, gfc_expr * kind)
{
-
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
try
-gfc_check_repeat (gfc_expr * x, gfc_expr * y)
+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;
try
gfc_check_scale (gfc_expr * x, gfc_expr * i)
{
-
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
try
gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
{
-
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
+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",
try
gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
{
-
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
try
-gfc_check_size (gfc_expr * array, gfc_expr * dim)
+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 (type_check (dim, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (kind_value_check (dim, 1, gfc_default_integer_kind ()) == FAILURE)
+ if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 0) == FAILURE)
try
-gfc_check_sign (gfc_expr * a, gfc_expr * b)
+gfc_check_sleep_sub (gfc_expr * seconds)
{
-
- if (int_or_real_check (a, 0) == FAILURE)
+ if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (a, 0, b, 1) == 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)
{
must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
return FAILURE;
+
if (scalar_check (ncopies, 2) == FAILURE)
return FAILURE;
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_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)
try
gfc_check_transpose (gfc_expr * matrix)
{
-
if (rank_check (matrix, 0, 2) == FAILURE)
return FAILURE;
try
gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
{
-
if (array_check (array, 0) == 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;
try
gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
{
-
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
gfc_check_x (gfc_expr * x)
{
-
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
try
gfc_check_cpu_time (gfc_expr * time)
{
-
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
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)
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;
try
gfc_check_random_number (gfc_expr * harvest)
{
-
if (type_check (harvest, 0, BT_REAL) == FAILURE)
return FAILURE;
try
gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
{
-
if (size != NULL)
{
if (scalar_check (size, 0) == FAILURE)
if (variable_check (size, 0) == FAILURE)
return FAILURE;
- if (kind_value_check (size, 0, gfc_default_integer_kind ()) == FAILURE)
+ if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
return FAILURE;
}
if (type_check (put, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (kind_value_check (put, 1, gfc_default_integer_kind ()) == FAILURE)
+ if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
}
if (variable_check (get, 2) == FAILURE)
return FAILURE;
- if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE)
+ if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
return FAILURE;
}
try
gfc_check_second_sub (gfc_expr * time)
{
-
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
gfc_expr * count_max)
{
-
if (count != NULL)
{
if (scalar_check (count, 0) == FAILURE)
if (variable_check (count_rate, 1) == FAILURE)
return FAILURE;
- if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
+ if (count != NULL
+ && same_type_check (count, 0, count_rate, 1) == FAILURE)
return FAILURE;
}
if (variable_check (count_max, 2) == FAILURE)
return FAILURE;
- if (count != NULL && same_type_check(count, 0, count_max, 2) == 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)
+ && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
return FAILURE;
+ }
- }
-
- return SUCCESS;
+ return SUCCESS;
}
try
gfc_check_irand (gfc_expr * x)
{
+ if (x == NULL)
+ return SUCCESS;
+
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_rand (gfc_expr * x)
{
+ if (x == NULL)
+ return SUCCESS;
+
if (scalar_check (x, 0) == 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_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_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_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;
+}
OSDN Git Service
