/* Check functions
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
You should have received a copy of the GNU General Public License
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. */
+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 (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)
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;
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;
}
attr = gfc_variable_attr (target, NULL);
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;
return SUCCESS;
}
-
+
/* BESJN and BESYN functions. */
try
gfc_check_besn (gfc_expr * n, gfc_expr * x)
{
-
if (scalar_check (n, 0) == FAILURE)
return FAILURE;
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)
{
-
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;
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;
}
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_fnum (gfc_expr * unit)
+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;
try
gfc_check_g77_math1 (gfc_expr * x)
{
-
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_huge (gfc_expr * x)
{
-
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_i (gfc_expr * i)
{
-
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
gfc_check_iand (gfc_expr * i, gfc_expr * j)
{
-
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (j, 1, BT_INTEGER) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (i, 0, j, 1) == FAILURE)
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (i->ts.kind != j->ts.kind)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
+ &i->where) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
try
gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (pos, 1, BT_INTEGER) == FAILURE
- || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE)
+ if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (pos, 1, BT_INTEGER) == FAILURE
- || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE
- || type_check (len, 2, BT_INTEGER) == FAILURE)
+ if (type_check (pos, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (len, 2, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (pos, 1, BT_INTEGER) == FAILURE
- || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE)
+ if (type_check (pos, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_idnint (gfc_expr * a)
+gfc_check_ichar_iachar (gfc_expr * c)
{
+ int i;
+ if (type_check (c, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ 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;
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;
if (string->ts.kind != substring->ts.kind)
{
- must_be (substring, 1, "the same kind as 'string'");
+ 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;
}
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");
+ 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_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);
}
try
gfc_check_min_max_real (gfc_actual_arglist * arg)
{
-
return check_rest (BT_REAL, gfc_default_real_kind, arg);
}
try
gfc_check_min_max_double (gfc_actual_arglist * arg)
{
-
return check_rest (BT_REAL, gfc_default_double_kind, arg);
}
try
gfc_check_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;
}
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;
}
m = ap->next->next->expr;
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name[0] == '\0')
+ && ap->next->name == NULL)
{
m = d;
d = NULL;
m = ap->next->next->expr;
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name[0] == '\0')
+ && ap->next->name == NULL)
{
m = d;
d = NULL;
try
gfc_check_minval_maxval (gfc_actual_arglist * ap)
{
-
if (int_or_real_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
return FAILURE;
-
+
return check_reduction (ap);
}
try
gfc_check_product_sum (gfc_actual_arglist * ap)
{
-
if (numeric_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
return FAILURE;
-
+
return check_reduction (ap);
}
try
gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
{
-
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
return FAILURE;
try
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
{
-
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
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)
{
-
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (mask->rank != 0 && mask->rank != array->rank)
{
- must_be (array, 0, "conformable with 'mask' argument");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
+ "with '%s' argument", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &array->where,
+ gfc_current_intrinsic_arg[1]);
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");
+ 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_radix (gfc_expr * x)
{
-
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_range (gfc_expr * x)
{
-
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
try
gfc_check_real (gfc_expr * a, gfc_expr * kind)
{
-
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
try
-gfc_check_repeat (gfc_expr * x, gfc_expr * y)
+gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
{
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
+{
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 2) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_repeat (gfc_expr * x, gfc_expr * y)
+{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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;
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;
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));
+ 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;
}
try
gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
{
-
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
{
-
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
gfc_check_stat (gfc_expr * name, gfc_expr * array)
{
-
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
{
-
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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)
try
gfc_check_second_sub (gfc_expr * time)
{
-
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
gfc_expr * count_max)
{
-
if (count != NULL)
{
if (scalar_check (count, 0) == FAILURE)
if (variable_check (count_rate, 1) == FAILURE)
return FAILURE;
- if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
+ if (count != NULL
+ && same_type_check (count, 0, count_rate, 1) == FAILURE)
return FAILURE;
}
if (variable_check (count_max, 2) == FAILURE)
return FAILURE;
- if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
+ if (count != NULL
+ && same_type_check (count, 0, count_max, 2) == FAILURE)
return FAILURE;
if (count_rate != NULL
- && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
+ && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
return FAILURE;
+ }
- }
-
- return SUCCESS;
+ return SUCCESS;
}
try
try
-gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
+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;
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;
+ return SUCCESS;
if (type_check (status, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
gfc_check_flush (gfc_expr * unit)
{
-
if (unit == NULL)
return SUCCESS;
try
-gfc_check_umask (gfc_expr * mask)
+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_ttynam_sub (gfc_expr * unit, gfc_expr * name)
+{
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (name, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_isatty (gfc_expr * unit)
+{
+ if (unit == NULL)
+ return FAILURE;
+
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_perror (gfc_expr * string)
+{
+ if (type_check (string, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_umask (gfc_expr * mask)
+{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
{
-
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
gfc_check_unlink (gfc_expr * name)
{
-
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
{
-
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
OSDN Git Service
