/* Check functions
- Copyright (C) 2002 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 GNU G95.
+This file is part of GCC.
-GNU G95 is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
You should have received a copy of the GNU General Public License
-along with GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA. */
/* These functions check to see if an argument list is compatible with
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)
{
-
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. */
-
-static try
-min_max_args (gfc_actual_arglist * arg)
+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 (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;
- }
+ 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;
}
-static try
-check_rest (bt type, int kind, gfc_actual_arglist * arg)
+try
+gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
{
- gfc_expr *x;
- int n;
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (min_max_args (arg) == FAILURE)
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
- n = 1;
+ return SUCCESS;
+}
- for (; arg; arg = arg->next, n++)
- {
- x = arg->expr;
+
+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",
+ 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)
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");
MASK NULL
NULL MASK minloc(array, mask=m)
DIM MASK
-*/
+
+ 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. */
try
-gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
+gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
{
+ gfc_expr *a, *m, *d;
- if (int_or_real_check (array, 0) == FAILURE)
+ a = ap->expr;
+ if (int_or_real_check (a, 0) == FAILURE
+ || array_check (a, 0) == FAILURE)
return FAILURE;
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
+ d = ap->next->expr;
+ m = ap->next->next->expr;
- if (a3 != NULL)
+ if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+ && ap->next->name == NULL)
{
- if (logical_array_check (a3, 2) == FAILURE)
- return FAILURE;
+ m = d;
+ d = NULL;
- if (a2 != NULL)
- {
- if (scalar_check (a2, 1) == FAILURE)
- return FAILURE;
- if (type_check (a2, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
- }
+ ap->next->expr = NULL;
+ ap->next->next->expr = m;
}
- else
- {
- if (a2 != NULL)
- {
- switch (a2->ts.type)
- {
- case BT_INTEGER:
- if (scalar_check (a2, 1) == FAILURE)
- return FAILURE;
- break;
- case BT_LOGICAL: /* The '2' makes the error message correct */
- if (logical_array_check (a2, 2) == FAILURE)
- return FAILURE;
- break;
+ if (d != NULL
+ && (scalar_check (d, 1) == FAILURE
+ || type_check (d, 1, BT_INTEGER) == FAILURE))
+ return FAILURE;
- default:
- type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */
- return FAILURE;
- }
- }
- }
+ if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
-gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+/* Similar to minloc/maxloc, the argument list might need to be
+ reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
+ difference is that MINLOC/MAXLOC take an additional KIND argument.
+ The possibilities are:
+
+ Arg #2 Arg #3
+ NULL NULL
+ DIM NULL
+ MASK NULL
+ NULL MASK minval(array, mask=m)
+ DIM MASK
+
+ 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 try
+check_reduction (gfc_actual_arglist * ap)
{
+ gfc_expr *m, *d;
- if (array_check (array, 0) == 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 (d != NULL
+ && (scalar_check (d, 1) == FAILURE
+ || type_check (d, 1, BT_INTEGER) == FAILURE))
return FAILURE;
- if (int_or_real_check (array, 0) == FAILURE)
+ if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == 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 (mask != NULL && logical_array_check (mask, 2) == 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 SUCCESS;
+ 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_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_check_radix (gfc_expr * x)
{
-
- if (array_check (array, 0) == FAILURE)
+ if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
- if (numeric_check (array, 0) == FAILURE)
- return FAILURE;
+ return SUCCESS;
+}
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
- if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
+try
+gfc_check_range (gfc_expr * x)
+{
+ if (numeric_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
+/* real, float, sngl. */
try
-gfc_check_radix (gfc_expr * x)
+gfc_check_real (gfc_expr * a, gfc_expr * kind)
{
+ if (numeric_check (a, 0) == FAILURE)
+ return FAILURE;
- if (int_or_real_check (x, 0) == FAILURE)
+ if (kind_check (kind, 1, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_range (gfc_expr * x)
+gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
{
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (numeric_check (x, 0) == FAILURE)
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/* real, float, sngl. */
try
-gfc_check_real (gfc_expr * a, gfc_expr * kind)
+gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
{
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (numeric_check (a, 0) == FAILURE)
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (kind_check (kind, 1, BT_REAL) == 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_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
{
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (array_check (array, 0) == FAILURE)
+ if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
- if (numeric_check (array, 0) == FAILURE)
+ if (type_check (array, 1, BT_INTEGER) == FAILURE
+ || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == 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 (mask != NULL && logical_array_check (mask, 2) == 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;
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 (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)
+ 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 (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;
}
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;
+}
+
+
+/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
+ count, count_rate, and count_max are all optional arguments */
+
+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_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_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_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
