2004-05-13 08:41:07 +02:00
|
|
|
/* Check functions
|
Make-lang.in, [...]: Update copyright years and boilerplate.
* Make-lang.in, arith.c, arith.h, array.c, bbt.c, check.c,
decl.c, dependency.c, dependency.h, dump-parse-tree.c, error.c,
expr.c, f95-lang.c, gfortran.h, interface.c, intrinsic.c,
intrinsic.h, io.c, iresolve.c, lang-specs.h, match.c, match.h,
matchexp.c, misc.c, module.c, options.c, parse.c, parse.h,
primary.c, resolve.c, scanner.c, simplify.c, st.c, symbol.c,
trans-array.c, trans-array.h, trans-common.c, trans-const.c,
trans-const.h, trans-decl.c, trans-expr.c, trans-intrinsic.c,
trans-io.c, trans-stmt.c, trans-stmt.h, trans-types.c,
trans-types.h, trans.c, trans.h: Update copyright years and
boilerplate.
* data.c: Likewise, also removed two whitespace-only lines.
* gfortranspec.c, lang.opt: Update copyright years.
From-SVN: r81839
2004-05-14 15:00:04 +02:00
|
|
|
Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
|
2004-05-13 08:41:07 +02:00
|
|
|
Contributed by Andy Vaught & Katherine Holcomb
|
|
|
|
|
Make-lang.in, [...]: Update copyright years and boilerplate.
* Make-lang.in, arith.c, arith.h, array.c, bbt.c, check.c,
decl.c, dependency.c, dependency.h, dump-parse-tree.c, error.c,
expr.c, f95-lang.c, gfortran.h, interface.c, intrinsic.c,
intrinsic.h, io.c, iresolve.c, lang-specs.h, match.c, match.h,
matchexp.c, misc.c, module.c, options.c, parse.c, parse.h,
primary.c, resolve.c, scanner.c, simplify.c, st.c, symbol.c,
trans-array.c, trans-array.h, trans-common.c, trans-const.c,
trans-const.h, trans-decl.c, trans-expr.c, trans-intrinsic.c,
trans-io.c, trans-stmt.c, trans-stmt.h, trans-types.c,
trans-types.h, trans.c, trans.h: Update copyright years and
boilerplate.
* data.c: Likewise, also removed two whitespace-only lines.
* gfortranspec.c, lang.opt: Update copyright years.
From-SVN: r81839
2004-05-14 15:00:04 +02:00
|
|
|
This file is part of GCC.
|
2004-05-13 08:41:07 +02:00
|
|
|
|
Make-lang.in, [...]: Update copyright years and boilerplate.
* Make-lang.in, arith.c, arith.h, array.c, bbt.c, check.c,
decl.c, dependency.c, dependency.h, dump-parse-tree.c, error.c,
expr.c, f95-lang.c, gfortran.h, interface.c, intrinsic.c,
intrinsic.h, io.c, iresolve.c, lang-specs.h, match.c, match.h,
matchexp.c, misc.c, module.c, options.c, parse.c, parse.h,
primary.c, resolve.c, scanner.c, simplify.c, st.c, symbol.c,
trans-array.c, trans-array.h, trans-common.c, trans-const.c,
trans-const.h, trans-decl.c, trans-expr.c, trans-intrinsic.c,
trans-io.c, trans-stmt.c, trans-stmt.h, trans-types.c,
trans-types.h, trans.c, trans.h: Update copyright years and
boilerplate.
* data.c: Likewise, also removed two whitespace-only lines.
* gfortranspec.c, lang.opt: Update copyright years.
From-SVN: r81839
2004-05-14 15:00:04 +02:00
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
|
|
|
the terms of the GNU General Public License as published by the Free
|
|
|
|
Software Foundation; either version 2, or (at your option) any later
|
|
|
|
version.
|
2004-05-13 08:41:07 +02:00
|
|
|
|
Make-lang.in, [...]: Update copyright years and boilerplate.
* Make-lang.in, arith.c, arith.h, array.c, bbt.c, check.c,
decl.c, dependency.c, dependency.h, dump-parse-tree.c, error.c,
expr.c, f95-lang.c, gfortran.h, interface.c, intrinsic.c,
intrinsic.h, io.c, iresolve.c, lang-specs.h, match.c, match.h,
matchexp.c, misc.c, module.c, options.c, parse.c, parse.h,
primary.c, resolve.c, scanner.c, simplify.c, st.c, symbol.c,
trans-array.c, trans-array.h, trans-common.c, trans-const.c,
trans-const.h, trans-decl.c, trans-expr.c, trans-intrinsic.c,
trans-io.c, trans-stmt.c, trans-stmt.h, trans-types.c,
trans-types.h, trans.c, trans.h: Update copyright years and
boilerplate.
* data.c: Likewise, also removed two whitespace-only lines.
* gfortranspec.c, lang.opt: Update copyright years.
From-SVN: r81839
2004-05-14 15:00:04 +02:00
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
|
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
|
for more details.
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License
|
Make-lang.in, [...]: Update copyright years and boilerplate.
* Make-lang.in, arith.c, arith.h, array.c, bbt.c, check.c,
decl.c, dependency.c, dependency.h, dump-parse-tree.c, error.c,
expr.c, f95-lang.c, gfortran.h, interface.c, intrinsic.c,
intrinsic.h, io.c, iresolve.c, lang-specs.h, match.c, match.h,
matchexp.c, misc.c, module.c, options.c, parse.c, parse.h,
primary.c, resolve.c, scanner.c, simplify.c, st.c, symbol.c,
trans-array.c, trans-array.h, trans-common.c, trans-const.c,
trans-const.h, trans-decl.c, trans-expr.c, trans-intrinsic.c,
trans-io.c, trans-stmt.c, trans-stmt.h, trans-types.c,
trans-types.h, trans.c, trans.h: Update copyright years and
boilerplate.
* data.c: Likewise, also removed two whitespace-only lines.
* gfortranspec.c, lang.opt: Update copyright years.
From-SVN: r81839
2004-05-14 15:00:04 +02:00
|
|
|
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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
|
|
|
|
/* These functions check to see if an argument list is compatible with
|
|
|
|
a particular intrinsic function or subroutine. Presence of
|
|
|
|
required arguments has already been established, the argument list
|
|
|
|
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"
|
|
|
|
|
|
|
|
|
|
|
|
/* The fundamental complaint function of this source file. This
|
|
|
|
function can be called in all kinds of ways. */
|
|
|
|
|
|
|
|
static void
|
|
|
|
must_be (gfc_expr * e, int n, const char *thing)
|
|
|
|
{
|
|
|
|
|
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
|
|
|
|
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
|
|
|
|
thing);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Check the type of an expression. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
type_check (gfc_expr * e, int n, bt type)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (e->ts.type == type)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
must_be (e, n, gfc_basic_typename (type));
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Check that the expression is a numeric type. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
numeric_check (gfc_expr * e, int n)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (gfc_numeric_ts (&e->ts))
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
must_be (e, n, "a numeric type");
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Check that an expression is integer or real. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
int_or_real_check (gfc_expr * e, int n)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
|
|
|
|
{
|
|
|
|
must_be (e, n, "INTEGER or REAL");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* 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)
|
|
|
|
{
|
|
|
|
int kind;
|
|
|
|
|
|
|
|
if (k == NULL)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
if (type_check (k, n, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (k->expr_type != EXPR_CONSTANT)
|
|
|
|
{
|
|
|
|
must_be (k, n, "a constant");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (gfc_extract_int (k, &kind) != NULL
|
|
|
|
|| gfc_validate_kind (type, kind) == -1)
|
|
|
|
{
|
|
|
|
gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
|
|
|
|
&k->where);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Make sure the expression is a double precision real. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
double_check (gfc_expr * d, int n)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (d, n, BT_REAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (d->ts.kind != gfc_default_double_kind ())
|
|
|
|
{
|
|
|
|
must_be (d, n, "double precision");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Make sure the expression is a logical array. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
logical_array_check (gfc_expr * array, int n)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array->ts.type != BT_LOGICAL || array->rank == 0)
|
|
|
|
{
|
|
|
|
must_be (array, n, "a logical array");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Make sure an expression is an array. */
|
|
|
|
|
|
|
|
static 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");
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Make sure two expression have the same type. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
|
|
|
|
{
|
|
|
|
char message[100];
|
|
|
|
|
|
|
|
if (gfc_compare_types (&e->ts, &f->ts))
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
sprintf (message, "the same type and kind as '%s'",
|
|
|
|
gfc_current_intrinsic_arg[n]);
|
|
|
|
|
|
|
|
must_be (f, m, message);
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Make sure that an expression has a certain (nonzero) rank. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
rank_check (gfc_expr * e, int n, int rank)
|
|
|
|
{
|
|
|
|
char message[100];
|
|
|
|
|
|
|
|
if (e->rank == rank)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
sprintf (message, "of rank %d", rank);
|
|
|
|
|
|
|
|
must_be (e, n, message);
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Make sure a variable expression is not an optional dummy argument. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
nonoptional_check (gfc_expr * e, int n)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
|
|
|
|
{
|
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
|
|
|
|
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
|
|
|
|
&e->where);
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
/* TODO: Recursive check on nonoptional variables? */
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Check that an expression has a particular kind. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
kind_value_check (gfc_expr * e, int n, int k)
|
|
|
|
{
|
|
|
|
char message[100];
|
|
|
|
|
|
|
|
if (e->ts.kind == k)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
sprintf (message, "of kind %d", k);
|
|
|
|
|
|
|
|
must_be (e, n, message);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Make sure an expression is a variable. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
variable_check (gfc_expr * e, int n)
|
|
|
|
{
|
|
|
|
|
|
|
|
if ((e->expr_type == EXPR_VARIABLE
|
|
|
|
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER)
|
|
|
|
|| (e->expr_type == EXPR_FUNCTION
|
|
|
|
&& e->symtree->n.sym->result == e->symtree->n.sym))
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
if (e->expr_type == EXPR_VARIABLE
|
|
|
|
&& e->symtree->n.sym->attr.intent == INTENT_IN)
|
|
|
|
{
|
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
|
|
|
|
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
|
|
|
|
&e->where);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
must_be (e, n, "a variable");
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Check the common DIM parameter for correctness. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
dim_check (gfc_expr * dim, int n, int optional)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (optional)
|
|
|
|
{
|
|
|
|
if (dim == NULL)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
if (nonoptional_check (dim, n) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (dim == NULL)
|
|
|
|
{
|
|
|
|
gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
|
|
|
|
gfc_current_intrinsic, gfc_current_intrinsic_where);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (type_check (dim, n, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (scalar_check (dim, n) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* If a DIM parameter is a constant, make sure that it is greater than
|
|
|
|
zero and less than or equal to the rank of the given array. If
|
|
|
|
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)
|
|
|
|
{
|
|
|
|
gfc_array_ref *ar;
|
|
|
|
int rank;
|
|
|
|
|
|
|
|
if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
ar = gfc_find_array_ref (array);
|
|
|
|
rank = array->rank;
|
|
|
|
if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
|
|
|
|
rank--;
|
|
|
|
|
|
|
|
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|
|
|
|
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
|
|
|
|
{
|
|
|
|
gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
|
|
|
|
"dimension index", gfc_current_intrinsic, &dim->where);
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/***** 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)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (a, 0, BT_REAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (kind_check (kind, 1, type) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Check subroutine suitable for ceiling, floor and nint. */
|
|
|
|
|
|
|
|
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)
|
|
|
|
{
|
|
|
|
|
|
|
|
return check_a_kind (a, kind, BT_REAL);
|
|
|
|
}
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_abs (gfc_expr * a)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (numeric_check (a, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (logical_array_check (mask, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_allocated (gfc_expr * array)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (variable_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (!array->symtree->n.sym->attr.allocatable)
|
|
|
|
{
|
|
|
|
must_be (array, 0, "ALLOCATABLE");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* 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)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (int_or_real_check (a, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (a, 0, p, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
|
|
|
|
{
|
|
|
|
symbol_attribute attr;
|
|
|
|
int i;
|
|
|
|
try t;
|
|
|
|
|
|
|
|
if (variable_check (pointer, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
attr = gfc_variable_attr (pointer, NULL);
|
|
|
|
if (!attr.pointer)
|
|
|
|
{
|
|
|
|
must_be (pointer, 0, "a POINTER");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (target == NULL)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
/* Target argument is optional. */
|
|
|
|
if (target->expr_type == EXPR_NULL)
|
|
|
|
{
|
|
|
|
gfc_error ("NULL pointer at %L is not permitted as actual argument "
|
|
|
|
"of '%s' intrinsic function",
|
|
|
|
&target->where, gfc_current_intrinsic);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
attr = gfc_variable_attr (target, NULL);
|
|
|
|
if (!attr.pointer && !attr.target)
|
|
|
|
{
|
|
|
|
must_be (target, 1, "a POINTER or a TARGET");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
t = SUCCESS;
|
|
|
|
if (same_type_check (pointer, 0, target, 1) == FAILURE)
|
|
|
|
t = FAILURE;
|
|
|
|
if (rank_check (target, 0, pointer->rank) == FAILURE)
|
|
|
|
t = 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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return t;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (numeric_check (x, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (y != NULL)
|
|
|
|
{
|
|
|
|
if (numeric_check (y, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
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)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_count (gfc_expr * mask, gfc_expr * dim)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (logical_array_check (mask, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (array->rank == 1)
|
|
|
|
{
|
|
|
|
if (scalar_check (shift, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
/* TODO: more requirements on shift parameter. */
|
|
|
|
}
|
|
|
|
|
|
|
|
if (dim_check (dim, 2, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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)
|
|
|
|
{
|
|
|
|
must_be (y, 1, "not be present if 'x' is COMPLEX");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_dble (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (numeric_check (x, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_digits (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (int_or_real_check (x, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (rank_check (vector_a, 0, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (rank_check (vector_b, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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 (scalar_check (shift, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
/* TODO: more weird restrictions on shift. */
|
|
|
|
}
|
|
|
|
|
|
|
|
if (boundary != NULL)
|
|
|
|
{
|
|
|
|
if (same_type_check (array, 0, boundary, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
/* TODO: more restrictions on boundary. */
|
|
|
|
}
|
|
|
|
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_huge (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (int_or_real_check (x, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Check that the single argument is an integer. */
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_i (gfc_expr * i)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_iand (gfc_expr * i, gfc_expr * j)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|
|
|
|| type_check (j, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (i, 0, j, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
|
|
|
|
{
|
|
|
|
|
|
|
|
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)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|
|
|
|| type_check (pos, 1, BT_INTEGER) == FAILURE
|
|
|
|
|| kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE
|
|
|
|
|| type_check (len, 2, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|
|
|
|| type_check (pos, 1, BT_INTEGER) == FAILURE
|
|
|
|
|| kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_idnint (gfc_expr * a)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (double_check (a, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ieor (gfc_expr * i, gfc_expr * j)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|
|
|
|| type_check (j, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (i, 0, j, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|
|
|
|
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
|
|
|
|
if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (string->ts.kind != substring->ts.kind)
|
|
|
|
{
|
|
|
|
must_be (substring, 1, "the same kind as 'string'");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_int (gfc_expr * x, gfc_expr * kind)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (numeric_check (x, 0) == FAILURE
|
|
|
|
|| kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ior (gfc_expr * i, gfc_expr * j)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|
|
|
|| type_check (j, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (i, 0, j, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|
|
|
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|
|
|
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_kind (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (x->ts.type == BT_DERIVED)
|
|
|
|
{
|
|
|
|
must_be (x, 0, "a non-derived type");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim != NULL)
|
|
|
|
{
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim_rank_check (dim, array, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_logical (gfc_expr * a, gfc_expr * kind)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (a, 0, BT_LOGICAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Min/max family. */
|
|
|
|
|
|
|
|
static try
|
|
|
|
min_max_args (gfc_actual_arglist * arg)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (arg == NULL || arg->next == NULL)
|
|
|
|
{
|
|
|
|
gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
|
|
|
|
gfc_current_intrinsic, gfc_current_intrinsic_where);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
static try
|
|
|
|
check_rest (bt type, int kind, gfc_actual_arglist * arg)
|
|
|
|
{
|
|
|
|
gfc_expr *x;
|
|
|
|
int n;
|
|
|
|
|
|
|
|
if (min_max_args (arg) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
n = 1;
|
|
|
|
|
|
|
|
for (; arg; arg = arg->next, n++)
|
|
|
|
{
|
|
|
|
x = arg->expr;
|
|
|
|
if (x->ts.type != type || x->ts.kind != kind)
|
|
|
|
{
|
|
|
|
if (x->ts.type == type)
|
|
|
|
{
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_min_max (gfc_actual_arglist * arg)
|
|
|
|
{
|
|
|
|
gfc_expr *x;
|
|
|
|
|
|
|
|
if (min_max_args (arg) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
x = arg->expr;
|
|
|
|
|
|
|
|
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
|
|
|
|
{
|
|
|
|
gfc_error
|
|
|
|
("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
|
|
|
|
gfc_current_intrinsic, &x->where);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return check_rest (x->ts.type, x->ts.kind, arg);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_min_max_integer (gfc_actual_arglist * arg)
|
|
|
|
{
|
|
|
|
|
|
|
|
return check_rest (BT_INTEGER, gfc_default_integer_kind (), arg);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_min_max_real (gfc_actual_arglist * arg)
|
|
|
|
{
|
|
|
|
|
|
|
|
return check_rest (BT_REAL, gfc_default_real_kind (), arg);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_min_max_double (gfc_actual_arglist * arg)
|
|
|
|
{
|
|
|
|
|
|
|
|
return check_rest (BT_REAL, gfc_default_double_kind (), arg);
|
|
|
|
}
|
|
|
|
|
|
|
|
/* End of min/max family. */
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
|
|
|
|
{
|
|
|
|
|
|
|
|
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
|
|
|
|
{
|
|
|
|
must_be (matrix_a, 0, "numeric or LOGICAL");
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
|
|
|
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
|
|
|
|
*/
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (int_or_real_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (a3 != NULL)
|
|
|
|
{
|
|
|
|
if (logical_array_check (a3, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (a2 != NULL)
|
|
|
|
{
|
|
|
|
if (scalar_check (a2, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (type_check (a2, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
if (a2 != NULL)
|
|
|
|
{
|
|
|
|
switch (a2->ts.type)
|
|
|
|
{
|
|
|
|
case BT_INTEGER:
|
|
|
|
if (scalar_check (a2, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
break;
|
|
|
|
|
|
|
|
case BT_LOGICAL: /* The '2' makes the error message correct */
|
|
|
|
if (logical_array_check (a2, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
break;
|
|
|
|
|
|
|
|
default:
|
|
|
|
type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (int_or_real_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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)
|
|
|
|
{
|
|
|
|
must_be (mold, 0, "a POINTER");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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 (mask->rank != 0 && mask->rank != array->rank)
|
|
|
|
{
|
|
|
|
must_be (array, 0, "conformable with 'mask' argument");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (vector != NULL)
|
|
|
|
{
|
|
|
|
if (same_type_check (array, 0, vector, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (rank_check (vector, 2, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
/* TODO: More constraints here. */
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_precision (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
|
|
|
|
{
|
|
|
|
must_be (x, 0, "of type REAL or COMPLEX");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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)
|
|
|
|
{
|
|
|
|
must_be (a, 0, "a dummy variable");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (!sym->attr.optional)
|
|
|
|
{
|
|
|
|
must_be (a, 0, "an OPTIONAL dummy variable");
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (numeric_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_radix (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (int_or_real_check (x, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_range (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (numeric_check (x, 0) == 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;
|
|
|
|
|
|
|
|
if (kind_check (kind, 1, BT_REAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_repeat (gfc_expr * x, gfc_expr * y)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (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;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
|
|
|
|
gfc_expr * pad, gfc_expr * order)
|
|
|
|
{
|
|
|
|
mpz_t size;
|
|
|
|
int m;
|
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
|
|
|
m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
|
|
|
|
mpz_clear (size);
|
|
|
|
|
|
|
|
if (m > 0)
|
|
|
|
{
|
|
|
|
gfc_error
|
|
|
|
("'shape' argument of 'reshape' intrinsic at %L has more than "
|
|
|
|
stringize (GFC_MAX_DIMENSIONS) " elements", &shape->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;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (y, 1, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (p == NULL && r == NULL)
|
|
|
|
{
|
|
|
|
gfc_error ("Missing arguments to %s intrinsic at %L",
|
|
|
|
gfc_current_intrinsic, gfc_current_intrinsic_where);
|
|
|
|
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (i, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_shape (gfc_expr * source)
|
|
|
|
{
|
|
|
|
gfc_array_ref *ar;
|
|
|
|
|
|
|
|
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
|
|
|
|
return SUCCESS;
|
|
|
|
|
|
|
|
ar = gfc_find_array_ref (source);
|
|
|
|
|
|
|
|
if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
|
|
|
|
{
|
|
|
|
gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
|
|
|
|
"an assumed size array", &source->where);
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_size (gfc_expr * array, gfc_expr * dim)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim != NULL)
|
|
|
|
{
|
|
|
|
if (type_check (dim, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (kind_value_check (dim, 1, gfc_default_integer_kind ()) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim_rank_check (dim, array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_sign (gfc_expr * a, gfc_expr * b)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (int_or_real_check (a, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (a, 0, b, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (source->rank >= GFC_MAX_DIMENSIONS)
|
|
|
|
{
|
|
|
|
must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (dim_check (dim, 1, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (scalar_check (ncopies, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (numeric_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
|
|
|
|
gfc_expr * mold ATTRIBUTE_UNUSED,
|
|
|
|
gfc_expr * size)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (size != NULL)
|
|
|
|
{
|
|
|
|
if (type_check (size, 2, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (scalar_check (size, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (nonoptional_check (size, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_transpose (gfc_expr * matrix)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (rank_check (matrix, 0, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (array_check (array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim != NULL)
|
|
|
|
{
|
|
|
|
if (dim_check (dim, 1, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (dim_rank_check (dim, array, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (rank_check (vector, 0, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (array_check (mask, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (vector, 0, field, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_trim (gfc_expr * x)
|
|
|
|
{
|
|
|
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (scalar_check (x, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Common check function for the half a dozen intrinsics that have a
|
|
|
|
single real argument. */
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_x (gfc_expr * x)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/************* Check functions for intrinsic subroutines *************/
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_cpu_time (gfc_expr * time)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (scalar_check (time, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (time, 0, BT_REAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (variable_check (time, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
|
|
|
|
gfc_expr * zone, gfc_expr * values)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (date != NULL)
|
|
|
|
{
|
|
|
|
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (scalar_check (date, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (variable_check (date, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (time != NULL)
|
|
|
|
{
|
|
|
|
if (type_check (time, 1, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (scalar_check (time, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (variable_check (time, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (zone != NULL)
|
|
|
|
{
|
|
|
|
if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (scalar_check (zone, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (variable_check (zone, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (values != NULL)
|
|
|
|
{
|
|
|
|
if (type_check (values, 3, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (array_check (values, 3) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (rank_check (values, 3, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (variable_check (values, 3) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
|
|
|
|
gfc_expr * to, gfc_expr * topos)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (from, 0, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (len, 2, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (same_type_check (from, 0, to, 3) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (variable_check (to, 3) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (topos, 4, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_random_number (gfc_expr * harvest)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (type_check (harvest, 0, BT_REAL) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (variable_check (harvest, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
try
|
|
|
|
gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
|
|
|
|
{
|
|
|
|
|
|
|
|
if (size != NULL)
|
|
|
|
{
|
|
|
|
if (scalar_check (size, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (size, 0, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (variable_check (size, 0) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (kind_value_check (size, 0, gfc_default_integer_kind ()) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (put != NULL)
|
|
|
|
{
|
|
|
|
if (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 (array_check (get, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
if (rank_check (get, 2, 1) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (type_check (get, 2, BT_INTEGER) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (variable_check (get, 2) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
|
|
|
|
if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE)
|
|
|
|
return FAILURE;
|
|
|
|
}
|
|
|
|
|
|
|
|
return SUCCESS;
|
|
|
|
}
|