/* Check functions
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
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
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
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. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* 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 "gfortran.h"
#include "intrinsic.h"
+#include "constructor.h"
-/* The fundamental complaint function of this source file. This
- function can be called in all kinds of ways. */
+/* Make sure an expression is a scalar. */
-static void
-must_be (gfc_expr * e, int n, const char *thing)
+static gfc_try
+scalar_check (gfc_expr *e, int n)
{
+ if (e->rank == 0)
+ return SUCCESS;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
- thing);
+ 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;
}
/* Check the type of an expression. */
-static try
-type_check (gfc_expr * e, int n, bt type)
+static gfc_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;
}
/* Check that the expression is a numeric type. */
-static try
-numeric_check (gfc_expr * e, int n)
+static gfc_try
+numeric_check (gfc_expr *e, int n)
{
-
if (gfc_numeric_ts (&e->ts))
return SUCCESS;
- must_be (e, n, "a numeric type");
+ /* If the expression has not got a type, check if its namespace can
+ offer a default type. */
+ if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
+ && e->symtree->n.sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (e->symtree->n.sym, 0,
+ e->symtree->n.sym->ns) == SUCCESS
+ && gfc_numeric_ts (&e->symtree->n.sym->ts))
+ {
+ e->ts = e->symtree->n.sym->ts;
+ return SUCCESS;
+ }
+
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
/* Check that an expression is integer or real. */
-static try
-int_or_real_check (gfc_expr * e, int n)
+static gfc_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 gfc_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;
}
/* Check that the expression is an optional constant integer
and that it specifies a valid kind for that type. */
-static try
-kind_check (gfc_expr * k, int n, bt type)
+static gfc_try
+kind_check (gfc_expr *k, int n, bt type)
{
int kind;
if (type_check (k, n, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (scalar_check (k, n) == FAILURE)
+ 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);
/* Make sure the expression is a double precision real. */
-static try
-double_check (gfc_expr * d, int n)
+static gfc_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;
}
/* Make sure the expression is a logical array. */
-static try
-logical_array_check (gfc_expr * array, int n)
+static gfc_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;
}
/* Make sure an expression is an array. */
-static try
-array_check (gfc_expr * e, int n)
+static gfc_try
+array_check (gfc_expr *e, int n)
{
-
if (e->rank != 0)
return SUCCESS;
- must_be (e, n, "an array");
-
- return FAILURE;
-}
-
-
-/* Make sure an expression is a scalar. */
-
-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 an array",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
-/* Make sure two expression have the same type. */
+/* Make sure two expressions have the same type. */
-static try
-same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
+static gfc_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;
}
/* Make sure that an expression has a certain (nonzero) rank. */
-static try
-rank_check (gfc_expr * e, int n, int rank)
+static gfc_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;
}
/* Make sure a variable expression is not an optional dummy argument. */
-static try
-nonoptional_check (gfc_expr * e, int n)
+static gfc_try
+nonoptional_check (gfc_expr *e, int n)
{
-
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where);
-
}
/* TODO: Recursive check on nonoptional variables? */
/* Check that an expression has a particular kind. */
-static try
-kind_value_check (gfc_expr * e, int n, int k)
+static gfc_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);
+ 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);
- must_be (e, n, message);
return FAILURE;
}
/* Make sure an expression is a variable. */
-static try
-variable_check (gfc_expr * e, int n)
+static gfc_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;
}
/* Check the common DIM parameter for correctness. */
-static try
-dim_check (gfc_expr * dim, int n, int optional)
+static gfc_try
+dim_check (gfc_expr *dim, int n, bool optional)
{
-
- if (optional)
- {
- if (dim == NULL)
- return SUCCESS;
-
- if (nonoptional_check (dim, n) == FAILURE)
- return FAILURE;
-
- return SUCCESS;
- }
-
if (dim == NULL)
- {
- gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
- gfc_current_intrinsic, gfc_current_intrinsic_where);
- return FAILURE;
- }
+ return SUCCESS;
if (type_check (dim, n, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (dim, n) == FAILURE)
return FAILURE;
+ if (!optional && nonoptional_check (dim, n) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
allow_assumed is zero then dim must be less than the rank of the array
for assumed size arrays. */
-static try
-dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
+static gfc_try
+dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
{
gfc_array_ref *ar;
int rank;
- if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
+ if (dim == NULL)
+ return SUCCESS;
+
+ if (dim->expr_type != EXPR_CONSTANT
+ || (array->expr_type != EXPR_VARIABLE
+ && array->expr_type != EXPR_ARRAY))
return SUCCESS;
- ar = gfc_find_array_ref (array);
rank = array->rank;
- if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
- rank--;
+ if (array->expr_type == EXPR_VARIABLE)
+ {
+ ar = gfc_find_array_ref (array);
+ if (ar->as->type == AS_ASSUMED_SIZE
+ && !allow_assumed
+ && ar->type != AR_ELEMENT
+ && ar->type != AR_SECTION)
+ rank--;
+ }
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
}
+/* 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 whether two character expressions have the same length;
+ returns SUCCESS if they have or if the length cannot be determined. */
+
+gfc_try
+gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
+{
+ long len_a, len_b;
+ len_a = len_b = -1;
+
+ if (a->ts.u.cl && a->ts.u.cl->length
+ && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
+ else if (a->expr_type == EXPR_CONSTANT
+ && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
+ len_a = a->value.character.length;
+ else
+ return SUCCESS;
+
+ if (b->ts.u.cl && b->ts.u.cl->length
+ && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
+ else if (b->expr_type == EXPR_CONSTANT
+ && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
+ len_b = b->value.character.length;
+ else
+ return SUCCESS;
+
+ if (len_a == len_b)
+ return SUCCESS;
+
+ gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+ len_a, len_b, name, &a->where);
+ return FAILURE;
+}
+
+
/***** Check functions *****/
/* Check subroutine suitable for intrinsics taking a real argument and
a kind argument for the result. */
-static try
-check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
+static gfc_try
+check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
{
-
if (type_check (a, 0, BT_REAL) == FAILURE)
return FAILURE;
if (kind_check (kind, 1, type) == FAILURE)
return SUCCESS;
}
+
/* Check subroutine suitable for ceiling, floor and nint. */
-try
-gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
+gfc_try
+gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
{
-
return check_a_kind (a, kind, BT_INTEGER);
}
+
/* Check subroutine suitable for aint, anint. */
-try
-gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
+gfc_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)
-{
+gfc_try
+gfc_check_abs (gfc_expr *a)
+{
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
}
-try
-gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
+gfc_try
+gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
+ if (type_check (a, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (logical_array_check (mask, 0) == FAILURE)
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
+{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE
+ || scalar_check (name, 0) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (type_check (mode, 1, BT_CHARACTER) == FAILURE
+ || scalar_check (mode, 1) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_allocated (gfc_expr * array)
+gfc_try
+gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
{
+ if (logical_array_check (mask, 0) == FAILURE)
+ return FAILURE;
- if (variable_check (array, 0) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
- if (array_check (array, 0) == FAILURE)
+ if (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_allocated (gfc_expr *array)
+{
+ symbol_attribute attr;
+
+ if (variable_check (array, 0) == FAILURE)
return FAILURE;
- if (!array->symtree->n.sym->attr.allocatable)
+ attr = gfc_variable_attr (array, NULL);
+ if (!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;
}
/* Common check function where the first argument must be real or
integer and the second argument must be the same as the first. */
-try
-gfc_check_a_p (gfc_expr * a, gfc_expr * p)
+gfc_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)
+ 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;
+}
+
+
+gfc_try
+gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
+{
+ if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
+gfc_try
+gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
- symbol_attribute attr;
+ symbol_attribute attr1, attr2;
int i;
- try t;
+ gfc_try t;
+ locus *where;
- if (variable_check (pointer, 0) == FAILURE)
- return FAILURE;
+ where = &pointer->where;
+
+ if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
+ attr1 = gfc_expr_attr (pointer);
+ else if (pointer->expr_type == EXPR_NULL)
+ goto null_arg;
+ else
+ gcc_assert (0); /* Pointer must be a variable or a function. */
- attr = gfc_variable_attr (pointer, NULL);
- if (!attr.pointer)
+ if (!attr1.pointer && !attr1.proc_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. */
+ where = &target->where;
if (target->expr_type == EXPR_NULL)
+ goto null_arg;
+
+ if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
+ attr2 = gfc_expr_attr (target);
+ else
{
- gfc_error ("NULL pointer at %L is not permitted as actual argument "
- "of '%s' intrinsic function",
- &target->where, gfc_current_intrinsic);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
+ "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &target->where);
return FAILURE;
}
- attr = gfc_variable_attr (target, NULL);
- if (!attr.pointer && !attr.target)
+ if (attr1.pointer && !attr2.pointer && !attr2.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->rank > 0)
{
for (i = 0; i < target->rank; i++)
- if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
- {
- gfc_error ("Array section with a vector subscript at %L shall not "
- "be the target of an pointer",
- &target->where);
- t = FAILURE;
- break;
- }
+ if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ {
+ gfc_error ("Array section with a vector subscript at %L shall not "
+ "be the target of a pointer",
+ &target->where);
+ t = FAILURE;
+ break;
+ }
}
return t;
+
+null_arg:
+
+ gfc_error ("NULL pointer at %L is not permitted as actual argument "
+ "of '%s' intrinsic function", where, gfc_current_intrinsic);
+ return FAILURE;
+
+}
+
+
+gfc_try
+gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
+{
+ /* gfc_notify_std would be a wast of time as the return value
+ is seemingly used only for the generic resolution. The error
+ will be: Too many arguments. */
+ if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
+ return FAILURE;
+
+ return gfc_check_atan2 (y, x);
+}
+
+
+gfc_try
+gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
+{
+ if (type_check (y, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+ if (same_type_check (y, 0, x, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
}
-try
-gfc_check_btest (gfc_expr * i, gfc_expr * pos)
+/* BESJN and BESYN functions. */
+
+gfc_try
+gfc_check_besn (gfc_expr *n, gfc_expr *x)
{
+ if (type_check (n, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (x, 1, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+gfc_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)
+gfc_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_try
+gfc_check_chdir (gfc_expr *dir)
{
-
- if (numeric_check (x, 0) == FAILURE)
+ if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (y != NULL)
- {
- if (numeric_check (y, 1) == FAILURE)
- return FAILURE;
+ return SUCCESS;
+}
- if (x->ts.type == BT_COMPLEX)
- {
- must_be (y, 1, "not be present if 'x' is COMPLEX");
- return FAILURE;
- }
- }
- if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
+gfc_try
+gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
+{
+ if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (dir, 0, gfc_default_character_kind) == 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_count (gfc_expr * mask, gfc_expr * dim)
+gfc_try
+gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
- if (logical_array_check (mask, 0) == FAILURE)
+ if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
+gfc_try
+gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
- if (array_check (array, 0) == FAILURE)
+ if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (array->rank == 1)
- {
- if (scalar_check (shift, 1) == FAILURE)
- return FAILURE;
- }
- else
- {
- /* TODO: more requirements on shift parameter. */
- }
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (dim_check (dim, 2, 1) == FAILURE)
+ if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
+gfc_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;
+ }
+
+ if (y->ts.type == BT_COMPLEX)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
return FAILURE;
}
+
}
+ if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
-try
-gfc_check_dble (gfc_expr * x)
+gfc_try
+gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
+ if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or REAL", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
+ return FAILURE;
+ }
+ if (scalar_check (x, 0) == FAILURE)
+ return FAILURE;
- if (numeric_check (x, 0) == 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_digits (gfc_expr * x)
+gfc_try
+gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
-
- if (int_or_real_check (x, 0) == FAILURE)
+ if (logical_array_check (mask, 0) == FAILURE)
+ return FAILURE;
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+ if (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
+gfc_try
+gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
+ if (array_check (array, 0) == FAILURE)
+ return FAILURE;
- switch (vector_a->ts.type)
- {
- case BT_LOGICAL:
- if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
- return FAILURE;
- break;
+ if (type_check (shift, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
- case BT_INTEGER:
- case BT_REAL:
- case BT_COMPLEX:
- if (numeric_check (vector_b, 1) == FAILURE)
- return FAILURE;
- break;
+ if (dim_check (dim, 2, true) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, false) == FAILURE)
+ return FAILURE;
+
+ if (array->rank == 1 || shift->rank == 0)
+ {
+ if (scalar_check (shift, 1) == FAILURE)
+ return FAILURE;
+ }
+ else if (shift->rank == array->rank - 1)
+ {
+ int d;
+ if (!dim)
+ d = 1;
+ else if (dim->expr_type == EXPR_CONSTANT)
+ gfc_extract_int (dim, &d);
+ else
+ d = -1;
+
+ if (d > 0)
+ {
+ int i, j;
+ for (i = 0, j = 0; i < array->rank; i++)
+ if (i != d - 1)
+ {
+ if (!identical_dimen_shape (array, i, shift, j))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid shape in dimension %d (%ld/%ld)",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, i + 1,
+ mpz_get_si (array->shape[i]),
+ mpz_get_si (shift->shape[j]));
+ return FAILURE;
+ }
+
+ j += 1;
+ }
+ }
+ }
+ else
+ {
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_ctime (gfc_expr *time)
+{
+ if (scalar_check (time, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (time, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
+{
+ if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+gfc_try
+gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
+{
+ if (numeric_check (x, 0) == FAILURE)
+ return FAILURE;
+
+ if (y != NULL)
+ {
+ if (numeric_check (y, 1) == FAILURE)
+ return FAILURE;
+
+ if (x->ts.type == BT_COMPLEX)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+ "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
+ return FAILURE;
+ }
+
+ if (y->ts.type == BT_COMPLEX)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_dble (gfc_expr *x)
+{
+ if (numeric_check (x, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_digits (gfc_expr *x)
+{
+ if (int_or_real_check (x, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
+{
+ switch (vector_a->ts.type)
+ {
+ case BT_LOGICAL:
+ if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+ break;
+
+ case BT_INTEGER:
+ case BT_REAL:
+ case BT_COMPLEX:
+ if (numeric_check (vector_b, 1) == FAILURE)
+ return FAILURE;
+ break;
default:
- 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;
}
-try
-gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
- gfc_expr * dim)
+gfc_try
+gfc_check_dprod (gfc_expr *x, gfc_expr *y)
{
+ if (type_check (x, 0, BT_REAL) == FAILURE
+ || type_check (y, 1, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (x->ts.kind != gfc_default_real_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ "real", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
+ return FAILURE;
+ }
+
+ if (y->ts.kind != gfc_default_real_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ "real", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+gfc_try
+gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
+ gfc_expr *dim)
+{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ if (dim_check (dim, 3, true) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, false) == FAILURE)
+ return FAILURE;
+
+ if (array->rank == 1 || shift->rank == 0)
{
- if (scalar_check (shift, 2) == FAILURE)
+ if (scalar_check (shift, 1) == FAILURE)
return FAILURE;
}
+ else if (shift->rank == array->rank - 1)
+ {
+ int d;
+ if (!dim)
+ d = 1;
+ else if (dim->expr_type == EXPR_CONSTANT)
+ gfc_extract_int (dim, &d);
+ else
+ d = -1;
+
+ if (d > 0)
+ {
+ int i, j;
+ for (i = 0, j = 0; i < array->rank; i++)
+ if (i != d - 1)
+ {
+ if (!identical_dimen_shape (array, i, shift, j))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid shape in dimension %d (%ld/%ld)",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, i + 1,
+ mpz_get_si (array->shape[i]),
+ mpz_get_si (shift->shape[j]));
+ return FAILURE;
+ }
+
+ j += 1;
+ }
+ }
+ }
else
{
- /* TODO: more weird restrictions on shift. */
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
}
if (boundary != NULL)
if (same_type_check (array, 0, boundary, 2) == FAILURE)
return FAILURE;
- /* TODO: more restrictions on boundary. */
+ if (array->rank == 1 || boundary->rank == 0)
+ {
+ if (scalar_check (boundary, 2) == FAILURE)
+ return FAILURE;
+ }
+ else if (boundary->rank == array->rank - 1)
+ {
+ if (gfc_check_conformance (shift, boundary,
+ "arguments '%s' and '%s' for "
+ "intrinsic %s",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic ) == FAILURE)
+ return FAILURE;
+ }
+ else
+ {
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+ "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
+ }
}
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
+/* A single complex argument. */
-try
-gfc_check_huge (gfc_expr * x)
+gfc_try
+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_try
+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;
}
+/* A single double argument. */
-try
-gfc_check_iand (gfc_expr * i, gfc_expr * j)
+gfc_try
+gfc_check_fn_d (gfc_expr *a)
{
-
- 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 (double_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
+/* A single real or complex argument. */
-try
-gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
+gfc_try
+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_try
+gfc_check_fn_rc2008 (gfc_expr *a)
{
+ if (real_or_complex_check (a, 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
- || type_check (len, 2, BT_INTEGER) == FAILURE)
+ if (a->ts.type == BT_COMPLEX
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
+ "argument of '%s' intrinsic at %L",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &a->where) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
+gfc_try
+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)
+ if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_idnint (gfc_expr * a)
+gfc_try
+gfc_check_huge (gfc_expr *x)
{
-
- if (double_check (a, 0) == FAILURE)
+ if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_ieor (gfc_expr * i, gfc_expr * j)
+gfc_try
+gfc_check_hypot (gfc_expr *x, gfc_expr *y)
{
-
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (j, 1, BT_INTEGER) == FAILURE)
+ if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
-
- if (same_type_check (i, 0, j, 1) == FAILURE)
+ if (same_type_check (x, 0, y, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
-{
+/* Check that the single argument is an integer. */
- if (type_check (string, 0, BT_CHARACTER) == FAILURE
- || type_check (substring, 1, BT_CHARACTER) == FAILURE)
+gfc_try
+gfc_check_i (gfc_expr *i)
+{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
+ return SUCCESS;
+}
- if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
+
+gfc_try
+gfc_check_iand (gfc_expr *i, gfc_expr *j)
+{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (string->ts.kind != substring->ts.kind)
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ 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_try
+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_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 (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_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 (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_try
+gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
{
+ int i;
- if (type_check (i, 0, BT_INTEGER) == FAILURE
- || type_check (shift, 1, BT_INTEGER) == FAILURE)
+ if (type_check (c, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- return SUCCESS;
-}
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+ if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
+ {
+ gfc_expr *start;
+ gfc_expr *end;
+ gfc_ref *ref;
-try
-gfc_check_kind (gfc_expr * x)
-{
+ /* Substring references don't have the charlength set. */
+ ref = c->ref;
+ while (ref && ref->type != REF_SUBSTRING)
+ ref = ref->next;
- if (x->ts.type == BT_DERIVED)
+ 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 they are ok. */
+ if (c->ts.u.cl && c->ts.u.cl->length)
+ {
+ /* If we already have a length for this expression then use it. */
+ if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ return SUCCESS;
+ i = mpz_get_si (c->ts.u.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)
{
- must_be (x, 0, "a non-derived type");
+ gfc_error ("Argument of %s at %L must be of length one",
+ gfc_current_intrinsic, &c->where);
return FAILURE;
}
}
-try
-gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
+gfc_try
+gfc_check_idnint (gfc_expr *a)
{
-
- if (array_check (array, 0) == FAILURE)
+ if (double_check (a, 0) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
-
- if (dim_rank_check (dim, array, 1) == FAILURE)
- return FAILURE;
- }
return SUCCESS;
}
-try
-gfc_check_logical (gfc_expr * a, gfc_expr * kind)
+gfc_try
+gfc_check_ieor (gfc_expr *i, gfc_expr *j)
{
-
- if (type_check (a, 0, BT_LOGICAL) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (kind_check (kind, 1, BT_LOGICAL) == 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;
}
-/* Min/max family. */
-
-static try
-min_max_args (gfc_actual_arglist * arg)
+gfc_try
+gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
+ gfc_expr *kind)
{
+ if (type_check (string, 0, BT_CHARACTER) == FAILURE
+ || type_check (substring, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
- if (arg == NULL || arg->next == NULL)
+ if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+ if (string->ts.kind != substring->ts.kind)
{
- gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
- gfc_current_intrinsic, gfc_current_intrinsic_where);
+ 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;
}
}
-static try
-check_rest (bt type, int kind, gfc_actual_arglist * arg)
+gfc_try
+gfc_check_int (gfc_expr *x, gfc_expr *kind)
{
- gfc_expr *x;
- int n;
+ if (numeric_check (x, 0) == FAILURE)
+ return FAILURE;
- if (min_max_args (arg) == FAILURE)
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- n = 1;
+ return SUCCESS;
+}
+
- for (; arg; arg = arg->next, n++)
- {
- x = arg->expr;
- if (x->ts.type != type || x->ts.kind != kind)
- {
- if (x->ts.type == type)
- {
- if (gfc_notify_std (GFC_STD_GNU,
- "Extension: Different type kinds at %L", &x->where)
- == FAILURE)
- return FAILURE;
- }
- else
- {
- gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
- n, gfc_current_intrinsic, &x->where,
- gfc_basic_typename (type), kind);
- return FAILURE;
- }
- }
- }
+gfc_try
+gfc_check_intconv (gfc_expr *x)
+{
+ if (numeric_check (x, 0) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
-gfc_check_min_max (gfc_actual_arglist * arg)
+gfc_try
+gfc_check_ior (gfc_expr *i, gfc_expr *j)
{
- gfc_expr *x;
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (min_max_args (arg) == FAILURE)
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- x = arg->expr;
-
- if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+ if (i->ts.kind != j->ts.kind)
{
- gfc_error
- ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
- gfc_current_intrinsic, &x->where);
- return FAILURE;
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
+ &i->where) == FAILURE)
+ return FAILURE;
}
- return check_rest (x->ts.type, x->ts.kind, arg);
+ return SUCCESS;
}
-try
-gfc_check_min_max_integer (gfc_actual_arglist * arg)
+gfc_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 check_rest (BT_INTEGER, gfc_default_integer_kind (), arg);
+ return SUCCESS;
}
-try
-gfc_check_min_max_real (gfc_actual_arglist * arg)
+gfc_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;
- return check_rest (BT_REAL, gfc_default_real_kind (), arg);
-}
-
-
-try
-gfc_check_min_max_double (gfc_actual_arglist * arg)
-{
+ if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
- return check_rest (BT_REAL, gfc_default_double_kind (), arg);
+ return SUCCESS;
}
-/* End of min/max family. */
-
-try
-gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
+gfc_try
+gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
{
+ if (type_check (pid, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
- {
- must_be (matrix_a, 0, "numeric or LOGICAL");
- return FAILURE;
- }
-
- if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
- {
- must_be (matrix_b, 0, "numeric or LOGICAL");
- return FAILURE;
- }
-
- switch (matrix_a->rank)
- {
- case 1:
- if (rank_check (matrix_b, 1, 2) == FAILURE)
- return FAILURE;
- break;
-
- case 2:
- if (matrix_b->rank == 2)
- break;
- if (rank_check (matrix_b, 1, 1) == FAILURE)
- return FAILURE;
- break;
-
- default:
- must_be (matrix_a, 0, "of rank 1 or 2");
- return FAILURE;
- }
+ if (type_check (sig, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-/* Whoever came up with this interface was probably on something.
- The possibilities for the occupation of the second and third
- parameters are:
-
- Arg #2 Arg #3
- NULL NULL
- DIM NULL
- 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_actual_arglist * ap)
+gfc_try
+gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
{
- gfc_expr *a, *m, *d;
+ if (type_check (pid, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- a = ap->expr;
- if (int_or_real_check (a, 0) == FAILURE
- || array_check (a, 0) == FAILURE)
+ if (scalar_check (pid, 0) == FAILURE)
return FAILURE;
- d = ap->next->expr;
- m = ap->next->next->expr;
+ if (type_check (sig, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
- && ap->next->name[0] == '\0')
- {
- m = d;
- d = NULL;
+ if (scalar_check (sig, 1) == FAILURE)
+ return FAILURE;
- ap->next->expr = NULL;
- ap->next->next->expr = m;
- }
+ if (status == NULL)
+ return SUCCESS;
- if (d != NULL
- && (scalar_check (d, 1) == FAILURE
- || type_check (d, 1, BT_INTEGER) == FAILURE))
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
- if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
+ if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_try
+gfc_check_kind (gfc_expr *x)
{
+ if (x->ts.type == BT_DERIVED)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
+ "non-derived type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+gfc_try
+gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (int_or_real_check (array, 0) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_rank_check (dim, array, 1) == FAILURE)
return FAILURE;
- if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
+gfc_try
+gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
{
-
- if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
+ if (type_check (s, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
- if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_nearest (gfc_expr * x, gfc_expr * s)
+gfc_try
+gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
{
-
- if (type_check (x, 0, BT_REAL) == FAILURE)
+ if (type_check (a, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (type_check (s, 1, BT_REAL) == FAILURE)
+ if (type_check (b, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_null (gfc_expr * mold)
+gfc_try
+gfc_check_link (gfc_expr *path1, gfc_expr *path2)
{
- symbol_attribute attr;
-
- if (mold == NULL)
- return SUCCESS;
-
- if (variable_check (mold, 0) == FAILURE)
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- attr = gfc_variable_attr (mold, NULL);
-
- if (!attr.pointer)
- {
- must_be (mold, 0, "a POINTER");
- return FAILURE;
- }
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
-gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
+gfc_try
+gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
-
- if (array_check (array, 0) == FAILURE)
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
-
- if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (mask->rank != 0 && mask->rank != array->rank)
- {
- must_be (array, 0, "conformable with 'mask' argument");
- return FAILURE;
- }
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
- if (vector != NULL)
- {
- if (same_type_check (array, 0, vector, 2) == FAILURE)
- return FAILURE;
+ if (status == NULL)
+ return SUCCESS;
- if (rank_check (vector, 2, 1) == FAILURE)
- return FAILURE;
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
- /* TODO: More constraints here. */
- }
+ if (scalar_check (status, 2) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
-gfc_check_precision (gfc_expr * x)
+gfc_try
+gfc_check_loc (gfc_expr *expr)
{
-
- if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
- {
- must_be (x, 0, "of type REAL or COMPLEX");
- return FAILURE;
- }
-
- return SUCCESS;
+ return variable_check (expr, 0);
}
-try
-gfc_check_present (gfc_expr * a)
+gfc_try
+gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
{
- gfc_symbol *sym;
-
- if (variable_check (a, 0) == FAILURE)
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- sym = a->symtree->n.sym;
- if (!sym->attr.dummy)
- {
- must_be (a, 0, "a dummy variable");
- return FAILURE;
- }
-
- if (!sym->attr.optional)
- {
- must_be (a, 0, "an OPTIONAL dummy variable");
- return FAILURE;
- }
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
-gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_try
+gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
-
- if (array_check (array, 0) == FAILURE)
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
-
- if (numeric_check (array, 0) == FAILURE)
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
-
- if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
- return SUCCESS;
-}
-
+ if (status == NULL)
+ return SUCCESS;
-try
-gfc_check_radix (gfc_expr * x)
-{
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (int_or_real_check (x, 0) == FAILURE)
+ if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_range (gfc_expr * x)
+gfc_try
+gfc_check_logical (gfc_expr *a, gfc_expr *kind)
{
-
- if (numeric_check (x, 0) == FAILURE)
+ if (type_check (a, 0, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+ if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/* real, float, sngl. */
-try
-gfc_check_real (gfc_expr * a, gfc_expr * kind)
-{
-
- if (numeric_check (a, 0) == FAILURE)
- return FAILURE;
+/* Min/max family. */
- if (kind_check (kind, 1, BT_REAL) == FAILURE)
- return FAILURE;
+static gfc_try
+min_max_args (gfc_actual_arglist *arg)
+{
+ if (arg == NULL || arg->next == NULL)
+ {
+ gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
+ gfc_current_intrinsic, gfc_current_intrinsic_where);
+ return FAILURE;
+ }
return SUCCESS;
}
-try
-gfc_check_repeat (gfc_expr * x, gfc_expr * y)
+static gfc_try
+check_rest (bt type, int kind, gfc_actual_arglist *arglist)
{
+ gfc_actual_arglist *arg, *tmp;
- if (type_check (x, 0, BT_CHARACTER) == FAILURE)
- return FAILURE;
+ gfc_expr *x;
+ int m, n;
- if (scalar_check (x, 0) == FAILURE)
+ if (min_max_args (arglist) == FAILURE)
return FAILURE;
- if (type_check (y, 0, BT_INTEGER) == FAILURE)
- return FAILURE;
+ for (arg = arglist, n=1; arg; arg = arg->next, n++)
+ {
+ x = arg->expr;
+ if (x->ts.type != type || x->ts.kind != kind)
+ {
+ if (x->ts.type == type)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
+ "kinds at %L", &x->where) == FAILURE)
+ return FAILURE;
+ }
+ else
+ {
+ gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
+ "%s(%d)", n, gfc_current_intrinsic, &x->where,
+ gfc_basic_typename (type), kind);
+ return FAILURE;
+ }
+ }
- if (scalar_check (y, 1) == FAILURE)
- return FAILURE;
+ for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
+ if (gfc_check_conformance (tmp->expr, x,
+ "arguments 'a%d' and 'a%d' for "
+ "intrinsic '%s'", m, n,
+ gfc_current_intrinsic) == FAILURE)
+ return FAILURE;
+ }
return SUCCESS;
}
-try
-gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
- gfc_expr * pad, gfc_expr * order)
+gfc_try
+gfc_check_min_max (gfc_actual_arglist *arg)
{
- mpz_t size;
- int m;
-
- if (array_check (source, 0) == FAILURE)
- return FAILURE;
+ gfc_expr *x;
- if (rank_check (shape, 1, 1) == FAILURE)
+ if (min_max_args (arg) == FAILURE)
return FAILURE;
- if (type_check (shape, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
+ x = arg->expr;
- if (gfc_array_size (shape, &size) != SUCCESS)
+ if (x->ts.type == BT_CHARACTER)
{
- gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
- "array of constant size", &shape->where);
- return FAILURE;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with CHARACTER argument at %L",
+ gfc_current_intrinsic, &x->where) == FAILURE)
+ return FAILURE;
}
-
- m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
- mpz_clear (size);
-
- if (m > 0)
+ else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
- gfc_error
- ("'shape' argument of 'reshape' intrinsic at %L has more than "
- stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
+ gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+ "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
return FAILURE;
}
- if (pad != NULL)
- {
- if (same_type_check (source, 0, pad, 2) == FAILURE)
- return FAILURE;
- if (array_check (pad, 2) == FAILURE)
- return FAILURE;
- }
-
- if (order != NULL && array_check (order, 3) == FAILURE)
- return FAILURE;
-
- return SUCCESS;
+ return check_rest (x->ts.type, x->ts.kind, arg);
}
-try
-gfc_check_scale (gfc_expr * x, gfc_expr * i)
+gfc_try
+gfc_check_min_max_integer (gfc_actual_arglist *arg)
{
+ return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
+}
- if (type_check (x, 0, BT_REAL) == FAILURE)
- return FAILURE;
-
- if (type_check (i, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
- return SUCCESS;
+gfc_try
+gfc_check_min_max_real (gfc_actual_arglist *arg)
+{
+ return check_rest (BT_REAL, gfc_default_real_kind, arg);
}
-try
-gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
+gfc_try
+gfc_check_min_max_double (gfc_actual_arglist *arg)
{
+ return check_rest (BT_REAL, gfc_default_double_kind, arg);
+}
- if (type_check (x, 0, BT_CHARACTER) == FAILURE)
- return FAILURE;
- if (type_check (y, 1, BT_CHARACTER) == FAILURE)
- return FAILURE;
+/* End of min/max family. */
- if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
+gfc_try
+gfc_check_malloc (gfc_expr *size)
+{
+ if (type_check (size, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (x, 0, y, 1) == FAILURE)
+ if (scalar_check (size, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
+gfc_try
+gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
{
-
- if (p == NULL && r == NULL)
+ if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
{
- gfc_error ("Missing arguments to %s intrinsic at %L",
- gfc_current_intrinsic, gfc_current_intrinsic_where);
-
+ 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 (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;
-}
+ if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ "or LOGICAL", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &matrix_b->where);
+ return FAILURE;
+ }
+ if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
+ || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
+ {
+ gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
+ gfc_current_intrinsic, &matrix_a->where,
+ gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
+ return FAILURE;
+ }
-try
-gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
+ switch (matrix_a->rank)
+ {
+ 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)
+ {
+ 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:
+ 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;
+ }
+
+ return SUCCESS;
+}
+
+
+/* Whoever came up with this interface was probably on something.
+ The possibilities for the occupation of the second and third
+ parameters are:
+
+ Arg #2 Arg #3
+ NULL NULL
+ DIM NULL
+ 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. */
+
+gfc_try
+gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
+{
+ gfc_expr *a, *m, *d;
+
+ a = ap->expr;
+ if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
+ return FAILURE;
+
+ d = ap->next->expr;
+ m = ap->next->next->expr;
+
+ if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+ && ap->next->name == NULL)
+ {
+ m = d;
+ d = NULL;
+ ap->next->expr = NULL;
+ ap->next->next->expr = m;
+ }
+
+ if (dim_check (d, 1, false) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (d, a, 0) == FAILURE)
+ return FAILURE;
+
+ if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (m != NULL
+ && gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic ) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/* Similar to minloc/maxloc, the argument list might need to be
+ reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
+ difference is that MINLOC/MAXLOC take an additional KIND argument.
+ The possibilities are:
+
+ Arg #2 Arg #3
+ NULL NULL
+ DIM NULL
+ MASK NULL
+ NULL MASK minval(array, mask=m)
+ DIM MASK
+
+ I.e. in the case of minval(array,mask), mask will be in the second
+ position of the argument list and we'll have to fix that up. */
+
+static gfc_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, false) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (d, a, 0) == FAILURE)
+ return FAILURE;
+
+ if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (m != NULL
+ && gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_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);
+}
+
+
+gfc_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);
+}
+
+
+gfc_try
+gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
+{
+ if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (tsource->ts.type == BT_CHARACTER)
+ return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
+{
+ symbol_attribute attr;
+
+ if (variable_check (from, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (from, NULL);
+ if (!attr.allocatable)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &from->where);
+ return FAILURE;
+ }
+
+ if (variable_check (to, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (to, NULL);
+ if (!attr.allocatable)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &to->where);
+ return FAILURE;
+ }
+
+ if (same_type_check (to, 1, from, 0) == FAILURE)
+ return FAILURE;
+
+ if (to->rank != from->rank)
+ {
+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
+ "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &to->where, from->rank, to->rank);
+ return FAILURE;
+ }
+
+ if (to->ts.kind != from->ts.kind)
+ {
+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
+ "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &to->where, from->ts.kind, to->ts.kind);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_nearest (gfc_expr *x, gfc_expr *s)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (type_check (s, 1, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_new_line (gfc_expr *a)
+{
+ if (type_check (a, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_null (gfc_expr *mold)
+{
+ symbol_attribute attr;
+
+ if (mold == NULL)
+ return SUCCESS;
+
+ if (variable_check (mold, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (mold, NULL);
+
+ if (!attr.pointer && !attr.proc_pointer)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &mold->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
+{
+ if (array_check (array, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (gfc_check_conformance (array, mask,
+ "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic) == FAILURE)
+ return FAILURE;
+
+ if (vector != NULL)
+ {
+ mpz_t array_size, vector_size;
+ bool have_array_size, have_vector_size;
+
+ if (same_type_check (array, 0, vector, 2) == FAILURE)
+ return FAILURE;
+
+ if (rank_check (vector, 2, 1) == FAILURE)
+ return FAILURE;
+
+ /* VECTOR requires at least as many elements as MASK
+ has .TRUE. values. */
+ have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
+ have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
+
+ if (have_vector_size
+ && (mask->expr_type == EXPR_ARRAY
+ || (mask->expr_type == EXPR_CONSTANT
+ && have_array_size)))
+ {
+ int mask_true_values = 0;
+
+ if (mask->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+ {
+ mask_true_values = 0;
+ break;
+ }
+
+ if (mask_ctor->expr->value.logical)
+ mask_true_values++;
+
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
+ }
+ else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
+ mask_true_values = mpz_get_si (array_size);
+
+ if (mpz_get_si (vector_size) < mask_true_values)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ "provide at least as many elements as there "
+ "are .TRUE. values in '%s' (%ld/%d)",
+ gfc_current_intrinsic_arg[2],gfc_current_intrinsic,
+ &vector->where, gfc_current_intrinsic_arg[1],
+ mpz_get_si (vector_size), mask_true_values);
+ return FAILURE;
+ }
+ }
+
+ if (have_array_size)
+ mpz_clear (array_size);
+ if (have_vector_size)
+ mpz_clear (vector_size);
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_precision (gfc_expr *x)
+{
+ if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
+ "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_present (gfc_expr *a)
+{
+ gfc_symbol *sym;
+
+ if (variable_check (a, 0) == FAILURE)
+ return FAILURE;
+
+ sym = a->symtree->n.sym;
+ if (!sym->attr.dummy)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
+ "dummy variable", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
+ return FAILURE;
+ }
+
+ if (!sym->attr.optional)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
+ "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
+ return FAILURE;
+ }
+
+ /* 13.14.82 PRESENT(A)
+ ......
+ Argument. A shall be the name of an optional dummy argument that is
+ accessible in the subprogram in which the PRESENT function reference
+ appears... */
+
+ if (a->ref != NULL
+ && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
+ && a->ref->u.ar.type == AR_FULL))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
+ "subobject of '%s'", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where, sym->name);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_radix (gfc_expr *x)
+{
+ if (int_or_real_check (x, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_range (gfc_expr *x)
+{
+ if (numeric_check (x, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/* real, float, sngl. */
+gfc_try
+gfc_check_real (gfc_expr *a, gfc_expr *kind)
+{
+ if (numeric_check (a, 0) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 1, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
+{
+ if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_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 (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == 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;
+}
+
+
+gfc_try
+gfc_check_repeat (gfc_expr *x, gfc_expr *y)
+{
+ if (type_check (x, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (x, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (y, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (y, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
+ gfc_expr *pad, gfc_expr *order)
+{
+ mpz_t size;
+ mpz_t nelems;
+ int shape_size;
+
+ if (array_check (source, 0) == FAILURE)
+ return FAILURE;
+
+ if (rank_check (shape, 1, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (shape, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (gfc_array_size (shape, &size) != SUCCESS)
+ {
+ gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
+ "array of constant size", &shape->where);
+ return FAILURE;
+ }
+
+ shape_size = mpz_get_ui (size);
+ mpz_clear (size);
+
+ if (shape_size <= 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &shape->where);
+ return FAILURE;
+ }
+ else if (shape_size > GFC_MAX_DIMENSIONS)
+ {
+ gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
+ "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
+ return FAILURE;
+ }
+ else if (shape->expr_type == EXPR_ARRAY)
+ {
+ gfc_expr *e;
+ int i, extent;
+ for (i = 0; i < shape_size; ++i)
+ {
+ e = gfc_constructor_lookup_expr (shape->value.constructor, i);
+ if (e->expr_type != EXPR_CONSTANT)
+ continue;
+
+ gfc_extract_int (e, &extent);
+ if (extent < 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "negative element (%d)", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &e->where, extent);
+ return FAILURE;
+ }
+ }
+ }
+
+ if (pad != NULL)
+ {
+ if (same_type_check (source, 0, pad, 2) == FAILURE)
+ return FAILURE;
+
+ if (array_check (pad, 2) == FAILURE)
+ return FAILURE;
+ }
+
+ if (order != NULL)
+ {
+ if (array_check (order, 3) == FAILURE)
+ return FAILURE;
+
+ if (type_check (order, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (order->expr_type == EXPR_ARRAY)
+ {
+ int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+
+ for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
+ perm[i] = 0;
+
+ gfc_array_size (order, &size);
+ order_size = mpz_get_ui (size);
+ mpz_clear (size);
+
+ if (order_size != shape_size)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "has wrong number of elements (%d/%d)",
+ gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &order->where,
+ order_size, shape_size);
+ return FAILURE;
+ }
+
+ for (i = 1; i <= order_size; ++i)
+ {
+ e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
+ if (e->expr_type != EXPR_CONSTANT)
+ continue;
+
+ gfc_extract_int (e, &dim);
+
+ if (dim < 1 || dim > order_size)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "has out-of-range dimension (%d)",
+ gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &e->where, dim);
+ return FAILURE;
+ }
+
+ if (perm[dim-1] != 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid permutation of dimensions (dimension "
+ "'%d' duplicated)", gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &e->where, dim);
+ return FAILURE;
+ }
+
+ perm[dim-1] = 1;
+ }
+ }
+ }
+
+ if (pad == NULL && shape->expr_type == EXPR_ARRAY
+ && gfc_is_constant_expr (shape)
+ && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
+ && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
+ {
+ /* Check the match in size between source and destination. */
+ if (gfc_array_size (source, &nelems) == SUCCESS)
+ {
+ gfc_constructor *c;
+ bool test;
+
+
+ mpz_init_set_ui (size, 1);
+ for (c = gfc_constructor_first (shape->value.constructor);
+ c; c = gfc_constructor_next (c))
+ mpz_mul (size, size, c->expr->value.integer);
+
+ test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
+ mpz_clear (nelems);
+ mpz_clear (size);
+
+ if (test)
+ {
+ gfc_error ("Without padding, there are not enough elements "
+ "in the intrinsic RESHAPE source at %L to match "
+ "the shape", &source->where);
+ return FAILURE;
+ }
+ }
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+
+ if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of a derived type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
+ return FAILURE;
+ }
+
+ if (!gfc_type_is_extensible (a->ts.u.derived))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of an extensible type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
+ return FAILURE;
+ }
+
+ if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of a derived type", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &b->where);
+ return FAILURE;
+ }
+
+ if (!gfc_type_is_extensible (b->ts.u.derived))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of an extensible type", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &b->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_scale (gfc_expr *x, gfc_expr *i)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (type_check (i, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
+{
+ if (type_check (x, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (y, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+ if (same_type_check (x, 0, y, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_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;
+}
+
+
+gfc_try
+gfc_check_selected_char_kind (gfc_expr *name)
+{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (name, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_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;
+}
+
+
+gfc_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;
+}
+
+
+gfc_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;
+}
+
+
+gfc_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 && ar->type == AR_FULL)
+ {
+ gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
+ "an assumed size array", &source->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_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;
+}
+
+
+gfc_try
+gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ if (array_check (array, 0) == FAILURE)
+ return FAILURE;
+
+ if (dim_check (dim, 1, true) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, 0) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
+{
+ return SUCCESS;
+}
+
+
+gfc_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;
+}
+
+
+gfc_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 == NULL)
+ return FAILURE;
+
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+
+ /* dim_rank_check() does not apply here. */
+ if (dim
+ && dim->expr_type == EXPR_CONSTANT
+ && (mpz_cmp_ui (dim->value.integer, 1) < 0
+ || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+ "dimension index", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &dim->where);
+ 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). */
+
+gfc_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 (kind_value_check (c, 1, gfc_default_character_kind) == 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;
+}
+
+
+gfc_try
+gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
+{
+ return gfc_check_fgetputc_sub (unit, c, NULL);
+}
+
+
+gfc_try
+gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
+{
+ if (type_check (c, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (c, 0, gfc_default_character_kind) == 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;
+}
+
+
+gfc_try
+gfc_check_fgetput (gfc_expr *c)
+{
+ return gfc_check_fgetput_sub (c, NULL);
+}
+
+
+gfc_try
+gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
+{
+ 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;
+
+ if (type_check (whence, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (whence, 2) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check (status, 3, 4) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 3) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+
+gfc_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;
+}
+
+
+gfc_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;
+}
+
+
+gfc_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;
+}
+
+
+gfc_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;
+}
+
+
+gfc_try
+gfc_check_stat (gfc_expr *name, gfc_expr *array)
+{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == 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;
+}
+
+
+gfc_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 (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ if (type_check (array, 1, BT_INTEGER) == FAILURE
+ || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
+ return FAILURE;
+
+ if (array_check (array, 1) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 2, BT_INTEGER) == FAILURE
+ || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 2) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
+ gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
+{
+ if (mold->ts.type == BT_HOLLERITH)
+ {
+ gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
+ &mold->where, gfc_basic_typename (BT_HOLLERITH));
+ return FAILURE;
+ }
+
+ 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;
+}
+
+
+gfc_try
+gfc_check_transpose (gfc_expr *matrix)
+{
+ if (rank_check (matrix, 0, 2) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ if (array_check (array, 0) == FAILURE)
+ return FAILURE;
+
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, 0) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
+{
+ mpz_t vector_size;
+
+ if (rank_check (vector, 0, 1) == FAILURE)
+ return FAILURE;
+
+ if (array_check (mask, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (same_type_check (vector, 0, field, 2) == FAILURE)
+ return FAILURE;
+
+ if (mask->expr_type == EXPR_ARRAY
+ && gfc_array_size (vector, &vector_size) == SUCCESS)
+ {
+ int mask_true_count = 0;
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+ {
+ mask_true_count = 0;
+ break;
+ }
+
+ if (mask_ctor->expr->value.logical)
+ mask_true_count++;
+
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
+
+ if (mpz_get_si (vector_size) < mask_true_count)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ "provide at least as many elements as there "
+ "are .TRUE. values in '%s' (%ld/%d)",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &vector->where, gfc_current_intrinsic_arg[1],
+ mpz_get_si (vector_size), mask_true_count);
+ return FAILURE;
+ }
+
+ mpz_clear (vector_size);
+ }
+
+ if (mask->rank != field->rank && field->rank != 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
+ "the same rank as '%s' or be a scalar",
+ gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
+ &field->where, gfc_current_intrinsic_arg[1]);
+ return FAILURE;
+ }
+
+ if (mask->rank == field->rank)
+ {
+ int i;
+ for (i = 0; i < field->rank; i++)
+ if (! identical_dimen_shape (mask, i, field, i))
+ {
+ gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
+ "must have identical shape.",
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &field->where);
+ }
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
+{
+ 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;
+
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_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;
+}
+
+
+gfc_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. */
+
+gfc_try
+gfc_check_x (gfc_expr *x)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/************* Check functions for intrinsic subroutines *************/
+
+gfc_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;
+}
+
+
+gfc_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 (kind_value_check (date, 0, gfc_default_character_kind) == 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 (kind_value_check (time, 1, gfc_default_character_kind) == 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 (kind_value_check (zone, 2, gfc_default_character_kind) == 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;
+}
+
+
+gfc_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;
- if (type_check (x, 0, BT_REAL) == FAILURE)
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_random_number (gfc_expr *harvest)
+{
+ if (type_check (harvest, 0, BT_REAL) == FAILURE)
return FAILURE;
- if (type_check (i, 1, BT_INTEGER) == FAILURE)
+ if (variable_check (harvest, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_shape (gfc_expr * source)
+gfc_try
+gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
- gfc_array_ref *ar;
+ unsigned int nargs = 0, kiss_size;
+ locus *where = NULL;
+ mpz_t put_size, get_size;
+ bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
- return SUCCESS;
+ have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
- ar = gfc_find_array_ref (source);
+ /* Keep the number of bytes in sync with kiss_size in
+ libgfortran/intrinsics/random.c. */
+ kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
- if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
+ if (size != NULL)
{
- gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
- "an assumed size array", &source->where);
- return FAILURE;
+ if (size->expr_type != EXPR_VARIABLE
+ || !size->symtree->n.sym->attr.optional)
+ nargs++;
+
+ 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 (put->expr_type != EXPR_VARIABLE
+ || !put->symtree->n.sym->attr.optional)
+ {
+ nargs++;
+ where = &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 (gfc_array_size (put, &put_size) == SUCCESS
+ && mpz_get_ui (put_size) < kiss_size)
+ gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ "too small (%i/%i)",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
+ (int) mpz_get_ui (put_size), kiss_size);
+ }
+
+ if (get != NULL)
+ {
+ if (get->expr_type != EXPR_VARIABLE
+ || !get->symtree->n.sym->attr.optional)
+ {
+ nargs++;
+ where = &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;
+
+ if (gfc_array_size (get, &get_size) == SUCCESS
+ && mpz_get_ui (get_size) < kiss_size)
+ gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ "too small (%i/%i)",
+ gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
+ (int) mpz_get_ui (get_size), kiss_size);
}
+ /* RANDOM_SEED may not have more than one non-optional argument. */
+ if (nargs > 1)
+ gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
+
return SUCCESS;
}
-try
-gfc_check_size (gfc_expr * array, gfc_expr * dim)
+gfc_try
+gfc_check_second_sub (gfc_expr *time)
{
+ if (scalar_check (time, 0) == FAILURE)
+ return FAILURE;
- if (array_check (array, 0) == FAILURE)
+ if (type_check (time, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check(time, 0, 4) == FAILURE)
return FAILURE;
- if (dim != NULL)
+ return SUCCESS;
+}
+
+
+/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
+ count, count_rate, and count_max are all optional arguments */
+
+gfc_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 (type_check (dim, 1, BT_INTEGER) == FAILURE)
+ 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 (kind_value_check (dim, 1, gfc_default_integer_kind ()) == FAILURE)
+ if (count != NULL
+ && same_type_check (count, 0, count_max, 2) == FAILURE)
return FAILURE;
- if (dim_rank_check (dim, array, 0) == FAILURE)
+ if (count_rate != NULL
+ && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
return FAILURE;
}
}
-try
-gfc_check_sign (gfc_expr * a, gfc_expr * b)
+gfc_try
+gfc_check_irand (gfc_expr *x)
{
+ if (x == NULL)
+ return SUCCESS;
- if (int_or_real_check (a, 0) == FAILURE)
+ if (scalar_check (x, 0) == FAILURE)
return FAILURE;
- if (same_type_check (a, 0, b, 1) == 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_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
+gfc_try
+gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
{
+ if (scalar_check (seconds, 0) == FAILURE)
+ return FAILURE;
- if (source->rank >= GFC_MAX_DIMENSIONS)
+ if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
- must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
+ 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 (dim_check (dim, 1, 0) == FAILURE)
+ if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
- if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
+ if (status == NULL)
+ return SUCCESS;
+
+ if (scalar_check (status, 2) == FAILURE)
return FAILURE;
- if (scalar_check (ncopies, 2) == FAILURE)
+
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_try
+gfc_check_rand (gfc_expr *x)
{
+ if (x == NULL)
+ return SUCCESS;
- if (array_check (array, 0) == FAILURE)
+ 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;
+}
+
+
+gfc_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 (numeric_check (array, 0) == FAILURE)
+ if (kind_value_check(x, 0, 4) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ return SUCCESS;
+}
+
+
+gfc_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 (mask != NULL && logical_array_check (mask, 2) == FAILURE)
+ if (type_check (result, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
- gfc_expr * mold ATTRIBUTE_UNUSED,
- gfc_expr * size)
+gfc_try
+gfc_check_dtime_etime (gfc_expr *x)
{
+ if (array_check (x, 0) == FAILURE)
+ return FAILURE;
- if (size != NULL)
- {
- if (type_check (size, 2, BT_INTEGER) == FAILURE)
- return FAILURE;
+ if (rank_check (x, 0, 1) == FAILURE)
+ return FAILURE;
- if (scalar_check (size, 2) == FAILURE)
- return FAILURE;
+ if (variable_check (x, 0) == FAILURE)
+ return FAILURE;
- if (nonoptional_check (size, 2) == 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_transpose (gfc_expr * matrix)
+gfc_try
+gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
{
+ if (array_check (values, 0) == FAILURE)
+ return FAILURE;
- if (rank_check (matrix, 0, 2) == FAILURE)
+ if (rank_check (values, 0, 1) == FAILURE)
+ return FAILURE;
+
+ if (variable_check (values, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (values, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check(values, 0, 4) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (time, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (time, 1, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check(time, 1, 4) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
+gfc_try
+gfc_check_fdate_sub (gfc_expr *date)
{
+ if (type_check (date, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
- if (array_check (array, 0) == FAILURE)
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_gerror (gfc_expr *msg)
+{
+ if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
+ return SUCCESS;
+}
- if (dim_rank_check (dim, array, 0) == FAILURE)
- return FAILURE;
+
+gfc_try
+gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
+{
+ if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (cwd, 0, gfc_default_character_kind) == 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;
+}
+
+
+gfc_try
+gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
+{
+ if (type_check (pos, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (pos->ts.kind > gfc_default_integer_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+ "not wider than the default kind (%d)",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &pos->where, gfc_default_integer_kind);
+ return FAILURE;
}
+
+ if (type_check (value, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_getlog (gfc_expr *msg)
+{
+ if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
-try
-gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
+gfc_try
+gfc_check_exit (gfc_expr *status)
{
+ if (status == NULL)
+ return SUCCESS;
- 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)
+ if (type_check (status, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (vector, 0, field, 2) == FAILURE)
+ if (scalar_check (status, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
+gfc_try
+gfc_check_flush (gfc_expr *unit)
{
+ if (unit == NULL)
+ return SUCCESS;
- if (type_check (x, 0, BT_CHARACTER) == FAILURE)
- return FAILURE;
-
- if (same_type_check (x, 0, y, 1) == FAILURE)
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
+ if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_trim (gfc_expr * x)
+gfc_try
+gfc_check_free (gfc_expr *i)
{
- if (type_check (x, 0, BT_CHARACTER) == FAILURE)
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (scalar_check (x, 0) == FAILURE)
+ if (scalar_check (i, 0) == FAILURE)
return FAILURE;
- return SUCCESS;
+ 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_try
+gfc_check_hostnm (gfc_expr *name)
{
-
- if (type_check (x, 0, BT_REAL) == FAILURE)
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/************* Check functions for intrinsic subroutines *************/
-
-try
-gfc_check_cpu_time (gfc_expr * time)
+gfc_try
+gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
{
-
- if (scalar_check (time, 0) == FAILURE)
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == 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_try
+gfc_check_itime_idate (gfc_expr *values)
{
+ if (array_check (values, 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 (rank_check (values, 0, 1) == 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 (variable_check (values, 0) == 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 (type_check (values, 0, BT_INTEGER) == 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;
- }
+ if (kind_value_check(values, 0, gfc_default_integer_kind) == 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_try
+gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
{
+ if (type_check (time, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (type_check (from, 0, BT_INTEGER) == FAILURE)
+ if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
return FAILURE;
- if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
+ if (scalar_check (time, 0) == FAILURE)
return FAILURE;
- if (type_check (len, 2, BT_INTEGER) == FAILURE)
+ if (array_check (values, 1) == FAILURE)
return FAILURE;
- if (same_type_check (from, 0, to, 3) == FAILURE)
+ if (rank_check (values, 1, 1) == FAILURE)
return FAILURE;
- if (variable_check (to, 3) == FAILURE)
+ if (variable_check (values, 1) == FAILURE)
return FAILURE;
- if (type_check (topos, 4, BT_INTEGER) == FAILURE)
+ if (type_check (values, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_random_number (gfc_expr * harvest)
+gfc_try
+gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
{
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
- if (type_check (harvest, 0, BT_REAL) == FAILURE)
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (harvest, 0) == FAILURE)
+ if (type_check (name, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
+gfc_try
+gfc_check_isatty (gfc_expr *unit)
{
+ if (unit == NULL)
+ return FAILURE;
- 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 (type_check (unit, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (rank_check (get, 2, 1) == FAILURE)
- return FAILURE;
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
- if (type_check (get, 2, BT_INTEGER) == FAILURE)
- return FAILURE;
+ return SUCCESS;
+}
- if (variable_check (get, 2) == FAILURE)
- return FAILURE;
- if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE)
- return FAILURE;
- }
+gfc_try
+gfc_check_isnan (gfc_expr *x)
+{
+ if (type_check (x, 0, BT_REAL) == 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)
+gfc_try
+gfc_check_perror (gfc_expr *string)
+{
+ if (type_check (string, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
-
- if (kind_value_check(time, 0, 4) == FAILURE)
+ if (kind_value_check (string, 0, gfc_default_character_kind) == 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)
+gfc_try
+gfc_check_umask (gfc_expr *mask)
{
+ if (type_check (mask, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- 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 (scalar_check (mask, 0) == FAILURE)
+ return FAILURE;
- }
+ return SUCCESS;
+}
- if (count_max != NULL)
- {
- if (scalar_check (count_max, 2) == FAILURE)
- return FAILURE;
- if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
- return FAILURE;
+gfc_try
+gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
+{
+ if (type_check (mask, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (variable_check (count_max, 2) == FAILURE)
- return FAILURE;
+ if (scalar_check (mask, 0) == FAILURE)
+ return FAILURE;
- if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
- return FAILURE;
+ if (old == NULL)
+ return SUCCESS;
- if (count_rate != NULL
- && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
- return FAILURE;
+ if (scalar_check (old, 1) == FAILURE)
+ return FAILURE;
- }
+ if (type_check (old, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
- return SUCCESS;
+ return SUCCESS;
}
-try
-gfc_check_irand (gfc_expr * x)
-{
- if (scalar_check (x, 0) == FAILURE)
- return FAILURE;
- if (type_check (x, 0, BT_INTEGER) == FAILURE)
+gfc_try
+gfc_check_unlink (gfc_expr *name)
+{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
-
- if (kind_value_check(x, 0, 4) == FAILURE)
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_rand (gfc_expr * x)
+
+gfc_try
+gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
{
- if (scalar_check (x, 0) == FAILURE)
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (type_check (x, 0, BT_INTEGER) == FAILURE)
+ if (status == NULL)
+ return SUCCESS;
+
+ if (scalar_check (status, 1) == FAILURE)
return FAILURE;
- if (kind_value_check(x, 0, 4) == FAILURE)
+ if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_srand (gfc_expr * x)
+
+gfc_try
+gfc_check_signal (gfc_expr *number, gfc_expr *handler)
{
- if (scalar_check (x, 0) == FAILURE)
+ if (scalar_check (number, 0) == FAILURE)
return FAILURE;
- if (type_check (x, 0, BT_INTEGER) == FAILURE)
+ if (type_check (number, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (kind_value_check(x, 0, 4) == FAILURE)
+ if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or PROCEDURE", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &handler->where);
+ return FAILURE;
+ }
+
+ if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_etime (gfc_expr * x)
+
+gfc_try
+gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
{
- if (array_check (x, 0) == FAILURE)
+ if (scalar_check (number, 0) == FAILURE)
return FAILURE;
- if (rank_check (x, 0, 1) == FAILURE)
+ if (type_check (number, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (x, 0) == 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 (type_check (x, 0, BT_REAL) == FAILURE)
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
- if (kind_value_check(x, 0, 4) == FAILURE)
+ if (scalar_check (status, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
-gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
+
+gfc_try
+gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
{
- if (array_check (values, 0) == FAILURE)
+ if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
-
- if (rank_check (values, 0, 1) == FAILURE)
+ if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
- if (variable_check (values, 0) == FAILURE)
+ if (scalar_check (status, 1) == FAILURE)
return FAILURE;
- if (type_check (values, 0, BT_REAL) == FAILURE)
+ if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (kind_value_check(values, 0, 4) == FAILURE)
+ if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
- if (scalar_check (time, 1) == FAILURE)
- return FAILURE;
+ return SUCCESS;
+}
- if (type_check (time, 1, BT_REAL) == FAILURE)
+
+/* This is used for the GNU intrinsics AND, OR and XOR. */
+gfc_try
+gfc_check_and (gfc_expr *i, gfc_expr *j)
+{
+ if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or LOGICAL", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &i->where);
+ return FAILURE;
+ }
+
+ if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or LOGICAL", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &j->where);
+ return FAILURE;
+ }
+
+ if (i->ts.type != j->ts.type)
+ {
+ gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+ "have the same type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &j->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (i, 0) == FAILURE)
return FAILURE;
- if (kind_value_check(time, 1, 4) == FAILURE)
+ if (scalar_check (j, 1) == FAILURE)
return FAILURE;
return SUCCESS;