/* Check functions
- Copyright (C) 2002 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 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, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, 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"
#include "intrinsic.h"
-/* The fundamental complaint function of this source file. This
- function can be called in all kinds of ways. */
-
-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);
-}
-
-
/* Check the type of an expression. */
static try
type_check (gfc_expr * e, int n, bt type)
{
-
if (e->ts.type == type)
return SUCCESS;
- must_be (e, n, gfc_basic_typename (type));
+ 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;
- must_be (e, n, "a numeric type");
+ 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)
{
- must_be (e, n, "INTEGER or 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;
+}
+
+
+/* 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)
+ {
+ 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;
}
if (k->expr_type != EXPR_CONSTANT)
{
- must_be (k, n, "a 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) == -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");
+ 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;
}
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");
+ 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;
}
static try
array_check (gfc_expr * e, int n)
{
-
if (e->rank != 0)
return SUCCESS;
- must_be (e, n, "an array");
+ 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;
- must_be (e, n, "a scalar");
+ 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)
{
- char message[100];
-
if (gfc_compare_types (&e->ts, &f->ts))
return SUCCESS;
- sprintf (message, "the same type and kind as '%s'",
- gfc_current_intrinsic_arg[n]);
-
- must_be (f, m, message);
-
+ 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)
{
- char message[100];
-
if (e->rank == rank)
return SUCCESS;
- sprintf (message, "of rank %d", rank);
-
- must_be (e, n, message);
-
+ 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",
static try
kind_value_check (gfc_expr * e, int n, int k)
{
- char message[100];
-
if (e->ts.kind == k)
return SUCCESS;
- sprintf (message, "of kind %d", k);
-
- must_be (e, n, message);
+ 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
return FAILURE;
}
- must_be (e, n, "a variable");
+ 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)
- {
- if (dim == NULL)
- return SUCCESS;
-
- if (nonoptional_check (dim, n) == FAILURE)
- return FAILURE;
-
- return SUCCESS;
- }
+ if (optional && dim == NULL)
+ return SUCCESS;
if (dim == NULL)
{
if (scalar_check (dim, n) == FAILURE)
return FAILURE;
+ if (nonoptional_check (dim, n) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
return SUCCESS;
}
+/* Compare the size of a along dimension ai with the size of b along
+ dimension bi, returning 0 if they are known not to be identical,
+ and 1 if they are identical, or if this cannot be determined. */
+
+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;
+}
/***** Check functions *****/
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;
if (!array->symtree->n.sym->attr.allocatable)
{
- must_be (array, 0, "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;
}
try
gfc_check_a_p (gfc_expr * a, gfc_expr * p)
{
-
if (int_or_real_check (a, 0) == FAILURE)
return FAILURE;
- if (same_type_check (a, 0, p, 1) == 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;
}
int i;
try t;
- if (variable_check (pointer, 0) == FAILURE)
- return FAILURE;
+ 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
+ gcc_assert (0); /* Pointer must be a variable or a function. */
- attr = gfc_variable_attr (pointer, NULL);
if (!attr.pointer)
{
- must_be (pointer, 0, "a 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;
}
+ /* Target argument is optional. */
if (target == NULL)
return SUCCESS;
- /* Target argument is optional. */
if (target->expr_type == EXPR_NULL)
{
gfc_error ("NULL pointer at %L is not permitted as actual argument "
return FAILURE;
}
- attr = gfc_variable_attr (target, NULL);
+ 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
+ gcc_assert (0); /* Target must be a variable or a function. */
+
if (!attr.pointer && !attr.target)
{
- must_be (target, 1, "a POINTER or a 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;
}
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 an pointer",
+ "be the target of a pointer",
&target->where);
t = FAILURE;
break;
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;
if (x->ts.type == BT_COMPLEX)
{
- must_be (y, 1, "not be present if 'x' is 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;
}
}
try
-gfc_check_count (gfc_expr * mask, gfc_expr * dim)
+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)
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)
+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 (x->ts.type == BT_COMPLEX)
{
- must_be (y, 1, "not be present if 'x' is 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;
}
}
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:
break;
default:
- must_be (vector_a, 0, "numeric or LOGICAL");
+ 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_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;
+ }
+
return SUCCESS;
}
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 (int_or_real_check (x, 0) == FAILURE)
+ if (type_check (a, 0, BT_COMPLEX) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/* Check that the single argument is an integer. */
+/* A single real argument. */
try
-gfc_check_i (gfc_expr * i)
+gfc_check_fn_r (gfc_expr * a)
{
-
- if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ if (type_check (a, 0, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
-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)
- return FAILURE;
-
- if (same_type_check (i, 0, j, 1) == FAILURE)
- return FAILURE;
-
- return SUCCESS;
-}
-
+/* A single real or complex argument. */
try
-gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
+gfc_check_fn_rc (gfc_expr * a)
{
-
- 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 (real_or_complex_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
+gfc_check_fnum (gfc_expr * unit)
{
+ if (type_check (unit, 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 (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_ibset (gfc_expr * i, gfc_expr * pos)
+gfc_check_g77_math1 (gfc_expr * x)
{
+ if (scalar_check (x, 0) == 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 (x, 0, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_idnint (gfc_expr * a)
+gfc_check_huge (gfc_expr * x)
{
-
- if (double_check (a, 0) == FAILURE)
+ if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
+/* Check that the single argument is an integer. */
+
try
-gfc_check_ieor (gfc_expr * i, gfc_expr * j)
+gfc_check_i (gfc_expr * i)
{
-
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (j, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
-
- if (same_type_check (i, 0, j, 1) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
+gfc_check_iand (gfc_expr * i, gfc_expr * j)
{
-
- if (type_check (string, 0, BT_CHARACTER) == FAILURE
- || type_check (substring, 1, BT_CHARACTER) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
-
- if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (string->ts.kind != substring->ts.kind)
+ if (i->ts.kind != j->ts.kind)
{
- must_be (substring, 1, "the same kind as 'string'");
- return FAILURE;
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
+ &i->where) == FAILURE)
+ return FAILURE;
}
return SUCCESS;
try
-gfc_check_int (gfc_expr * x, gfc_expr * kind)
+gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (numeric_check (x, 0) == FAILURE
- || kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_ior (gfc_expr * i, gfc_expr * j)
+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 (j, 1, BT_INTEGER) == FAILURE)
+ if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (i, 0, j, 1) == FAILURE)
+ if (type_check (len, 2, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
+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 (shift, 1, BT_INTEGER) == FAILURE)
+ if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
+gfc_check_ichar_iachar (gfc_expr * c)
{
+ int i;
- if (type_check (i, 0, BT_INTEGER) == FAILURE
+ 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;
+
+ /* 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)
+ {
+ /* 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
+ 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_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;
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");
+ 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;
}
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 (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)
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_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))
{
- must_be (matrix_a, 0, "numeric or LOGICAL");
+ 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))
{
- must_be (matrix_b, 0, "numeric or LOGICAL");
+ 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;
}
case 1:
if (rank_check (matrix_b, 1, 2) == FAILURE)
return FAILURE;
+ /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
+ if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
+ {
+ gfc_error ("different shape on dimension 1 for arguments '%s' "
+ "and '%s' at %L for intrinsic matmul",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1],
+ &matrix_a->where);
+ return FAILURE;
+ }
break;
case 2:
- if (matrix_b->rank == 2)
- break;
- if (rank_check (matrix_b, 1, 1) == FAILURE)
- return FAILURE;
+ if (matrix_b->rank != 2)
+ {
+ if (rank_check (matrix_b, 1, 1) == FAILURE)
+ return FAILURE;
+ }
+ /* matrix_b has rank 1 or 2 here. Common check for the cases
+ - matrix_a has shape (n,m) and matrix_b has shape (m, k)
+ - matrix_a has shape (n,m) and matrix_b has shape (m). */
+ if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
+ {
+ gfc_error ("different shape on dimension 2 for argument '%s' and "
+ "dimension 1 for argument '%s' at %L for intrinsic "
+ "matmul", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], &matrix_a->where);
+ return FAILURE;
+ }
break;
default:
- must_be (matrix_a, 0, "of rank 1 or 2");
+ 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;
}
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 (dim_check (d, 1, 1) == FAILURE)
+ return FAILURE;
- default:
- type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */
- 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_expr * array, gfc_expr * dim, gfc_expr * mask)
-{
-
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
+/* 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:
- if (int_or_real_check (array, 0) == FAILURE)
+ 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 *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 (dim_check (dim, 1, 1) == FAILURE)
+ if (d && dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
- if (mask != NULL && logical_array_check (mask, 2) == 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;
+
+ 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)
{
+ 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_nearest (gfc_expr * x, gfc_expr * s)
{
-
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
if (!attr.pointer)
{
- must_be (mold, 0, "a 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;
}
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;
- if (mask->rank != 0 && mask->rank != array->rank)
- {
- must_be (array, 0, "conformable with 'mask' argument");
- 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)
{
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");
+ 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;
}
sym = a->symtree->n.sym;
if (!sym->attr.dummy)
{
- must_be (a, 0, "a dummy variable");
+ 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)
{
- must_be (a, 0, "an OPTIONAL dummy variable");
+ 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;
}
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;
if (m > 0)
{
- gfc_error
- ("'shape' argument of 'reshape' intrinsic at %L has more than "
- stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
+ gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
+ "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
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;
if (type_check (y, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (z != NULL && type_check (z, 2, BT_LOGICAL) == 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;
+
+ return SUCCESS;
+}
+
+
+/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
+ functions). */
+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;
+
+ 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;
+
+ 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;
+}
+
+
+/* Common check function for the half a dozen intrinsics that have a
+ single real argument. */
+
+try
+gfc_check_x (gfc_expr * x)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/************* Check functions for intrinsic subroutines *************/
+
+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;
+}
+
+
+/* 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_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;
+
+ 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 (same_type_check (x, 0, y, 1) == FAILURE)
+ if (kind_value_check(time, 1, 4) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
+gfc_check_fdate_sub (gfc_expr * date)
{
-
- 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)
+ if (type_check (date, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
+gfc_check_gerror (gfc_expr * msg)
{
-
- if (type_check (x, 0, BT_REAL) == FAILURE)
- return FAILURE;
-
- if (type_check (i, 1, BT_INTEGER) == FAILURE)
+ if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_shape (gfc_expr * source)
+gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
{
- gfc_array_ref *ar;
+ if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
+ if (status == NULL)
return SUCCESS;
- ar = gfc_find_array_ref (source);
+ if (scalar_check (status, 1) == FAILURE)
+ return FAILURE;
- 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;
- }
+ if (type_check (status, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
try
-gfc_check_size (gfc_expr * array, gfc_expr * dim)
+gfc_check_getlog (gfc_expr * msg)
{
-
- if (array_check (array, 0) == FAILURE)
+ if (type_check (msg, 0, BT_CHARACTER) == 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_sign (gfc_expr * a, gfc_expr * b)
+gfc_check_exit (gfc_expr * status)
{
+ if (status == NULL)
+ return SUCCESS;
- if (int_or_real_check (a, 0) == FAILURE)
+ if (type_check (status, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (a, 0, b, 1) == FAILURE)
+ if (scalar_check (status, 0) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
+gfc_check_flush (gfc_expr * unit)
{
+ if (unit == NULL)
+ return SUCCESS;
- if (source->rank >= GFC_MAX_DIMENSIONS)
- {
- must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
- return FAILURE;
- }
-
- if (dim_check (dim, 1, 0) == FAILURE)
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
- return FAILURE;
- if (scalar_check (ncopies, 2) == FAILURE)
+ if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_check_free (gfc_expr * i)
{
-
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
-
- if (numeric_check (array, 0) == FAILURE)
- return FAILURE;
-
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
+ if (scalar_check (i, 0) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
- gfc_expr * mold ATTRIBUTE_UNUSED,
- gfc_expr * size)
+gfc_check_hostnm (gfc_expr * name)
{
-
- 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;
- }
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
try
-gfc_check_transpose (gfc_expr * matrix)
+gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (rank_check (matrix, 0, 2) == 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_ubound (gfc_expr * array, gfc_expr * dim)
+gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
{
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
- if (array_check (array, 0) == FAILURE)
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
+ if (type_check (name, 1, BT_CHARACTER) == 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)
+gfc_check_isatty (gfc_expr * unit)
{
-
- if (rank_check (vector, 0, 1) == FAILURE)
- return FAILURE;
-
- if (array_check (mask, 1) == FAILURE)
+ if (unit == NULL)
return FAILURE;
- if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (vector, 0, field, 2) == FAILURE)
+ if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
+gfc_check_perror (gfc_expr * string)
{
-
- if (type_check (x, 0, BT_CHARACTER) == FAILURE)
+ if (type_check (string, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (same_type_check (x, 0, y, 1) == FAILURE)
+ return SUCCESS;
+}
+
+
+try
+gfc_check_umask (gfc_expr * mask)
+{
+ if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
+ if (scalar_check (mask, 0) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_trim (gfc_expr * x)
+gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
{
- if (type_check (x, 0, BT_CHARACTER) == FAILURE)
+ if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (scalar_check (x, 0) == FAILURE)
+ if (scalar_check (mask, 0) == FAILURE)
return FAILURE;
- return SUCCESS;
-}
+ 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;
+}
-/* Common check function for the half a dozen intrinsics that have a
- single real argument. */
try
-gfc_check_x (gfc_expr * x)
+gfc_check_unlink (gfc_expr * name)
{
-
- if (type_check (x, 0, BT_REAL) == FAILURE)
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/************* Check functions for intrinsic subroutines *************/
-
try
-gfc_check_cpu_time (gfc_expr * time)
+gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
{
-
- if (scalar_check (time, 0) == FAILURE)
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (type_check (time, 0, BT_REAL) == FAILURE)
+ if (status == NULL)
+ return SUCCESS;
+
+ if (scalar_check (status, 1) == FAILURE)
return FAILURE;
- if (variable_check (time, 0) == FAILURE)
+ if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
- gfc_expr * zone, gfc_expr * values)
+gfc_check_signal (gfc_expr * number, gfc_expr * handler)
{
+ if (scalar_check (number, 0) == FAILURE)
+ return FAILURE;
- 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 (type_check (number, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (zone != NULL)
+ if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
- 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;
+ 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 (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;
- }
+ if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
try
-gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
- gfc_expr * to, gfc_expr * topos)
+gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
{
-
- if (type_check (from, 0, BT_INTEGER) == FAILURE)
+ if (scalar_check (number, 0) == FAILURE)
return FAILURE;
- if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
+ if (type_check (number, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (type_check (len, 2, 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 (same_type_check (from, 0, to, 3) == FAILURE)
+ if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
- if (variable_check (to, 3) == FAILURE)
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
- if (type_check (topos, 4, BT_INTEGER) == FAILURE)
+ if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_random_number (gfc_expr * harvest)
+gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
{
+ if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (type_check (harvest, 0, BT_REAL) == FAILURE)
+ if (scalar_check (status, 1) == FAILURE)
return FAILURE;
- if (variable_check (harvest, 0) == 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;
}
+/* This is used for the GNU intrinsics AND, OR and XOR. */
try
-gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
+gfc_check_and (gfc_expr * i, gfc_expr * j)
{
-
- if (size != NULL)
+ if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
{
- 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;
+ 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 (put != NULL)
+ if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
- 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;
+ 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 (get != NULL)
+ if (i->ts.type != j->ts.type)
{
- 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;
+ 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 (variable_check (get, 2) == FAILURE)
- return FAILURE;
+ if (scalar_check (i, 0) == FAILURE)
+ return FAILURE;
- if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE)
- return FAILURE;
- }
+ if (scalar_check (j, 1) == FAILURE)
+ return FAILURE;
return SUCCESS;
}