/* Check functions
|
/* Check functions
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Andy Vaught & Katherine Holcomb
|
Contributed by Andy Vaught & Katherine Holcomb
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
|
/* These functions check to see if an argument list is compatible with
|
/* These functions check to see if an argument list is compatible with
|
a particular intrinsic function or subroutine. Presence of
|
a particular intrinsic function or subroutine. Presence of
|
required arguments has already been established, the argument list
|
required arguments has already been established, the argument list
|
has been sorted into the right order and has NULL arguments in the
|
has been sorted into the right order and has NULL arguments in the
|
correct places for missing optional arguments. */
|
correct places for missing optional arguments. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "flags.h"
|
#include "flags.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "intrinsic.h"
|
#include "intrinsic.h"
|
#include "constructor.h"
|
#include "constructor.h"
|
#include "target-memory.h"
|
#include "target-memory.h"
|
|
|
|
|
/* Make sure an expression is a scalar. */
|
/* Make sure an expression is a scalar. */
|
|
|
static gfc_try
|
static gfc_try
|
scalar_check (gfc_expr *e, int n)
|
scalar_check (gfc_expr *e, int n)
|
{
|
{
|
if (e->rank == 0)
|
if (e->rank == 0)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where);
|
&e->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Check the type of an expression. */
|
/* Check the type of an expression. */
|
|
|
static gfc_try
|
static gfc_try
|
type_check (gfc_expr *e, int n, bt type)
|
type_check (gfc_expr *e, int n, bt type)
|
{
|
{
|
if (e->ts.type == type)
|
if (e->ts.type == type)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where, gfc_basic_typename (type));
|
&e->where, gfc_basic_typename (type));
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Check that the expression is a numeric type. */
|
/* Check that the expression is a numeric type. */
|
|
|
static gfc_try
|
static gfc_try
|
numeric_check (gfc_expr *e, int n)
|
numeric_check (gfc_expr *e, int n)
|
{
|
{
|
if (gfc_numeric_ts (&e->ts))
|
if (gfc_numeric_ts (&e->ts))
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* If the expression has not got a type, check if its namespace can
|
/* If the expression has not got a type, check if its namespace can
|
offer a default type. */
|
offer a default type. */
|
if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
|
if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
|
&& e->symtree->n.sym->ts.type == BT_UNKNOWN
|
&& e->symtree->n.sym->ts.type == BT_UNKNOWN
|
&& gfc_set_default_type (e->symtree->n.sym, 0,
|
&& gfc_set_default_type (e->symtree->n.sym, 0,
|
e->symtree->n.sym->ns) == SUCCESS
|
e->symtree->n.sym->ns) == SUCCESS
|
&& gfc_numeric_ts (&e->symtree->n.sym->ts))
|
&& gfc_numeric_ts (&e->symtree->n.sym->ts))
|
{
|
{
|
e->ts = e->symtree->n.sym->ts;
|
e->ts = e->symtree->n.sym->ts;
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where);
|
&e->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Check that an expression is integer or real. */
|
/* Check that an expression is integer or real. */
|
|
|
static gfc_try
|
static gfc_try
|
int_or_real_check (gfc_expr *e, int n)
|
int_or_real_check (gfc_expr *e, int n)
|
{
|
{
|
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
|
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
"or REAL", gfc_current_intrinsic_arg[n]->name,
|
"or REAL", gfc_current_intrinsic_arg[n]->name,
|
gfc_current_intrinsic, &e->where);
|
gfc_current_intrinsic, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check that an expression is real or complex. */
|
/* Check that an expression is real or complex. */
|
|
|
static gfc_try
|
static gfc_try
|
real_or_complex_check (gfc_expr *e, int n)
|
real_or_complex_check (gfc_expr *e, int n)
|
{
|
{
|
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
|
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
|
"or COMPLEX", gfc_current_intrinsic_arg[n]->name,
|
"or COMPLEX", gfc_current_intrinsic_arg[n]->name,
|
gfc_current_intrinsic, &e->where);
|
gfc_current_intrinsic, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check that an expression is INTEGER or PROCEDURE. */
|
/* Check that an expression is INTEGER or PROCEDURE. */
|
|
|
static gfc_try
|
static gfc_try
|
int_or_proc_check (gfc_expr *e, int n)
|
int_or_proc_check (gfc_expr *e, int n)
|
{
|
{
|
if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
|
if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
"or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
|
"or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
|
gfc_current_intrinsic, &e->where);
|
gfc_current_intrinsic, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check that the expression is an optional constant integer
|
/* Check that the expression is an optional constant integer
|
and that it specifies a valid kind for that type. */
|
and that it specifies a valid kind for that type. */
|
|
|
static gfc_try
|
static gfc_try
|
kind_check (gfc_expr *k, int n, bt type)
|
kind_check (gfc_expr *k, int n, bt type)
|
{
|
{
|
int kind;
|
int kind;
|
|
|
if (k == NULL)
|
if (k == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (k, n, BT_INTEGER) == FAILURE)
|
if (type_check (k, n, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (k, n) == FAILURE)
|
if (scalar_check (k, n) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (k->expr_type != EXPR_CONSTANT)
|
if (k->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&k->where);
|
&k->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (gfc_extract_int (k, &kind) != NULL
|
if (gfc_extract_int (k, &kind) != NULL
|
|| gfc_validate_kind (type, kind, true) < 0)
|
|| gfc_validate_kind (type, kind, true) < 0)
|
{
|
{
|
gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
|
gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
|
&k->where);
|
&k->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Make sure the expression is a double precision real. */
|
/* Make sure the expression is a double precision real. */
|
|
|
static gfc_try
|
static gfc_try
|
double_check (gfc_expr *d, int n)
|
double_check (gfc_expr *d, int n)
|
{
|
{
|
if (type_check (d, n, BT_REAL) == FAILURE)
|
if (type_check (d, n, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (d->ts.kind != gfc_default_double_kind)
|
if (d->ts.kind != gfc_default_double_kind)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
|
"precision", gfc_current_intrinsic_arg[n]->name,
|
"precision", gfc_current_intrinsic_arg[n]->name,
|
gfc_current_intrinsic, &d->where);
|
gfc_current_intrinsic, &d->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
coarray_check (gfc_expr *e, int n)
|
coarray_check (gfc_expr *e, int n)
|
{
|
{
|
if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
|
if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
|
&& CLASS_DATA (e)->attr.codimension
|
&& CLASS_DATA (e)->attr.codimension
|
&& CLASS_DATA (e)->as->corank)
|
&& CLASS_DATA (e)->as->corank)
|
{
|
{
|
gfc_add_class_array_ref (e);
|
gfc_add_class_array_ref (e);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
if (!gfc_is_coarray (e))
|
if (!gfc_is_coarray (e))
|
{
|
{
|
gfc_error ("Expected coarray variable as '%s' argument to the %s "
|
gfc_error ("Expected coarray variable as '%s' argument to the %s "
|
"intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
|
"intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
|
gfc_current_intrinsic, &e->where);
|
gfc_current_intrinsic, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Make sure the expression is a logical array. */
|
/* Make sure the expression is a logical array. */
|
|
|
static gfc_try
|
static gfc_try
|
logical_array_check (gfc_expr *array, int n)
|
logical_array_check (gfc_expr *array, int n)
|
{
|
{
|
if (array->ts.type != BT_LOGICAL || array->rank == 0)
|
if (array->ts.type != BT_LOGICAL || array->rank == 0)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
|
"array", gfc_current_intrinsic_arg[n]->name,
|
"array", gfc_current_intrinsic_arg[n]->name,
|
gfc_current_intrinsic, &array->where);
|
gfc_current_intrinsic, &array->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Make sure an expression is an array. */
|
/* Make sure an expression is an array. */
|
|
|
static gfc_try
|
static gfc_try
|
array_check (gfc_expr *e, int n)
|
array_check (gfc_expr *e, int n)
|
{
|
{
|
if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
|
if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
|
&& CLASS_DATA (e)->attr.dimension
|
&& CLASS_DATA (e)->attr.dimension
|
&& CLASS_DATA (e)->as->rank)
|
&& CLASS_DATA (e)->as->rank)
|
{
|
{
|
gfc_add_class_array_ref (e);
|
gfc_add_class_array_ref (e);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
if (e->rank != 0)
|
if (e->rank != 0)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where);
|
&e->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* If expr is a constant, then check to ensure that it is greater than
|
/* If expr is a constant, then check to ensure that it is greater than
|
of equal to zero. */
|
of equal to zero. */
|
|
|
static gfc_try
|
static gfc_try
|
nonnegative_check (const char *arg, gfc_expr *expr)
|
nonnegative_check (const char *arg, gfc_expr *expr)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (expr->expr_type == EXPR_CONSTANT)
|
if (expr->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_extract_int (expr, &i);
|
gfc_extract_int (expr, &i);
|
if (i < 0)
|
if (i < 0)
|
{
|
{
|
gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
|
gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* If expr2 is constant, then check that the value is less than
|
/* If expr2 is constant, then check that the value is less than
|
(less than or equal to, if 'or_equal' is true) bit_size(expr1). */
|
(less than or equal to, if 'or_equal' is true) bit_size(expr1). */
|
|
|
static gfc_try
|
static gfc_try
|
less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
|
less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
|
gfc_expr *expr2, bool or_equal)
|
gfc_expr *expr2, bool or_equal)
|
{
|
{
|
int i2, i3;
|
int i2, i3;
|
|
|
if (expr2->expr_type == EXPR_CONSTANT)
|
if (expr2->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_extract_int (expr2, &i2);
|
gfc_extract_int (expr2, &i2);
|
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
|
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
|
|
|
/* For ISHFT[C], check that |shift| <= bit_size(i). */
|
/* For ISHFT[C], check that |shift| <= bit_size(i). */
|
if (arg2 == NULL)
|
if (arg2 == NULL)
|
{
|
{
|
if (i2 < 0)
|
if (i2 < 0)
|
i2 = -i2;
|
i2 = -i2;
|
|
|
if (i2 > gfc_integer_kinds[i3].bit_size)
|
if (i2 > gfc_integer_kinds[i3].bit_size)
|
{
|
{
|
gfc_error ("The absolute value of SHIFT at %L must be less "
|
gfc_error ("The absolute value of SHIFT at %L must be less "
|
"than or equal to BIT_SIZE('%s')",
|
"than or equal to BIT_SIZE('%s')",
|
&expr2->where, arg1);
|
&expr2->where, arg1);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (or_equal)
|
if (or_equal)
|
{
|
{
|
if (i2 > gfc_integer_kinds[i3].bit_size)
|
if (i2 > gfc_integer_kinds[i3].bit_size)
|
{
|
{
|
gfc_error ("'%s' at %L must be less than "
|
gfc_error ("'%s' at %L must be less than "
|
"or equal to BIT_SIZE('%s')",
|
"or equal to BIT_SIZE('%s')",
|
arg2, &expr2->where, arg1);
|
arg2, &expr2->where, arg1);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
if (i2 >= gfc_integer_kinds[i3].bit_size)
|
if (i2 >= gfc_integer_kinds[i3].bit_size)
|
{
|
{
|
gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
|
gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
|
arg2, &expr2->where, arg1);
|
arg2, &expr2->where, arg1);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* If expr is constant, then check that the value is less than or equal
|
/* If expr is constant, then check that the value is less than or equal
|
to the bit_size of the kind k. */
|
to the bit_size of the kind k. */
|
|
|
static gfc_try
|
static gfc_try
|
less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
|
less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
|
{
|
{
|
int i, val;
|
int i, val;
|
|
|
if (expr->expr_type != EXPR_CONSTANT)
|
if (expr->expr_type != EXPR_CONSTANT)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
i = gfc_validate_kind (BT_INTEGER, k, false);
|
i = gfc_validate_kind (BT_INTEGER, k, false);
|
gfc_extract_int (expr, &val);
|
gfc_extract_int (expr, &val);
|
|
|
if (val > gfc_integer_kinds[i].bit_size)
|
if (val > gfc_integer_kinds[i].bit_size)
|
{
|
{
|
gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
|
gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
|
"INTEGER(KIND=%d)", arg, &expr->where, k);
|
"INTEGER(KIND=%d)", arg, &expr->where, k);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* If expr2 and expr3 are constants, then check that the value is less than
|
/* If expr2 and expr3 are constants, then check that the value is less than
|
or equal to bit_size(expr1). */
|
or equal to bit_size(expr1). */
|
|
|
static gfc_try
|
static gfc_try
|
less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
|
less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
|
gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
|
gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
|
{
|
{
|
int i2, i3;
|
int i2, i3;
|
|
|
if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
|
if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_extract_int (expr2, &i2);
|
gfc_extract_int (expr2, &i2);
|
gfc_extract_int (expr3, &i3);
|
gfc_extract_int (expr3, &i3);
|
i2 += i3;
|
i2 += i3;
|
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
|
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
|
if (i2 > gfc_integer_kinds[i3].bit_size)
|
if (i2 > gfc_integer_kinds[i3].bit_size)
|
{
|
{
|
gfc_error ("'%s + %s' at %L must be less than or equal "
|
gfc_error ("'%s + %s' at %L must be less than or equal "
|
"to BIT_SIZE('%s')",
|
"to BIT_SIZE('%s')",
|
arg2, arg3, &expr2->where, arg1);
|
arg2, arg3, &expr2->where, arg1);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* Make sure two expressions have the same type. */
|
/* Make sure two expressions have the same type. */
|
|
|
static gfc_try
|
static gfc_try
|
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
|
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
|
{
|
{
|
if (gfc_compare_types (&e->ts, &f->ts))
|
if (gfc_compare_types (&e->ts, &f->ts))
|
return SUCCESS;
|
return SUCCESS;
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
|
"and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
|
"and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
|
gfc_current_intrinsic, &f->where,
|
gfc_current_intrinsic, &f->where,
|
gfc_current_intrinsic_arg[n]->name);
|
gfc_current_intrinsic_arg[n]->name);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Make sure that an expression has a certain (nonzero) rank. */
|
/* Make sure that an expression has a certain (nonzero) rank. */
|
|
|
static gfc_try
|
static gfc_try
|
rank_check (gfc_expr *e, int n, int rank)
|
rank_check (gfc_expr *e, int n, int rank)
|
{
|
{
|
if (e->rank == rank)
|
if (e->rank == rank)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where, rank);
|
&e->where, rank);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Make sure a variable expression is not an optional dummy argument. */
|
/* Make sure a variable expression is not an optional dummy argument. */
|
|
|
static gfc_try
|
static gfc_try
|
nonoptional_check (gfc_expr *e, int n)
|
nonoptional_check (gfc_expr *e, int n)
|
{
|
{
|
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
|
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_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where);
|
&e->where);
|
}
|
}
|
|
|
/* TODO: Recursive check on nonoptional variables? */
|
/* TODO: Recursive check on nonoptional variables? */
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check for ALLOCATABLE attribute. */
|
/* Check for ALLOCATABLE attribute. */
|
|
|
static gfc_try
|
static gfc_try
|
allocatable_check (gfc_expr *e, int n)
|
allocatable_check (gfc_expr *e, int n)
|
{
|
{
|
symbol_attribute attr;
|
symbol_attribute attr;
|
|
|
attr = gfc_variable_attr (e, NULL);
|
attr = gfc_variable_attr (e, NULL);
|
if (!attr.allocatable)
|
if (!attr.allocatable)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where);
|
&e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check that an expression has a particular kind. */
|
/* Check that an expression has a particular kind. */
|
|
|
static gfc_try
|
static gfc_try
|
kind_value_check (gfc_expr *e, int n, int k)
|
kind_value_check (gfc_expr *e, int n, int k)
|
{
|
{
|
if (e->ts.kind == k)
|
if (e->ts.kind == k)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
|
&e->where, k);
|
&e->where, k);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Make sure an expression is a variable. */
|
/* Make sure an expression is a variable. */
|
|
|
static gfc_try
|
static gfc_try
|
variable_check (gfc_expr *e, int n, bool allow_proc)
|
variable_check (gfc_expr *e, int n, bool allow_proc)
|
{
|
{
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree->n.sym->attr.intent == INTENT_IN
|
&& e->symtree->n.sym->attr.intent == INTENT_IN
|
&& (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
|
&& (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
|
|| gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
|
|| gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
|
{
|
{
|
gfc_ref *ref;
|
gfc_ref *ref;
|
bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
|
bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
|
&& CLASS_DATA (e->symtree->n.sym)
|
&& CLASS_DATA (e->symtree->n.sym)
|
? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
|
? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
|
: e->symtree->n.sym->attr.pointer;
|
: e->symtree->n.sym->attr.pointer;
|
|
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
{
|
{
|
if (pointer && ref->type == REF_COMPONENT)
|
if (pointer && ref->type == REF_COMPONENT)
|
break;
|
break;
|
if (ref->type == REF_COMPONENT
|
if (ref->type == REF_COMPONENT
|
&& ((ref->u.c.component->ts.type == BT_CLASS
|
&& ((ref->u.c.component->ts.type == BT_CLASS
|
&& CLASS_DATA (ref->u.c.component)->attr.class_pointer)
|
&& CLASS_DATA (ref->u.c.component)->attr.class_pointer)
|
|| (ref->u.c.component->ts.type != BT_CLASS
|
|| (ref->u.c.component->ts.type != BT_CLASS
|
&& ref->u.c.component->attr.pointer)))
|
&& ref->u.c.component->attr.pointer)))
|
break;
|
break;
|
}
|
}
|
|
|
if (!ref)
|
if (!ref)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
|
"INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
|
"INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
|
gfc_current_intrinsic, &e->where);
|
gfc_current_intrinsic, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER
|
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER
|
&& (allow_proc || !e->symtree->n.sym->attr.function))
|
&& (allow_proc || !e->symtree->n.sym->attr.function))
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
|
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
|
&& e->symtree->n.sym == e->symtree->n.sym->result)
|
&& e->symtree->n.sym == e->symtree->n.sym->result)
|
{
|
{
|
gfc_namespace *ns;
|
gfc_namespace *ns;
|
for (ns = gfc_current_ns; ns; ns = ns->parent)
|
for (ns = gfc_current_ns; ns; ns = ns->parent)
|
if (ns->proc_name == e->symtree->n.sym)
|
if (ns->proc_name == e->symtree->n.sym)
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
|
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Check the common DIM parameter for correctness. */
|
/* Check the common DIM parameter for correctness. */
|
|
|
static gfc_try
|
static gfc_try
|
dim_check (gfc_expr *dim, int n, bool optional)
|
dim_check (gfc_expr *dim, int n, bool optional)
|
{
|
{
|
if (dim == NULL)
|
if (dim == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (dim, n, BT_INTEGER) == FAILURE)
|
if (type_check (dim, n, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (dim, n) == FAILURE)
|
if (scalar_check (dim, n) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (!optional && nonoptional_check (dim, n) == FAILURE)
|
if (!optional && nonoptional_check (dim, n) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* If a coarray DIM parameter is a constant, make sure that it is greater than
|
/* If a coarray DIM parameter is a constant, make sure that it is greater than
|
zero and less than or equal to the corank of the given array. */
|
zero and less than or equal to the corank of the given array. */
|
|
|
static gfc_try
|
static gfc_try
|
dim_corank_check (gfc_expr *dim, gfc_expr *array)
|
dim_corank_check (gfc_expr *dim, gfc_expr *array)
|
{
|
{
|
int corank;
|
int corank;
|
|
|
gcc_assert (array->expr_type == EXPR_VARIABLE);
|
gcc_assert (array->expr_type == EXPR_VARIABLE);
|
|
|
if (dim->expr_type != EXPR_CONSTANT)
|
if (dim->expr_type != EXPR_CONSTANT)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (array->ts.type == BT_CLASS)
|
if (array->ts.type == BT_CLASS)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
corank = gfc_get_corank (array);
|
corank = gfc_get_corank (array);
|
|
|
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
|
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
|
{
|
{
|
gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
|
gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
|
"codimension index", gfc_current_intrinsic, &dim->where);
|
"codimension index", gfc_current_intrinsic, &dim->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* If a DIM parameter is a constant, make sure that it is greater than
|
/* 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
|
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
|
allow_assumed is zero then dim must be less than the rank of the array
|
for assumed size arrays. */
|
for assumed size arrays. */
|
|
|
static gfc_try
|
static gfc_try
|
dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
|
dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
|
{
|
{
|
gfc_array_ref *ar;
|
gfc_array_ref *ar;
|
int rank;
|
int rank;
|
|
|
if (dim == NULL)
|
if (dim == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (dim->expr_type != EXPR_CONSTANT)
|
if (dim->expr_type != EXPR_CONSTANT)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (array->ts.type == BT_CLASS)
|
if (array->ts.type == BT_CLASS)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
|
if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
|
&& array->value.function.isym->id == GFC_ISYM_SPREAD)
|
&& array->value.function.isym->id == GFC_ISYM_SPREAD)
|
rank = array->rank + 1;
|
rank = array->rank + 1;
|
else
|
else
|
rank = array->rank;
|
rank = array->rank;
|
|
|
if (array->expr_type == EXPR_VARIABLE)
|
if (array->expr_type == EXPR_VARIABLE)
|
{
|
{
|
ar = gfc_find_array_ref (array);
|
ar = gfc_find_array_ref (array);
|
if (ar->as->type == AS_ASSUMED_SIZE
|
if (ar->as->type == AS_ASSUMED_SIZE
|
&& !allow_assumed
|
&& !allow_assumed
|
&& ar->type != AR_ELEMENT
|
&& ar->type != AR_ELEMENT
|
&& ar->type != AR_SECTION)
|
&& ar->type != AR_SECTION)
|
rank--;
|
rank--;
|
}
|
}
|
|
|
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
|
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
|
{
|
{
|
gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
|
gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
|
"dimension index", gfc_current_intrinsic, &dim->where);
|
"dimension index", gfc_current_intrinsic, &dim->where);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Compare the size of a along dimension ai with the size of b along
|
/* 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,
|
dimension bi, returning 0 if they are known not to be identical,
|
and 1 if they are identical, or if this cannot be determined. */
|
and 1 if they are identical, or if this cannot be determined. */
|
|
|
static int
|
static int
|
identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
|
identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
|
{
|
{
|
mpz_t a_size, b_size;
|
mpz_t a_size, b_size;
|
int ret;
|
int ret;
|
|
|
gcc_assert (a->rank > ai);
|
gcc_assert (a->rank > ai);
|
gcc_assert (b->rank > bi);
|
gcc_assert (b->rank > bi);
|
|
|
ret = 1;
|
ret = 1;
|
|
|
if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
|
if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
|
{
|
{
|
if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
|
if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
|
{
|
{
|
if (mpz_cmp (a_size, b_size) != 0)
|
if (mpz_cmp (a_size, b_size) != 0)
|
ret = 0;
|
ret = 0;
|
|
|
mpz_clear (b_size);
|
mpz_clear (b_size);
|
}
|
}
|
mpz_clear (a_size);
|
mpz_clear (a_size);
|
}
|
}
|
return ret;
|
return ret;
|
}
|
}
|
|
|
/* Calculate the length of a character variable, including substrings.
|
/* Calculate the length of a character variable, including substrings.
|
Strip away parentheses if necessary. Return -1 if no length could
|
Strip away parentheses if necessary. Return -1 if no length could
|
be determined. */
|
be determined. */
|
|
|
static long
|
static long
|
gfc_var_strlen (const gfc_expr *a)
|
gfc_var_strlen (const gfc_expr *a)
|
{
|
{
|
gfc_ref *ra;
|
gfc_ref *ra;
|
|
|
while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
|
while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
|
a = a->value.op.op1;
|
a = a->value.op.op1;
|
|
|
for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
|
for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
|
;
|
;
|
|
|
if (ra)
|
if (ra)
|
{
|
{
|
long start_a, end_a;
|
long start_a, end_a;
|
|
|
if (ra->u.ss.start->expr_type == EXPR_CONSTANT
|
if (ra->u.ss.start->expr_type == EXPR_CONSTANT
|
&& ra->u.ss.end->expr_type == EXPR_CONSTANT)
|
&& ra->u.ss.end->expr_type == EXPR_CONSTANT)
|
{
|
{
|
start_a = mpz_get_si (ra->u.ss.start->value.integer);
|
start_a = mpz_get_si (ra->u.ss.start->value.integer);
|
end_a = mpz_get_si (ra->u.ss.end->value.integer);
|
end_a = mpz_get_si (ra->u.ss.end->value.integer);
|
return end_a - start_a + 1;
|
return end_a - start_a + 1;
|
}
|
}
|
else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
|
else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
|
return 1;
|
return 1;
|
else
|
else
|
return -1;
|
return -1;
|
}
|
}
|
|
|
if (a->ts.u.cl && a->ts.u.cl->length
|
if (a->ts.u.cl && a->ts.u.cl->length
|
&& a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
&& a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
return mpz_get_si (a->ts.u.cl->length->value.integer);
|
return mpz_get_si (a->ts.u.cl->length->value.integer);
|
else if (a->expr_type == EXPR_CONSTANT
|
else if (a->expr_type == EXPR_CONSTANT
|
&& (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
|
&& (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
|
return a->value.character.length;
|
return a->value.character.length;
|
else
|
else
|
return -1;
|
return -1;
|
|
|
}
|
}
|
|
|
/* Check whether two character expressions have the same length;
|
/* Check whether two character expressions have the same length;
|
returns SUCCESS if they have or if the length cannot be determined,
|
returns SUCCESS if they have or if the length cannot be determined,
|
otherwise return FAILURE and raise a gfc_error. */
|
otherwise return FAILURE and raise a gfc_error. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
|
gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
|
{
|
{
|
long len_a, len_b;
|
long len_a, len_b;
|
|
|
len_a = gfc_var_strlen(a);
|
len_a = gfc_var_strlen(a);
|
len_b = gfc_var_strlen(b);
|
len_b = gfc_var_strlen(b);
|
|
|
if (len_a == -1 || len_b == -1 || len_a == len_b)
|
if (len_a == -1 || len_b == -1 || len_a == len_b)
|
return SUCCESS;
|
return SUCCESS;
|
else
|
else
|
{
|
{
|
gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
|
gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
|
len_a, len_b, name, &a->where);
|
len_a, len_b, name, &a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
|
|
/***** Check functions *****/
|
/***** Check functions *****/
|
|
|
/* Check subroutine suitable for intrinsics taking a real argument and
|
/* Check subroutine suitable for intrinsics taking a real argument and
|
a kind argument for the result. */
|
a kind argument for the result. */
|
|
|
static gfc_try
|
static gfc_try
|
check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
|
check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
|
{
|
{
|
if (type_check (a, 0, BT_REAL) == FAILURE)
|
if (type_check (a, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_check (kind, 1, type) == FAILURE)
|
if (kind_check (kind, 1, type) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check subroutine suitable for ceiling, floor and nint. */
|
/* Check subroutine suitable for ceiling, floor and nint. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
|
gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
|
{
|
{
|
return check_a_kind (a, kind, BT_INTEGER);
|
return check_a_kind (a, kind, BT_INTEGER);
|
}
|
}
|
|
|
|
|
/* Check subroutine suitable for aint, anint. */
|
/* Check subroutine suitable for aint, anint. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
|
gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
|
{
|
{
|
return check_a_kind (a, kind, BT_REAL);
|
return check_a_kind (a, kind, BT_REAL);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_abs (gfc_expr *a)
|
gfc_check_abs (gfc_expr *a)
|
{
|
{
|
if (numeric_check (a, 0) == FAILURE)
|
if (numeric_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_achar (gfc_expr *a, gfc_expr *kind)
|
gfc_check_achar (gfc_expr *a, gfc_expr *kind)
|
{
|
{
|
if (type_check (a, 0, BT_INTEGER) == FAILURE)
|
if (type_check (a, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
|
if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
|
gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE
|
|| scalar_check (name, 0) == FAILURE)
|
|| scalar_check (name, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (mode, 1, BT_CHARACTER) == FAILURE
|
if (type_check (mode, 1, BT_CHARACTER) == FAILURE
|
|| scalar_check (mode, 1) == FAILURE)
|
|| scalar_check (mode, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
|
gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
|
{
|
{
|
if (logical_array_check (mask, 0) == FAILURE)
|
if (logical_array_check (mask, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, mask, 0) == FAILURE)
|
if (dim_rank_check (dim, mask, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_allocated (gfc_expr *array)
|
gfc_check_allocated (gfc_expr *array)
|
{
|
{
|
if (variable_check (array, 0, false) == FAILURE)
|
if (variable_check (array, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (allocatable_check (array, 0) == FAILURE)
|
if (allocatable_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Common check function where the first argument must be real or
|
/* Common check function where the first argument must be real or
|
integer and the second argument must be the same as the first. */
|
integer and the second argument must be the same as the first. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_a_p (gfc_expr *a, gfc_expr *p)
|
gfc_check_a_p (gfc_expr *a, gfc_expr *p)
|
{
|
{
|
if (int_or_real_check (a, 0) == FAILURE)
|
if (int_or_real_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (a->ts.type != p->ts.type)
|
if (a->ts.type != p->ts.type)
|
{
|
{
|
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
|
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
|
"have the same type", gfc_current_intrinsic_arg[0]->name,
|
"have the same type", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&p->where);
|
&p->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (a->ts.kind != p->ts.kind)
|
if (a->ts.kind != p->ts.kind)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
&p->where) == FAILURE)
|
&p->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
|
gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
|
{
|
{
|
if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
|
if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
|
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
|
{
|
{
|
symbol_attribute attr1, attr2;
|
symbol_attribute attr1, attr2;
|
int i;
|
int i;
|
gfc_try t;
|
gfc_try t;
|
locus *where;
|
locus *where;
|
|
|
where = &pointer->where;
|
where = &pointer->where;
|
|
|
if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
|
if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
|
attr1 = gfc_expr_attr (pointer);
|
attr1 = gfc_expr_attr (pointer);
|
else if (pointer->expr_type == EXPR_NULL)
|
else if (pointer->expr_type == EXPR_NULL)
|
goto null_arg;
|
goto null_arg;
|
else
|
else
|
gcc_assert (0); /* Pointer must be a variable or a function. */
|
gcc_assert (0); /* Pointer must be a variable or a function. */
|
|
|
if (!attr1.pointer && !attr1.proc_pointer)
|
if (!attr1.pointer && !attr1.proc_pointer)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&pointer->where);
|
&pointer->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* F2008, C1242. */
|
/* F2008, C1242. */
|
if (attr1.pointer && gfc_is_coindexed (pointer))
|
if (attr1.pointer && gfc_is_coindexed (pointer))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
|
"coindexed", gfc_current_intrinsic_arg[0]->name,
|
"coindexed", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &pointer->where);
|
gfc_current_intrinsic, &pointer->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Target argument is optional. */
|
/* Target argument is optional. */
|
if (target == NULL)
|
if (target == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
where = &target->where;
|
where = &target->where;
|
if (target->expr_type == EXPR_NULL)
|
if (target->expr_type == EXPR_NULL)
|
goto null_arg;
|
goto null_arg;
|
|
|
if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
|
if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
|
attr2 = gfc_expr_attr (target);
|
attr2 = gfc_expr_attr (target);
|
else
|
else
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
|
"or target VARIABLE or FUNCTION",
|
"or target VARIABLE or FUNCTION",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&target->where);
|
&target->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (attr1.pointer && !attr2.pointer && !attr2.target)
|
if (attr1.pointer && !attr2.pointer && !attr2.target)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
|
"or a TARGET", gfc_current_intrinsic_arg[1]->name,
|
"or a TARGET", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &target->where);
|
gfc_current_intrinsic, &target->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* F2008, C1242. */
|
/* F2008, C1242. */
|
if (attr1.pointer && gfc_is_coindexed (target))
|
if (attr1.pointer && gfc_is_coindexed (target))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
|
"coindexed", gfc_current_intrinsic_arg[1]->name,
|
"coindexed", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &target->where);
|
gfc_current_intrinsic, &target->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
if (same_type_check (pointer, 0, target, 1) == FAILURE)
|
if (same_type_check (pointer, 0, target, 1) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
if (rank_check (target, 0, pointer->rank) == FAILURE)
|
if (rank_check (target, 0, pointer->rank) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
if (target->rank > 0)
|
if (target->rank > 0)
|
{
|
{
|
for (i = 0; i < target->rank; i++)
|
for (i = 0; i < target->rank; i++)
|
if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
|
if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
|
{
|
{
|
gfc_error ("Array section with a vector subscript at %L shall not "
|
gfc_error ("Array section with a vector subscript at %L shall not "
|
"be the target of a pointer",
|
"be the target of a pointer",
|
&target->where);
|
&target->where);
|
t = FAILURE;
|
t = FAILURE;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
return t;
|
return t;
|
|
|
null_arg:
|
null_arg:
|
|
|
gfc_error ("NULL pointer at %L is not permitted as actual argument "
|
gfc_error ("NULL pointer at %L is not permitted as actual argument "
|
"of '%s' intrinsic function", where, gfc_current_intrinsic);
|
"of '%s' intrinsic function", where, gfc_current_intrinsic);
|
return FAILURE;
|
return FAILURE;
|
|
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
|
gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
|
{
|
{
|
/* gfc_notify_std would be a waste of time as the return value
|
/* gfc_notify_std would be a waste of time as the return value
|
is seemingly used only for the generic resolution. The error
|
is seemingly used only for the generic resolution. The error
|
will be: Too many arguments. */
|
will be: Too many arguments. */
|
if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
|
if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
|
return FAILURE;
|
return FAILURE;
|
|
|
return gfc_check_atan2 (y, x);
|
return gfc_check_atan2 (y, x);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
|
gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
|
{
|
{
|
if (type_check (y, 0, BT_REAL) == FAILURE)
|
if (type_check (y, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (same_type_check (y, 0, x, 1) == FAILURE)
|
if (same_type_check (y, 0, x, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
|
gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
|
{
|
{
|
if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
|
if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
|
&& !(atom->ts.type == BT_LOGICAL
|
&& !(atom->ts.type == BT_LOGICAL
|
&& atom->ts.kind == gfc_atomic_logical_kind))
|
&& atom->ts.kind == gfc_atomic_logical_kind))
|
{
|
{
|
gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
|
gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
|
"integer of ATOMIC_INT_KIND or a logical of "
|
"integer of ATOMIC_INT_KIND or a logical of "
|
"ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
|
"ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!gfc_expr_attr (atom).codimension)
|
if (!gfc_expr_attr (atom).codimension)
|
{
|
{
|
gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
|
gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
|
"coarray or coindexed", &atom->where, gfc_current_intrinsic);
|
"coarray or coindexed", &atom->where, gfc_current_intrinsic);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (atom->ts.type != value->ts.type)
|
if (atom->ts.type != value->ts.type)
|
{
|
{
|
gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
|
gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
|
"have the same type at %L", gfc_current_intrinsic,
|
"have the same type at %L", gfc_current_intrinsic,
|
&value->where);
|
&value->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
|
gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
|
{
|
{
|
if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
|
if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
|
if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
|
{
|
{
|
gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
|
gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
|
"definable", gfc_current_intrinsic, &atom->where);
|
"definable", gfc_current_intrinsic, &atom->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return gfc_check_atomic (atom, value);
|
return gfc_check_atomic (atom, value);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
|
gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
|
{
|
{
|
if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
|
if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
|
if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
|
{
|
{
|
gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
|
gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
|
"definable", gfc_current_intrinsic, &value->where);
|
"definable", gfc_current_intrinsic, &value->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return gfc_check_atomic (atom, value);
|
return gfc_check_atomic (atom, value);
|
}
|
}
|
|
|
|
|
/* BESJN and BESYN functions. */
|
/* BESJN and BESYN functions. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_besn (gfc_expr *n, gfc_expr *x)
|
gfc_check_besn (gfc_expr *n, gfc_expr *x)
|
{
|
{
|
if (type_check (n, 0, BT_INTEGER) == FAILURE)
|
if (type_check (n, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (n->expr_type == EXPR_CONSTANT)
|
if (n->expr_type == EXPR_CONSTANT)
|
{
|
{
|
int i;
|
int i;
|
gfc_extract_int (n, &i);
|
gfc_extract_int (n, &i);
|
if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument "
|
if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument "
|
"N at %L", &n->where) == FAILURE)
|
"N at %L", &n->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (type_check (x, 1, BT_REAL) == FAILURE)
|
if (type_check (x, 1, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Transformational version of the Bessel JN and YN functions. */
|
/* Transformational version of the Bessel JN and YN functions. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
|
gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
|
{
|
{
|
if (type_check (n1, 0, BT_INTEGER) == FAILURE)
|
if (type_check (n1, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (n1, 0) == FAILURE)
|
if (scalar_check (n1, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (nonnegative_check("N1", n1) == FAILURE)
|
if (nonnegative_check("N1", n1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (n2, 1, BT_INTEGER) == FAILURE)
|
if (type_check (n2, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (n2, 1) == FAILURE)
|
if (scalar_check (n2, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (nonnegative_check("N2", n2) == FAILURE)
|
if (nonnegative_check("N2", n2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (x, 2, BT_REAL) == FAILURE)
|
if (type_check (x, 2, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (x, 2) == FAILURE)
|
if (scalar_check (x, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
|
gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
|
gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (pos, 1, BT_INTEGER) == FAILURE)
|
if (type_check (pos, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("pos", pos) == FAILURE)
|
if (nonnegative_check ("pos", pos) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
|
if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_char (gfc_expr *i, gfc_expr *kind)
|
gfc_check_char (gfc_expr *i, gfc_expr *kind)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
|
if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_chdir (gfc_expr *dir)
|
gfc_check_chdir (gfc_expr *dir)
|
{
|
{
|
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
|
gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
|
{
|
{
|
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (status, 1) == FAILURE)
|
if (scalar_check (status, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
|
gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
|
gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
|
gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
|
{
|
{
|
if (numeric_check (x, 0) == FAILURE)
|
if (numeric_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (y != NULL)
|
if (y != NULL)
|
{
|
{
|
if (numeric_check (y, 1) == FAILURE)
|
if (numeric_check (y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (x->ts.type == BT_COMPLEX)
|
if (x->ts.type == BT_COMPLEX)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
|
"present if 'x' is COMPLEX",
|
"present if 'x' is COMPLEX",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&y->where);
|
&y->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (y->ts.type == BT_COMPLEX)
|
if (y->ts.type == BT_COMPLEX)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
|
"of either REAL or INTEGER",
|
"of either REAL or INTEGER",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&y->where);
|
&y->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
}
|
}
|
|
|
if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
|
if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_complex (gfc_expr *x, gfc_expr *y)
|
gfc_check_complex (gfc_expr *x, gfc_expr *y)
|
{
|
{
|
if (int_or_real_check (x, 0) == FAILURE)
|
if (int_or_real_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (x, 0) == FAILURE)
|
if (scalar_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (int_or_real_check (y, 1) == FAILURE)
|
if (int_or_real_check (y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (y, 1) == FAILURE)
|
if (scalar_check (y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
|
gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
|
{
|
{
|
if (logical_array_check (mask, 0) == FAILURE)
|
if (logical_array_check (mask, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (dim_rank_check (dim, mask, 0) == FAILURE)
|
if (dim_rank_check (dim, mask, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
|
gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
|
{
|
{
|
if (array_check (array, 0) == FAILURE)
|
if (array_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
|
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_check (dim, 2, true) == FAILURE)
|
if (dim_check (dim, 2, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, array, false) == FAILURE)
|
if (dim_rank_check (dim, array, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array->rank == 1 || shift->rank == 0)
|
if (array->rank == 1 || shift->rank == 0)
|
{
|
{
|
if (scalar_check (shift, 1) == FAILURE)
|
if (scalar_check (shift, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (shift->rank == array->rank - 1)
|
else if (shift->rank == array->rank - 1)
|
{
|
{
|
int d;
|
int d;
|
if (!dim)
|
if (!dim)
|
d = 1;
|
d = 1;
|
else if (dim->expr_type == EXPR_CONSTANT)
|
else if (dim->expr_type == EXPR_CONSTANT)
|
gfc_extract_int (dim, &d);
|
gfc_extract_int (dim, &d);
|
else
|
else
|
d = -1;
|
d = -1;
|
|
|
if (d > 0)
|
if (d > 0)
|
{
|
{
|
int i, j;
|
int i, j;
|
for (i = 0, j = 0; i < array->rank; i++)
|
for (i = 0, j = 0; i < array->rank; i++)
|
if (i != d - 1)
|
if (i != d - 1)
|
{
|
{
|
if (!identical_dimen_shape (array, i, shift, j))
|
if (!identical_dimen_shape (array, i, shift, j))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
"invalid shape in dimension %d (%ld/%ld)",
|
"invalid shape in dimension %d (%ld/%ld)",
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &shift->where, i + 1,
|
gfc_current_intrinsic, &shift->where, i + 1,
|
mpz_get_si (array->shape[i]),
|
mpz_get_si (array->shape[i]),
|
mpz_get_si (shift->shape[j]));
|
mpz_get_si (shift->shape[j]));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
j += 1;
|
j += 1;
|
}
|
}
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
|
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
|
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
|
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &shift->where, array->rank - 1);
|
gfc_current_intrinsic, &shift->where, array->rank - 1);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ctime (gfc_expr *time)
|
gfc_check_ctime (gfc_expr *time)
|
{
|
{
|
if (scalar_check (time, 0) == FAILURE)
|
if (scalar_check (time, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (time, 0, BT_INTEGER) == FAILURE)
|
if (type_check (time, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
|
gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
|
{
|
{
|
if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
|
if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gfc_try
|
gfc_try
|
gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
|
gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
|
{
|
{
|
if (numeric_check (x, 0) == FAILURE)
|
if (numeric_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (y != NULL)
|
if (y != NULL)
|
{
|
{
|
if (numeric_check (y, 1) == FAILURE)
|
if (numeric_check (y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (x->ts.type == BT_COMPLEX)
|
if (x->ts.type == BT_COMPLEX)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
|
"present if 'x' is COMPLEX",
|
"present if 'x' is COMPLEX",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&y->where);
|
&y->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (y->ts.type == BT_COMPLEX)
|
if (y->ts.type == BT_COMPLEX)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
|
"of either REAL or INTEGER",
|
"of either REAL or INTEGER",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&y->where);
|
&y->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_dble (gfc_expr *x)
|
gfc_check_dble (gfc_expr *x)
|
{
|
{
|
if (numeric_check (x, 0) == FAILURE)
|
if (numeric_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_digits (gfc_expr *x)
|
gfc_check_digits (gfc_expr *x)
|
{
|
{
|
if (int_or_real_check (x, 0) == FAILURE)
|
if (int_or_real_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
|
gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
|
{
|
{
|
switch (vector_a->ts.type)
|
switch (vector_a->ts.type)
|
{
|
{
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
|
if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
break;
|
break;
|
|
|
case BT_INTEGER:
|
case BT_INTEGER:
|
case BT_REAL:
|
case BT_REAL:
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
if (numeric_check (vector_b, 1) == FAILURE)
|
if (numeric_check (vector_b, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
|
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
|
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &vector_a->where);
|
gfc_current_intrinsic, &vector_a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (rank_check (vector_a, 0, 1) == FAILURE)
|
if (rank_check (vector_a, 0, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (vector_b, 1, 1) == FAILURE)
|
if (rank_check (vector_b, 1, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
|
if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
|
{
|
{
|
gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
|
gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
|
"intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
|
"intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name, &vector_a->where);
|
gfc_current_intrinsic_arg[1]->name, &vector_a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_dprod (gfc_expr *x, gfc_expr *y)
|
gfc_check_dprod (gfc_expr *x, gfc_expr *y)
|
{
|
{
|
if (type_check (x, 0, BT_REAL) == FAILURE
|
if (type_check (x, 0, BT_REAL) == FAILURE
|
|| type_check (y, 1, BT_REAL) == FAILURE)
|
|| type_check (y, 1, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (x->ts.kind != gfc_default_real_kind)
|
if (x->ts.kind != gfc_default_real_kind)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
|
"real", gfc_current_intrinsic_arg[0]->name,
|
"real", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &x->where);
|
gfc_current_intrinsic, &x->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (y->ts.kind != gfc_default_real_kind)
|
if (y->ts.kind != gfc_default_real_kind)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
|
"real", gfc_current_intrinsic_arg[1]->name,
|
"real", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &y->where);
|
gfc_current_intrinsic, &y->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
|
gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (i->is_boz && j->is_boz)
|
if (i->is_boz && j->is_boz)
|
{
|
{
|
gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
|
gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
|
"constants", &i->where, &j->where);
|
"constants", &i->where, &j->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE)
|
if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (shift, 2, BT_INTEGER) == FAILURE)
|
if (type_check (shift, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("SHIFT", shift) == FAILURE)
|
if (nonnegative_check ("SHIFT", shift) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (i->is_boz)
|
if (i->is_boz)
|
{
|
{
|
if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE)
|
if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
i->ts.kind = j->ts.kind;
|
i->ts.kind = j->ts.kind;
|
}
|
}
|
else
|
else
|
{
|
{
|
if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
|
if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
j->ts.kind = i->ts.kind;
|
j->ts.kind = i->ts.kind;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
|
gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
|
gfc_expr *dim)
|
gfc_expr *dim)
|
{
|
{
|
if (array_check (array, 0) == FAILURE)
|
if (array_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
|
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_check (dim, 3, true) == FAILURE)
|
if (dim_check (dim, 3, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, array, false) == FAILURE)
|
if (dim_rank_check (dim, array, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array->rank == 1 || shift->rank == 0)
|
if (array->rank == 1 || shift->rank == 0)
|
{
|
{
|
if (scalar_check (shift, 1) == FAILURE)
|
if (scalar_check (shift, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (shift->rank == array->rank - 1)
|
else if (shift->rank == array->rank - 1)
|
{
|
{
|
int d;
|
int d;
|
if (!dim)
|
if (!dim)
|
d = 1;
|
d = 1;
|
else if (dim->expr_type == EXPR_CONSTANT)
|
else if (dim->expr_type == EXPR_CONSTANT)
|
gfc_extract_int (dim, &d);
|
gfc_extract_int (dim, &d);
|
else
|
else
|
d = -1;
|
d = -1;
|
|
|
if (d > 0)
|
if (d > 0)
|
{
|
{
|
int i, j;
|
int i, j;
|
for (i = 0, j = 0; i < array->rank; i++)
|
for (i = 0, j = 0; i < array->rank; i++)
|
if (i != d - 1)
|
if (i != d - 1)
|
{
|
{
|
if (!identical_dimen_shape (array, i, shift, j))
|
if (!identical_dimen_shape (array, i, shift, j))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
"invalid shape in dimension %d (%ld/%ld)",
|
"invalid shape in dimension %d (%ld/%ld)",
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &shift->where, i + 1,
|
gfc_current_intrinsic, &shift->where, i + 1,
|
mpz_get_si (array->shape[i]),
|
mpz_get_si (array->shape[i]),
|
mpz_get_si (shift->shape[j]));
|
mpz_get_si (shift->shape[j]));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
j += 1;
|
j += 1;
|
}
|
}
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
|
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
|
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
|
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &shift->where, array->rank - 1);
|
gfc_current_intrinsic, &shift->where, array->rank - 1);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (boundary != NULL)
|
if (boundary != NULL)
|
{
|
{
|
if (same_type_check (array, 0, boundary, 2) == FAILURE)
|
if (same_type_check (array, 0, boundary, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array->rank == 1 || boundary->rank == 0)
|
if (array->rank == 1 || boundary->rank == 0)
|
{
|
{
|
if (scalar_check (boundary, 2) == FAILURE)
|
if (scalar_check (boundary, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (boundary->rank == array->rank - 1)
|
else if (boundary->rank == array->rank - 1)
|
{
|
{
|
if (gfc_check_conformance (shift, boundary,
|
if (gfc_check_conformance (shift, boundary,
|
"arguments '%s' and '%s' for "
|
"arguments '%s' and '%s' for "
|
"intrinsic %s",
|
"intrinsic %s",
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic ) == FAILURE)
|
gfc_current_intrinsic ) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
|
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
|
"rank %d or be a scalar",
|
"rank %d or be a scalar",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&shift->where, array->rank - 1);
|
&shift->where, array->rank - 1);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gfc_try
|
gfc_try
|
gfc_check_float (gfc_expr *a)
|
gfc_check_float (gfc_expr *a)
|
{
|
{
|
if (type_check (a, 0, BT_INTEGER) == FAILURE)
|
if (type_check (a, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if ((a->ts.kind != gfc_default_integer_kind)
|
if ((a->ts.kind != gfc_default_integer_kind)
|
&& gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER "
|
&& gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER "
|
"kind argument to %s intrinsic at %L",
|
"kind argument to %s intrinsic at %L",
|
gfc_current_intrinsic, &a->where) == FAILURE )
|
gfc_current_intrinsic, &a->where) == FAILURE )
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* A single complex argument. */
|
/* A single complex argument. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fn_c (gfc_expr *a)
|
gfc_check_fn_c (gfc_expr *a)
|
{
|
{
|
if (type_check (a, 0, BT_COMPLEX) == FAILURE)
|
if (type_check (a, 0, BT_COMPLEX) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* A single real argument. */
|
/* A single real argument. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fn_r (gfc_expr *a)
|
gfc_check_fn_r (gfc_expr *a)
|
{
|
{
|
if (type_check (a, 0, BT_REAL) == FAILURE)
|
if (type_check (a, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* A single double argument. */
|
/* A single double argument. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fn_d (gfc_expr *a)
|
gfc_check_fn_d (gfc_expr *a)
|
{
|
{
|
if (double_check (a, 0) == FAILURE)
|
if (double_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* A single real or complex argument. */
|
/* A single real or complex argument. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fn_rc (gfc_expr *a)
|
gfc_check_fn_rc (gfc_expr *a)
|
{
|
{
|
if (real_or_complex_check (a, 0) == FAILURE)
|
if (real_or_complex_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fn_rc2008 (gfc_expr *a)
|
gfc_check_fn_rc2008 (gfc_expr *a)
|
{
|
{
|
if (real_or_complex_check (a, 0) == FAILURE)
|
if (real_or_complex_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (a->ts.type == BT_COMPLEX
|
if (a->ts.type == BT_COMPLEX
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
|
"argument of '%s' intrinsic at %L",
|
"argument of '%s' intrinsic at %L",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &a->where) == FAILURE)
|
gfc_current_intrinsic, &a->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fnum (gfc_expr *unit)
|
gfc_check_fnum (gfc_expr *unit)
|
{
|
{
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_huge (gfc_expr *x)
|
gfc_check_huge (gfc_expr *x)
|
{
|
{
|
if (int_or_real_check (x, 0) == FAILURE)
|
if (int_or_real_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_hypot (gfc_expr *x, gfc_expr *y)
|
gfc_check_hypot (gfc_expr *x, gfc_expr *y)
|
{
|
{
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check that the single argument is an integer. */
|
/* Check that the single argument is an integer. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_i (gfc_expr *i)
|
gfc_check_i (gfc_expr *i)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_iand (gfc_expr *i, gfc_expr *j)
|
gfc_check_iand (gfc_expr *i, gfc_expr *j)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (i->ts.kind != j->ts.kind)
|
if (i->ts.kind != j->ts.kind)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
&i->where) == FAILURE)
|
&i->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
|
gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (pos, 1, BT_INTEGER) == FAILURE)
|
if (type_check (pos, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (len, 2, BT_INTEGER) == FAILURE)
|
if (type_check (len, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("pos", pos) == FAILURE)
|
if (nonnegative_check ("pos", pos) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("len", len) == FAILURE)
|
if (nonnegative_check ("len", len) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
|
if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
|
gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
|
if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
|
{
|
{
|
gfc_expr *start;
|
gfc_expr *start;
|
gfc_expr *end;
|
gfc_expr *end;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
|
|
/* Substring references don't have the charlength set. */
|
/* Substring references don't have the charlength set. */
|
ref = c->ref;
|
ref = c->ref;
|
while (ref && ref->type != REF_SUBSTRING)
|
while (ref && ref->type != REF_SUBSTRING)
|
ref = ref->next;
|
ref = ref->next;
|
|
|
gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
|
gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
|
|
|
if (!ref)
|
if (!ref)
|
{
|
{
|
/* Check that the argument is length one. Non-constant lengths
|
/* Check that the argument is length one. Non-constant lengths
|
can't be checked here, so assume they are ok. */
|
can't be checked here, so assume they are ok. */
|
if (c->ts.u.cl && c->ts.u.cl->length)
|
if (c->ts.u.cl && c->ts.u.cl->length)
|
{
|
{
|
/* If we already have a length for this expression then use it. */
|
/* If we already have a length for this expression then use it. */
|
if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
|
if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
|
return SUCCESS;
|
return SUCCESS;
|
i = mpz_get_si (c->ts.u.cl->length->value.integer);
|
i = mpz_get_si (c->ts.u.cl->length->value.integer);
|
}
|
}
|
else
|
else
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
else
|
else
|
{
|
{
|
start = ref->u.ss.start;
|
start = ref->u.ss.start;
|
end = ref->u.ss.end;
|
end = ref->u.ss.end;
|
|
|
gcc_assert (start);
|
gcc_assert (start);
|
if (end == NULL || end->expr_type != EXPR_CONSTANT
|
if (end == NULL || end->expr_type != EXPR_CONSTANT
|
|| start->expr_type != EXPR_CONSTANT)
|
|| start->expr_type != EXPR_CONSTANT)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
i = mpz_get_si (end->value.integer) + 1
|
i = mpz_get_si (end->value.integer) + 1
|
- mpz_get_si (start->value.integer);
|
- mpz_get_si (start->value.integer);
|
}
|
}
|
}
|
}
|
else
|
else
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (i != 1)
|
if (i != 1)
|
{
|
{
|
gfc_error ("Argument of %s at %L must be of length one",
|
gfc_error ("Argument of %s at %L must be of length one",
|
gfc_current_intrinsic, &c->where);
|
gfc_current_intrinsic, &c->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_idnint (gfc_expr *a)
|
gfc_check_idnint (gfc_expr *a)
|
{
|
{
|
if (double_check (a, 0) == FAILURE)
|
if (double_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ieor (gfc_expr *i, gfc_expr *j)
|
gfc_check_ieor (gfc_expr *i, gfc_expr *j)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (i->ts.kind != j->ts.kind)
|
if (i->ts.kind != j->ts.kind)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
&i->where) == FAILURE)
|
&i->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
|
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
|
gfc_expr *kind)
|
gfc_expr *kind)
|
{
|
{
|
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
|
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
|
if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (string->ts.kind != substring->ts.kind)
|
if (string->ts.kind != substring->ts.kind)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
|
"kind as '%s'", gfc_current_intrinsic_arg[1]->name,
|
"kind as '%s'", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &substring->where,
|
gfc_current_intrinsic, &substring->where,
|
gfc_current_intrinsic_arg[0]->name);
|
gfc_current_intrinsic_arg[0]->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_int (gfc_expr *x, gfc_expr *kind)
|
gfc_check_int (gfc_expr *x, gfc_expr *kind)
|
{
|
{
|
if (numeric_check (x, 0) == FAILURE)
|
if (numeric_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_intconv (gfc_expr *x)
|
gfc_check_intconv (gfc_expr *x)
|
{
|
{
|
if (numeric_check (x, 0) == FAILURE)
|
if (numeric_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ior (gfc_expr *i, gfc_expr *j)
|
gfc_check_ior (gfc_expr *i, gfc_expr *j)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (i->ts.kind != j->ts.kind)
|
if (i->ts.kind != j->ts.kind)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
|
&i->where) == FAILURE)
|
&i->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
|
gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
|
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
|
if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
|
gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
if (type_check (i, 0, BT_INTEGER) == FAILURE
|
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
|
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (size != NULL)
|
if (size != NULL)
|
{
|
{
|
int i2, i3;
|
int i2, i3;
|
|
|
if (type_check (size, 2, BT_INTEGER) == FAILURE)
|
if (type_check (size, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE)
|
if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (size->expr_type == EXPR_CONSTANT)
|
if (size->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_extract_int (size, &i3);
|
gfc_extract_int (size, &i3);
|
if (i3 <= 0)
|
if (i3 <= 0)
|
{
|
{
|
gfc_error ("SIZE at %L must be positive", &size->where);
|
gfc_error ("SIZE at %L must be positive", &size->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (shift->expr_type == EXPR_CONSTANT)
|
if (shift->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_extract_int (shift, &i2);
|
gfc_extract_int (shift, &i2);
|
if (i2 < 0)
|
if (i2 < 0)
|
i2 = -i2;
|
i2 = -i2;
|
|
|
if (i2 > i3)
|
if (i2 > i3)
|
{
|
{
|
gfc_error ("The absolute value of SHIFT at %L must be less "
|
gfc_error ("The absolute value of SHIFT at %L must be less "
|
"than or equal to SIZE at %L", &shift->where,
|
"than or equal to SIZE at %L", &shift->where,
|
&size->where);
|
&size->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
|
else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
|
gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
|
{
|
{
|
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
|
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
|
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
|
gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
|
{
|
{
|
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
|
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (pid, 0) == FAILURE)
|
if (scalar_check (pid, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
|
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (sig, 1) == FAILURE)
|
if (scalar_check (sig, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_kind (gfc_expr *x)
|
gfc_check_kind (gfc_expr *x)
|
{
|
{
|
if (x->ts.type == BT_DERIVED)
|
if (x->ts.type == BT_DERIVED)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
|
"non-derived type", gfc_current_intrinsic_arg[0]->name,
|
"non-derived type", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &x->where);
|
gfc_current_intrinsic, &x->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
{
|
{
|
if (array_check (array, 0) == FAILURE)
|
if (array_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, array, 1) == FAILURE)
|
if (dim_rank_check (dim, array, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
|
gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
|
{
|
{
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
{
|
{
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (coarray_check (coarray, 0) == FAILURE)
|
if (coarray_check (coarray, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim != NULL)
|
if (dim != NULL)
|
{
|
{
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_corank_check (dim, coarray) == FAILURE)
|
if (dim_corank_check (dim, coarray) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
|
gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
|
{
|
{
|
if (type_check (s, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (s, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
|
gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
|
{
|
{
|
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (b, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (b, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_link (gfc_expr *path1, gfc_expr *path2)
|
gfc_check_link (gfc_expr *path1, gfc_expr *path2)
|
{
|
{
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
|
gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
|
{
|
{
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_loc (gfc_expr *expr)
|
gfc_check_loc (gfc_expr *expr)
|
{
|
{
|
return variable_check (expr, 0, true);
|
return variable_check (expr, 0, true);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
|
gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
|
{
|
{
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
|
gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
|
{
|
{
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_logical (gfc_expr *a, gfc_expr *kind)
|
gfc_check_logical (gfc_expr *a, gfc_expr *kind)
|
{
|
{
|
if (type_check (a, 0, BT_LOGICAL) == FAILURE)
|
if (type_check (a, 0, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
|
if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Min/max family. */
|
/* Min/max family. */
|
|
|
static gfc_try
|
static gfc_try
|
min_max_args (gfc_actual_arglist *arg)
|
min_max_args (gfc_actual_arglist *arg)
|
{
|
{
|
if (arg == NULL || arg->next == NULL)
|
if (arg == NULL || arg->next == NULL)
|
{
|
{
|
gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
|
gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
|
gfc_current_intrinsic, gfc_current_intrinsic_where);
|
gfc_current_intrinsic, gfc_current_intrinsic_where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
check_rest (bt type, int kind, gfc_actual_arglist *arglist)
|
check_rest (bt type, int kind, gfc_actual_arglist *arglist)
|
{
|
{
|
gfc_actual_arglist *arg, *tmp;
|
gfc_actual_arglist *arg, *tmp;
|
|
|
gfc_expr *x;
|
gfc_expr *x;
|
int m, n;
|
int m, n;
|
|
|
if (min_max_args (arglist) == FAILURE)
|
if (min_max_args (arglist) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
for (arg = arglist, n=1; arg; arg = arg->next, n++)
|
for (arg = arglist, n=1; arg; arg = arg->next, n++)
|
{
|
{
|
x = arg->expr;
|
x = arg->expr;
|
if (x->ts.type != type || x->ts.kind != kind)
|
if (x->ts.type != type || x->ts.kind != kind)
|
{
|
{
|
if (x->ts.type == type)
|
if (x->ts.type == type)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
|
"kinds at %L", &x->where) == FAILURE)
|
"kinds at %L", &x->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
|
gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
|
"%s(%d)", n, gfc_current_intrinsic, &x->where,
|
"%s(%d)", n, gfc_current_intrinsic, &x->where,
|
gfc_basic_typename (type), kind);
|
gfc_basic_typename (type), kind);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
|
for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
|
if (gfc_check_conformance (tmp->expr, x,
|
if (gfc_check_conformance (tmp->expr, x,
|
"arguments 'a%d' and 'a%d' for "
|
"arguments 'a%d' and 'a%d' for "
|
"intrinsic '%s'", m, n,
|
"intrinsic '%s'", m, n,
|
gfc_current_intrinsic) == FAILURE)
|
gfc_current_intrinsic) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_min_max (gfc_actual_arglist *arg)
|
gfc_check_min_max (gfc_actual_arglist *arg)
|
{
|
{
|
gfc_expr *x;
|
gfc_expr *x;
|
|
|
if (min_max_args (arg) == FAILURE)
|
if (min_max_args (arg) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
x = arg->expr;
|
x = arg->expr;
|
|
|
if (x->ts.type == BT_CHARACTER)
|
if (x->ts.type == BT_CHARACTER)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with CHARACTER argument at %L",
|
"with CHARACTER argument at %L",
|
gfc_current_intrinsic, &x->where) == FAILURE)
|
gfc_current_intrinsic, &x->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
|
else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
|
{
|
{
|
gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
|
gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
|
"REAL or CHARACTER", gfc_current_intrinsic, &x->where);
|
"REAL or CHARACTER", gfc_current_intrinsic, &x->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return check_rest (x->ts.type, x->ts.kind, arg);
|
return check_rest (x->ts.type, x->ts.kind, arg);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_min_max_integer (gfc_actual_arglist *arg)
|
gfc_check_min_max_integer (gfc_actual_arglist *arg)
|
{
|
{
|
return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
|
return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_min_max_real (gfc_actual_arglist *arg)
|
gfc_check_min_max_real (gfc_actual_arglist *arg)
|
{
|
{
|
return check_rest (BT_REAL, gfc_default_real_kind, arg);
|
return check_rest (BT_REAL, gfc_default_real_kind, arg);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_min_max_double (gfc_actual_arglist *arg)
|
gfc_check_min_max_double (gfc_actual_arglist *arg)
|
{
|
{
|
return check_rest (BT_REAL, gfc_default_double_kind, arg);
|
return check_rest (BT_REAL, gfc_default_double_kind, arg);
|
}
|
}
|
|
|
|
|
/* End of min/max family. */
|
/* End of min/max family. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_malloc (gfc_expr *size)
|
gfc_check_malloc (gfc_expr *size)
|
{
|
{
|
if (type_check (size, 0, BT_INTEGER) == FAILURE)
|
if (type_check (size, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (size, 0) == FAILURE)
|
if (scalar_check (size, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
|
gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
|
{
|
{
|
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
|
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
|
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
|
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &matrix_a->where);
|
gfc_current_intrinsic, &matrix_a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
|
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 "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
|
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
|
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &matrix_b->where);
|
gfc_current_intrinsic, &matrix_b->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
|
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_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_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
|
gfc_current_intrinsic, &matrix_a->where,
|
gfc_current_intrinsic, &matrix_a->where,
|
gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
|
gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
switch (matrix_a->rank)
|
switch (matrix_a->rank)
|
{
|
{
|
case 1:
|
case 1:
|
if (rank_check (matrix_b, 1, 2) == FAILURE)
|
if (rank_check (matrix_b, 1, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
/* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
|
/* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
|
if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
|
if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
|
{
|
{
|
gfc_error ("Different shape on dimension 1 for arguments '%s' "
|
gfc_error ("Different shape on dimension 1 for arguments '%s' "
|
"and '%s' at %L for intrinsic matmul",
|
"and '%s' at %L for intrinsic matmul",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
|
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
break;
|
break;
|
|
|
case 2:
|
case 2:
|
if (matrix_b->rank != 2)
|
if (matrix_b->rank != 2)
|
{
|
{
|
if (rank_check (matrix_b, 1, 1) == FAILURE)
|
if (rank_check (matrix_b, 1, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
/* matrix_b has rank 1 or 2 here. Common check for the cases
|
/* 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, k)
|
- matrix_a has shape (n,m) and matrix_b has shape (m). */
|
- matrix_a has shape (n,m) and matrix_b has shape (m). */
|
if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
|
if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
|
{
|
{
|
gfc_error ("Different shape on dimension 2 for argument '%s' and "
|
gfc_error ("Different shape on dimension 2 for argument '%s' and "
|
"dimension 1 for argument '%s' at %L for intrinsic "
|
"dimension 1 for argument '%s' at %L for intrinsic "
|
"matmul", gfc_current_intrinsic_arg[0]->name,
|
"matmul", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
|
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
|
"1 or 2", gfc_current_intrinsic_arg[0]->name,
|
"1 or 2", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &matrix_a->where);
|
gfc_current_intrinsic, &matrix_a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Whoever came up with this interface was probably on something.
|
/* Whoever came up with this interface was probably on something.
|
The possibilities for the occupation of the second and third
|
The possibilities for the occupation of the second and third
|
parameters are:
|
parameters are:
|
|
|
Arg #2 Arg #3
|
Arg #2 Arg #3
|
NULL NULL
|
NULL NULL
|
DIM NULL
|
DIM NULL
|
MASK NULL
|
MASK NULL
|
NULL MASK minloc(array, mask=m)
|
NULL MASK minloc(array, mask=m)
|
DIM MASK
|
DIM MASK
|
|
|
I.e. in the case of minloc(array,mask), mask will be in the second
|
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. */
|
position of the argument list and we'll have to fix that up. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
|
gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
|
{
|
{
|
gfc_expr *a, *m, *d;
|
gfc_expr *a, *m, *d;
|
|
|
a = ap->expr;
|
a = ap->expr;
|
if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
|
if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
d = ap->next->expr;
|
d = ap->next->expr;
|
m = ap->next->next->expr;
|
m = ap->next->next->expr;
|
|
|
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
|
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
|
&& ap->next->name == NULL)
|
&& ap->next->name == NULL)
|
{
|
{
|
m = d;
|
m = d;
|
d = NULL;
|
d = NULL;
|
ap->next->expr = NULL;
|
ap->next->expr = NULL;
|
ap->next->next->expr = m;
|
ap->next->next->expr = m;
|
}
|
}
|
|
|
if (dim_check (d, 1, false) == FAILURE)
|
if (dim_check (d, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (d, a, 0) == FAILURE)
|
if (dim_rank_check (d, a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
|
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (m != NULL
|
if (m != NULL
|
&& gfc_check_conformance (a, m,
|
&& gfc_check_conformance (a, m,
|
"arguments '%s' and '%s' for intrinsic %s",
|
"arguments '%s' and '%s' for intrinsic %s",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic ) == FAILURE)
|
gfc_current_intrinsic ) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Similar to minloc/maxloc, the argument list might need to be
|
/* Similar to minloc/maxloc, the argument list might need to be
|
reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
|
reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
|
difference is that MINLOC/MAXLOC take an additional KIND argument.
|
difference is that MINLOC/MAXLOC take an additional KIND argument.
|
The possibilities are:
|
The possibilities are:
|
|
|
Arg #2 Arg #3
|
Arg #2 Arg #3
|
NULL NULL
|
NULL NULL
|
DIM NULL
|
DIM NULL
|
MASK NULL
|
MASK NULL
|
NULL MASK minval(array, mask=m)
|
NULL MASK minval(array, mask=m)
|
DIM MASK
|
DIM MASK
|
|
|
I.e. in the case of minval(array,mask), mask will be in the second
|
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. */
|
position of the argument list and we'll have to fix that up. */
|
|
|
static gfc_try
|
static gfc_try
|
check_reduction (gfc_actual_arglist *ap)
|
check_reduction (gfc_actual_arglist *ap)
|
{
|
{
|
gfc_expr *a, *m, *d;
|
gfc_expr *a, *m, *d;
|
|
|
a = ap->expr;
|
a = ap->expr;
|
d = ap->next->expr;
|
d = ap->next->expr;
|
m = ap->next->next->expr;
|
m = ap->next->next->expr;
|
|
|
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
|
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
|
&& ap->next->name == NULL)
|
&& ap->next->name == NULL)
|
{
|
{
|
m = d;
|
m = d;
|
d = NULL;
|
d = NULL;
|
ap->next->expr = NULL;
|
ap->next->expr = NULL;
|
ap->next->next->expr = m;
|
ap->next->next->expr = m;
|
}
|
}
|
|
|
if (dim_check (d, 1, false) == FAILURE)
|
if (dim_check (d, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (d, a, 0) == FAILURE)
|
if (dim_rank_check (d, a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
|
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (m != NULL
|
if (m != NULL
|
&& gfc_check_conformance (a, m,
|
&& gfc_check_conformance (a, m,
|
"arguments '%s' and '%s' for intrinsic %s",
|
"arguments '%s' and '%s' for intrinsic %s",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic) == FAILURE)
|
gfc_current_intrinsic) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_minval_maxval (gfc_actual_arglist *ap)
|
gfc_check_minval_maxval (gfc_actual_arglist *ap)
|
{
|
{
|
if (int_or_real_check (ap->expr, 0) == FAILURE
|
if (int_or_real_check (ap->expr, 0) == FAILURE
|
|| array_check (ap->expr, 0) == FAILURE)
|
|| array_check (ap->expr, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return check_reduction (ap);
|
return check_reduction (ap);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_product_sum (gfc_actual_arglist *ap)
|
gfc_check_product_sum (gfc_actual_arglist *ap)
|
{
|
{
|
if (numeric_check (ap->expr, 0) == FAILURE
|
if (numeric_check (ap->expr, 0) == FAILURE
|
|| array_check (ap->expr, 0) == FAILURE)
|
|| array_check (ap->expr, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return check_reduction (ap);
|
return check_reduction (ap);
|
}
|
}
|
|
|
|
|
/* For IANY, IALL and IPARITY. */
|
/* For IANY, IALL and IPARITY. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_mask (gfc_expr *i, gfc_expr *kind)
|
gfc_check_mask (gfc_expr *i, gfc_expr *kind)
|
{
|
{
|
int k;
|
int k;
|
|
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("I", i) == FAILURE)
|
if (nonnegative_check ("I", i) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind)
|
if (kind)
|
gfc_extract_int (kind, &k);
|
gfc_extract_int (kind, &k);
|
else
|
else
|
k = gfc_default_integer_kind;
|
k = gfc_default_integer_kind;
|
|
|
if (less_than_bitsizekind ("I", i, k) == FAILURE)
|
if (less_than_bitsizekind ("I", i, k) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
|
gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
|
{
|
{
|
if (ap->expr->ts.type != BT_INTEGER)
|
if (ap->expr->ts.type != BT_INTEGER)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &ap->expr->where);
|
gfc_current_intrinsic, &ap->expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (array_check (ap->expr, 0) == FAILURE)
|
if (array_check (ap->expr, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return check_reduction (ap);
|
return check_reduction (ap);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
|
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
|
{
|
{
|
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
|
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
|
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (tsource->ts.type == BT_CHARACTER)
|
if (tsource->ts.type == BT_CHARACTER)
|
return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
|
return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
|
gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
if (type_check (j, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (mask, 2, BT_INTEGER) == FAILURE)
|
if (type_check (mask, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (same_type_check (i, 0, j, 1) == FAILURE)
|
if (same_type_check (i, 0, j, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (same_type_check (i, 0, mask, 2) == FAILURE)
|
if (same_type_check (i, 0, mask, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
|
gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
|
{
|
{
|
if (variable_check (from, 0, false) == FAILURE)
|
if (variable_check (from, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (allocatable_check (from, 0) == FAILURE)
|
if (allocatable_check (from, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (to, 1, false) == FAILURE)
|
if (variable_check (to, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (allocatable_check (to, 1) == FAILURE)
|
if (allocatable_check (to, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
|
if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
|
{
|
{
|
gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
|
gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
|
"polymorphic if FROM is polymorphic",
|
"polymorphic if FROM is polymorphic",
|
&from->where);
|
&from->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (same_type_check (to, 1, from, 0) == FAILURE)
|
if (same_type_check (to, 1, from, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (to->rank != from->rank)
|
if (to->rank != from->rank)
|
{
|
{
|
gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
|
gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
|
"have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
|
"have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&to->where, from->rank, to->rank);
|
&to->where, from->rank, to->rank);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (to->ts.kind != from->ts.kind)
|
if (to->ts.kind != from->ts.kind)
|
{
|
{
|
gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
|
gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
|
"be of the same kind %d/%d",
|
"be of the same kind %d/%d",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&to->where, from->ts.kind, to->ts.kind);
|
&to->where, from->ts.kind, to->ts.kind);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* CLASS arguments: Make sure the vtab of from is present. */
|
/* CLASS arguments: Make sure the vtab of from is present. */
|
if (to->ts.type == BT_CLASS)
|
if (to->ts.type == BT_CLASS)
|
gfc_find_derived_vtab (from->ts.u.derived);
|
gfc_find_derived_vtab (from->ts.u.derived);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_nearest (gfc_expr *x, gfc_expr *s)
|
gfc_check_nearest (gfc_expr *x, gfc_expr *s)
|
{
|
{
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (s, 1, BT_REAL) == FAILURE)
|
if (type_check (s, 1, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (s->expr_type == EXPR_CONSTANT)
|
if (s->expr_type == EXPR_CONSTANT)
|
{
|
{
|
if (mpfr_sgn (s->value.real) == 0)
|
if (mpfr_sgn (s->value.real) == 0)
|
{
|
{
|
gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
|
gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
|
&s->where);
|
&s->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_new_line (gfc_expr *a)
|
gfc_check_new_line (gfc_expr *a)
|
{
|
{
|
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
|
gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
|
{
|
{
|
if (type_check (array, 0, BT_REAL) == FAILURE)
|
if (type_check (array, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (array, 0) == FAILURE)
|
if (array_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, array, false) == FAILURE)
|
if (dim_rank_check (dim, array, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gfc_try
|
gfc_try
|
gfc_check_null (gfc_expr *mold)
|
gfc_check_null (gfc_expr *mold)
|
{
|
{
|
symbol_attribute attr;
|
symbol_attribute attr;
|
|
|
if (mold == NULL)
|
if (mold == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (variable_check (mold, 0, true) == FAILURE)
|
if (variable_check (mold, 0, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
attr = gfc_variable_attr (mold, NULL);
|
attr = gfc_variable_attr (mold, NULL);
|
|
|
if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
|
if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
|
"ALLOCATABLE or procedure pointer",
|
"ALLOCATABLE or procedure pointer",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &mold->where);
|
gfc_current_intrinsic, &mold->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (attr.allocatable
|
if (attr.allocatable
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with "
|
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with "
|
"allocatable MOLD at %L", &mold->where) == FAILURE)
|
"allocatable MOLD at %L", &mold->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* F2008, C1242. */
|
/* F2008, C1242. */
|
if (gfc_is_coindexed (mold))
|
if (gfc_is_coindexed (mold))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
|
"coindexed", gfc_current_intrinsic_arg[0]->name,
|
"coindexed", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &mold->where);
|
gfc_current_intrinsic, &mold->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
|
gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
|
{
|
{
|
if (array_check (array, 0) == FAILURE)
|
if (array_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
|
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_check_conformance (array, mask,
|
if (gfc_check_conformance (array, mask,
|
"arguments '%s' and '%s' for intrinsic '%s'",
|
"arguments '%s' and '%s' for intrinsic '%s'",
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic) == FAILURE)
|
gfc_current_intrinsic) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (vector != NULL)
|
if (vector != NULL)
|
{
|
{
|
mpz_t array_size, vector_size;
|
mpz_t array_size, vector_size;
|
bool have_array_size, have_vector_size;
|
bool have_array_size, have_vector_size;
|
|
|
if (same_type_check (array, 0, vector, 2) == FAILURE)
|
if (same_type_check (array, 0, vector, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (vector, 2, 1) == FAILURE)
|
if (rank_check (vector, 2, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* VECTOR requires at least as many elements as MASK
|
/* VECTOR requires at least as many elements as MASK
|
has .TRUE. values. */
|
has .TRUE. values. */
|
have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
|
have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
|
have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
|
have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
|
|
|
if (have_vector_size
|
if (have_vector_size
|
&& (mask->expr_type == EXPR_ARRAY
|
&& (mask->expr_type == EXPR_ARRAY
|
|| (mask->expr_type == EXPR_CONSTANT
|
|| (mask->expr_type == EXPR_CONSTANT
|
&& have_array_size)))
|
&& have_array_size)))
|
{
|
{
|
int mask_true_values = 0;
|
int mask_true_values = 0;
|
|
|
if (mask->expr_type == EXPR_ARRAY)
|
if (mask->expr_type == EXPR_ARRAY)
|
{
|
{
|
gfc_constructor *mask_ctor;
|
gfc_constructor *mask_ctor;
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
while (mask_ctor)
|
while (mask_ctor)
|
{
|
{
|
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
|
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
|
{
|
{
|
mask_true_values = 0;
|
mask_true_values = 0;
|
break;
|
break;
|
}
|
}
|
|
|
if (mask_ctor->expr->value.logical)
|
if (mask_ctor->expr->value.logical)
|
mask_true_values++;
|
mask_true_values++;
|
|
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
}
|
}
|
}
|
}
|
else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
|
else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
|
mask_true_values = mpz_get_si (array_size);
|
mask_true_values = mpz_get_si (array_size);
|
|
|
if (mpz_get_si (vector_size) < mask_true_values)
|
if (mpz_get_si (vector_size) < mask_true_values)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must "
|
"provide at least as many elements as there "
|
"provide at least as many elements as there "
|
"are .TRUE. values in '%s' (%ld/%d)",
|
"are .TRUE. values in '%s' (%ld/%d)",
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic, &vector->where,
|
gfc_current_intrinsic, &vector->where,
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic_arg[1]->name,
|
mpz_get_si (vector_size), mask_true_values);
|
mpz_get_si (vector_size), mask_true_values);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
|
|
if (have_array_size)
|
if (have_array_size)
|
mpz_clear (array_size);
|
mpz_clear (array_size);
|
if (have_vector_size)
|
if (have_vector_size)
|
mpz_clear (vector_size);
|
mpz_clear (vector_size);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
|
gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
|
{
|
{
|
if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
|
if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (mask, 0) == FAILURE)
|
if (array_check (mask, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, mask, false) == FAILURE)
|
if (dim_rank_check (dim, mask, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_precision (gfc_expr *x)
|
gfc_check_precision (gfc_expr *x)
|
{
|
{
|
if (real_or_complex_check (x, 0) == FAILURE)
|
if (real_or_complex_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_present (gfc_expr *a)
|
gfc_check_present (gfc_expr *a)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
|
|
if (variable_check (a, 0, true) == FAILURE)
|
if (variable_check (a, 0, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
sym = a->symtree->n.sym;
|
sym = a->symtree->n.sym;
|
if (!sym->attr.dummy)
|
if (!sym->attr.dummy)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
|
"dummy variable", gfc_current_intrinsic_arg[0]->name,
|
"dummy variable", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &a->where);
|
gfc_current_intrinsic, &a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!sym->attr.optional)
|
if (!sym->attr.optional)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
|
"an OPTIONAL dummy variable",
|
"an OPTIONAL dummy variable",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&a->where);
|
&a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* 13.14.82 PRESENT(A)
|
/* 13.14.82 PRESENT(A)
|
......
|
......
|
Argument. A shall be the name of an optional dummy argument that is
|
Argument. A shall be the name of an optional dummy argument that is
|
accessible in the subprogram in which the PRESENT function reference
|
accessible in the subprogram in which the PRESENT function reference
|
appears... */
|
appears... */
|
|
|
if (a->ref != NULL
|
if (a->ref != NULL
|
&& !(a->ref->next == NULL && a->ref->type == REF_ARRAY
|
&& !(a->ref->next == NULL && a->ref->type == REF_ARRAY
|
&& (a->ref->u.ar.type == AR_FULL
|
&& (a->ref->u.ar.type == AR_FULL
|
|| (a->ref->u.ar.type == AR_ELEMENT
|
|| (a->ref->u.ar.type == AR_ELEMENT
|
&& a->ref->u.ar.as->rank == 0))))
|
&& a->ref->u.ar.as->rank == 0))))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
|
"subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
|
"subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &a->where, sym->name);
|
gfc_current_intrinsic, &a->where, sym->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_radix (gfc_expr *x)
|
gfc_check_radix (gfc_expr *x)
|
{
|
{
|
if (int_or_real_check (x, 0) == FAILURE)
|
if (int_or_real_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_range (gfc_expr *x)
|
gfc_check_range (gfc_expr *x)
|
{
|
{
|
if (numeric_check (x, 0) == FAILURE)
|
if (numeric_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
|
gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
|
{
|
{
|
/* Any data object is allowed; a "data object" is a "constant (4.1.3),
|
/* Any data object is allowed; a "data object" is a "constant (4.1.3),
|
variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
|
variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
|
|
|
bool is_variable = true;
|
bool is_variable = true;
|
|
|
/* Functions returning pointers are regarded as variable, cf. F2008, R602. */
|
/* Functions returning pointers are regarded as variable, cf. F2008, R602. */
|
if (a->expr_type == EXPR_FUNCTION)
|
if (a->expr_type == EXPR_FUNCTION)
|
is_variable = a->value.function.esym
|
is_variable = a->value.function.esym
|
? a->value.function.esym->result->attr.pointer
|
? a->value.function.esym->result->attr.pointer
|
: a->symtree->n.sym->result->attr.pointer;
|
: a->symtree->n.sym->result->attr.pointer;
|
|
|
if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
|
if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
|
|| a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
|
|| a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
|
|| !is_variable)
|
|| !is_variable)
|
{
|
{
|
gfc_error ("The argument of the RANK intrinsic at %L must be a data "
|
gfc_error ("The argument of the RANK intrinsic at %L must be a data "
|
"object", &a->where);
|
"object", &a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* real, float, sngl. */
|
/* real, float, sngl. */
|
gfc_try
|
gfc_try
|
gfc_check_real (gfc_expr *a, gfc_expr *kind)
|
gfc_check_real (gfc_expr *a, gfc_expr *kind)
|
{
|
{
|
if (numeric_check (a, 0) == FAILURE)
|
if (numeric_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 1, BT_REAL) == FAILURE)
|
if (kind_check (kind, 1, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
|
gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
|
{
|
{
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
|
gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
|
{
|
{
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_repeat (gfc_expr *x, gfc_expr *y)
|
gfc_check_repeat (gfc_expr *x, gfc_expr *y)
|
{
|
{
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (x, 0) == FAILURE)
|
if (scalar_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (y, 0, BT_INTEGER) == FAILURE)
|
if (type_check (y, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (y, 1) == FAILURE)
|
if (scalar_check (y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
|
gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
|
gfc_expr *pad, gfc_expr *order)
|
gfc_expr *pad, gfc_expr *order)
|
{
|
{
|
mpz_t size;
|
mpz_t size;
|
mpz_t nelems;
|
mpz_t nelems;
|
int shape_size;
|
int shape_size;
|
|
|
if (array_check (source, 0) == FAILURE)
|
if (array_check (source, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (shape, 1, 1) == FAILURE)
|
if (rank_check (shape, 1, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (shape, 1, BT_INTEGER) == FAILURE)
|
if (type_check (shape, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_array_size (shape, &size) != SUCCESS)
|
if (gfc_array_size (shape, &size) != SUCCESS)
|
{
|
{
|
gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
|
gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
|
"array of constant size", &shape->where);
|
"array of constant size", &shape->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
shape_size = mpz_get_ui (size);
|
shape_size = mpz_get_ui (size);
|
mpz_clear (size);
|
mpz_clear (size);
|
|
|
if (shape_size <= 0)
|
if (shape_size <= 0)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&shape->where);
|
&shape->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (shape_size > GFC_MAX_DIMENSIONS)
|
else if (shape_size > GFC_MAX_DIMENSIONS)
|
{
|
{
|
gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
|
gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
|
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
|
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (shape->expr_type == EXPR_ARRAY)
|
else if (shape->expr_type == EXPR_ARRAY)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
int i, extent;
|
int i, extent;
|
for (i = 0; i < shape_size; ++i)
|
for (i = 0; i < shape_size; ++i)
|
{
|
{
|
e = gfc_constructor_lookup_expr (shape->value.constructor, i);
|
e = gfc_constructor_lookup_expr (shape->value.constructor, i);
|
if (e->expr_type != EXPR_CONSTANT)
|
if (e->expr_type != EXPR_CONSTANT)
|
continue;
|
continue;
|
|
|
gfc_extract_int (e, &extent);
|
gfc_extract_int (e, &extent);
|
if (extent < 0)
|
if (extent < 0)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
"negative element (%d)",
|
"negative element (%d)",
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &e->where, extent);
|
gfc_current_intrinsic, &e->where, extent);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (pad != NULL)
|
if (pad != NULL)
|
{
|
{
|
if (same_type_check (source, 0, pad, 2) == FAILURE)
|
if (same_type_check (source, 0, pad, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (pad, 2) == FAILURE)
|
if (array_check (pad, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (order != NULL)
|
if (order != NULL)
|
{
|
{
|
if (array_check (order, 3) == FAILURE)
|
if (array_check (order, 3) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (order, 3, BT_INTEGER) == FAILURE)
|
if (type_check (order, 3, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (order->expr_type == EXPR_ARRAY)
|
if (order->expr_type == EXPR_ARRAY)
|
{
|
{
|
int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
|
int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
|
for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
|
perm[i] = 0;
|
perm[i] = 0;
|
|
|
gfc_array_size (order, &size);
|
gfc_array_size (order, &size);
|
order_size = mpz_get_ui (size);
|
order_size = mpz_get_ui (size);
|
mpz_clear (size);
|
mpz_clear (size);
|
|
|
if (order_size != shape_size)
|
if (order_size != shape_size)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
"has wrong number of elements (%d/%d)",
|
"has wrong number of elements (%d/%d)",
|
gfc_current_intrinsic_arg[3]->name,
|
gfc_current_intrinsic_arg[3]->name,
|
gfc_current_intrinsic, &order->where,
|
gfc_current_intrinsic, &order->where,
|
order_size, shape_size);
|
order_size, shape_size);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
for (i = 1; i <= order_size; ++i)
|
for (i = 1; i <= order_size; ++i)
|
{
|
{
|
e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
|
e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
|
if (e->expr_type != EXPR_CONSTANT)
|
if (e->expr_type != EXPR_CONSTANT)
|
continue;
|
continue;
|
|
|
gfc_extract_int (e, &dim);
|
gfc_extract_int (e, &dim);
|
|
|
if (dim < 1 || dim > order_size)
|
if (dim < 1 || dim > order_size)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
"has out-of-range dimension (%d)",
|
"has out-of-range dimension (%d)",
|
gfc_current_intrinsic_arg[3]->name,
|
gfc_current_intrinsic_arg[3]->name,
|
gfc_current_intrinsic, &e->where, dim);
|
gfc_current_intrinsic, &e->where, dim);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (perm[dim-1] != 0)
|
if (perm[dim-1] != 0)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
|
"invalid permutation of dimensions (dimension "
|
"invalid permutation of dimensions (dimension "
|
"'%d' duplicated)",
|
"'%d' duplicated)",
|
gfc_current_intrinsic_arg[3]->name,
|
gfc_current_intrinsic_arg[3]->name,
|
gfc_current_intrinsic, &e->where, dim);
|
gfc_current_intrinsic, &e->where, dim);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
perm[dim-1] = 1;
|
perm[dim-1] = 1;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (pad == NULL && shape->expr_type == EXPR_ARRAY
|
if (pad == NULL && shape->expr_type == EXPR_ARRAY
|
&& gfc_is_constant_expr (shape)
|
&& gfc_is_constant_expr (shape)
|
&& !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
|
&& !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
|
&& source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
|
&& source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
|
{
|
{
|
/* Check the match in size between source and destination. */
|
/* Check the match in size between source and destination. */
|
if (gfc_array_size (source, &nelems) == SUCCESS)
|
if (gfc_array_size (source, &nelems) == SUCCESS)
|
{
|
{
|
gfc_constructor *c;
|
gfc_constructor *c;
|
bool test;
|
bool test;
|
|
|
|
|
mpz_init_set_ui (size, 1);
|
mpz_init_set_ui (size, 1);
|
for (c = gfc_constructor_first (shape->value.constructor);
|
for (c = gfc_constructor_first (shape->value.constructor);
|
c; c = gfc_constructor_next (c))
|
c; c = gfc_constructor_next (c))
|
mpz_mul (size, size, c->expr->value.integer);
|
mpz_mul (size, size, c->expr->value.integer);
|
|
|
test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
|
test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
|
mpz_clear (nelems);
|
mpz_clear (nelems);
|
mpz_clear (size);
|
mpz_clear (size);
|
|
|
if (test)
|
if (test)
|
{
|
{
|
gfc_error ("Without padding, there are not enough elements "
|
gfc_error ("Without padding, there are not enough elements "
|
"in the intrinsic RESHAPE source at %L to match "
|
"in the intrinsic RESHAPE source at %L to match "
|
"the shape", &source->where);
|
"the shape", &source->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
|
gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
|
{
|
{
|
|
|
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
|
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
"must be of a derived type",
|
"must be of a derived type",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&a->where);
|
&a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!gfc_type_is_extensible (a->ts.u.derived))
|
if (!gfc_type_is_extensible (a->ts.u.derived))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
"must be of an extensible type",
|
"must be of an extensible type",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&a->where);
|
&a->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
|
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
"must be of a derived type",
|
"must be of a derived type",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&b->where);
|
&b->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!gfc_type_is_extensible (b->ts.u.derived))
|
if (!gfc_type_is_extensible (b->ts.u.derived))
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
"must be of an extensible type",
|
"must be of an extensible type",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&b->where);
|
&b->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_scale (gfc_expr *x, gfc_expr *i)
|
gfc_check_scale (gfc_expr *x, gfc_expr *i)
|
{
|
{
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (i, 1, BT_INTEGER) == FAILURE)
|
if (type_check (i, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
|
gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
|
{
|
{
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (y, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (y, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
|
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_secnds (gfc_expr *r)
|
gfc_check_secnds (gfc_expr *r)
|
{
|
{
|
if (type_check (r, 0, BT_REAL) == FAILURE)
|
if (type_check (r, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check (r, 0, 4) == FAILURE)
|
if (kind_value_check (r, 0, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (r, 0) == FAILURE)
|
if (scalar_check (r, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_selected_char_kind (gfc_expr *name)
|
gfc_check_selected_char_kind (gfc_expr *name)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (name, 0) == FAILURE)
|
if (scalar_check (name, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_selected_int_kind (gfc_expr *r)
|
gfc_check_selected_int_kind (gfc_expr *r)
|
{
|
{
|
if (type_check (r, 0, BT_INTEGER) == FAILURE)
|
if (type_check (r, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (r, 0) == FAILURE)
|
if (scalar_check (r, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
|
gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
|
{
|
{
|
if (p == NULL && r == NULL
|
if (p == NULL && r == NULL
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
|
" neither 'P' nor 'R' argument at %L",
|
" neither 'P' nor 'R' argument at %L",
|
gfc_current_intrinsic_where) == FAILURE)
|
gfc_current_intrinsic_where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (p)
|
if (p)
|
{
|
{
|
if (type_check (p, 0, BT_INTEGER) == FAILURE)
|
if (type_check (p, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (p, 0) == FAILURE)
|
if (scalar_check (p, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (r)
|
if (r)
|
{
|
{
|
if (type_check (r, 1, BT_INTEGER) == FAILURE)
|
if (type_check (r, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (r, 1) == FAILURE)
|
if (scalar_check (r, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (radix)
|
if (radix)
|
{
|
{
|
if (type_check (radix, 1, BT_INTEGER) == FAILURE)
|
if (type_check (radix, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (radix, 1) == FAILURE)
|
if (scalar_check (radix, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
|
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
|
"RADIX argument at %L", gfc_current_intrinsic,
|
"RADIX argument at %L", gfc_current_intrinsic,
|
&radix->where) == FAILURE)
|
&radix->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
|
gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
|
{
|
{
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (i, 1, BT_INTEGER) == FAILURE)
|
if (type_check (i, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_shape (gfc_expr *source, gfc_expr *kind)
|
gfc_check_shape (gfc_expr *source, gfc_expr *kind)
|
{
|
{
|
gfc_array_ref *ar;
|
gfc_array_ref *ar;
|
|
|
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
|
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
ar = gfc_find_array_ref (source);
|
ar = gfc_find_array_ref (source);
|
|
|
if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
|
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 "
|
gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
|
"an assumed size array", &source->where);
|
"an assumed size array", &source->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_shift (gfc_expr *i, gfc_expr *shift)
|
gfc_check_shift (gfc_expr *i, gfc_expr *shift)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (shift, 0, BT_INTEGER) == FAILURE)
|
if (type_check (shift, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("SHIFT", shift) == FAILURE)
|
if (nonnegative_check ("SHIFT", shift) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
|
if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_sign (gfc_expr *a, gfc_expr *b)
|
gfc_check_sign (gfc_expr *a, gfc_expr *b)
|
{
|
{
|
if (int_or_real_check (a, 0) == FAILURE)
|
if (int_or_real_check (a, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (same_type_check (a, 0, b, 1) == FAILURE)
|
if (same_type_check (a, 0, b, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
{
|
{
|
if (array_check (array, 0) == FAILURE)
|
if (array_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_check (dim, 1, true) == FAILURE)
|
if (dim_check (dim, 1, true) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, array, 0) == FAILURE)
|
if (dim_rank_check (dim, array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_sizeof (gfc_expr *arg)
|
gfc_check_sizeof (gfc_expr *arg)
|
{
|
{
|
if (arg->ts.type == BT_PROCEDURE)
|
if (arg->ts.type == BT_PROCEDURE)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&arg->where);
|
&arg->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_c_sizeof (gfc_expr *arg)
|
gfc_check_c_sizeof (gfc_expr *arg)
|
{
|
{
|
if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
|
if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
|
"interoperable data entity",
|
"interoperable data entity",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&arg->where);
|
&arg->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_sleep_sub (gfc_expr *seconds)
|
gfc_check_sleep_sub (gfc_expr *seconds)
|
{
|
{
|
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
|
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (seconds, 0) == FAILURE)
|
if (scalar_check (seconds, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gfc_try
|
gfc_try
|
gfc_check_sngl (gfc_expr *a)
|
gfc_check_sngl (gfc_expr *a)
|
{
|
{
|
if (type_check (a, 0, BT_REAL) == FAILURE)
|
if (type_check (a, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if ((a->ts.kind != gfc_default_double_kind)
|
if ((a->ts.kind != gfc_default_double_kind)
|
&& gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision "
|
&& gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision "
|
"REAL argument to %s intrinsic at %L",
|
"REAL argument to %s intrinsic at %L",
|
gfc_current_intrinsic, &a->where) == FAILURE)
|
gfc_current_intrinsic, &a->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
gfc_try
|
gfc_try
|
gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
|
gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
|
{
|
{
|
if (source->rank >= GFC_MAX_DIMENSIONS)
|
if (source->rank >= GFC_MAX_DIMENSIONS)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
|
"than rank %d", gfc_current_intrinsic_arg[0]->name,
|
"than rank %d", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
|
gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (dim == NULL)
|
if (dim == NULL)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* dim_rank_check() does not apply here. */
|
/* dim_rank_check() does not apply here. */
|
if (dim
|
if (dim
|
&& dim->expr_type == EXPR_CONSTANT
|
&& dim->expr_type == EXPR_CONSTANT
|
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|
|| mpz_cmp_ui (dim->value.integer, source->rank + 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 "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
|
"dimension index", gfc_current_intrinsic_arg[1]->name,
|
"dimension index", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &dim->where);
|
gfc_current_intrinsic, &dim->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
|
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (ncopies, 2) == FAILURE)
|
if (scalar_check (ncopies, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
|
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
|
functions). */
|
functions). */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
|
gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
|
{
|
{
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (c, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (c, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE
|
if (type_check (status, 2, BT_INTEGER) == FAILURE
|
|| kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
|
|| kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
|
|| scalar_check (status, 2) == FAILURE)
|
|| scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
|
gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
|
{
|
{
|
return gfc_check_fgetputc_sub (unit, c, NULL);
|
return gfc_check_fgetputc_sub (unit, c, NULL);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
|
gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
|
{
|
{
|
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 1, BT_INTEGER) == FAILURE
|
if (type_check (status, 1, BT_INTEGER) == FAILURE
|
|| kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
|
|| kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
|
|| scalar_check (status, 1) == FAILURE)
|
|| scalar_check (status, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fgetput (gfc_expr *c)
|
gfc_check_fgetput (gfc_expr *c)
|
{
|
{
|
return gfc_check_fgetput_sub (c, NULL);
|
return gfc_check_fgetput_sub (c, NULL);
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
|
gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
|
{
|
{
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (offset, 1, BT_INTEGER) == FAILURE)
|
if (type_check (offset, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (offset, 1) == FAILURE)
|
if (scalar_check (offset, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (whence, 2, BT_INTEGER) == FAILURE)
|
if (type_check (whence, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (whence, 2) == FAILURE)
|
if (scalar_check (whence, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 3, BT_INTEGER) == FAILURE)
|
if (type_check (status, 3, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check (status, 3, 4) == FAILURE)
|
if (kind_value_check (status, 3, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 3) == FAILURE)
|
if (scalar_check (status, 3) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
|
gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
|
{
|
{
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
|| kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
|
|| kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (array, 1) == FAILURE)
|
if (array_check (array, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
|
gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
|
{
|
{
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (array, 1) == FAILURE)
|
if (array_check (array, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE
|
if (type_check (status, 2, BT_INTEGER) == FAILURE
|
|| kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
|
|| kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ftell (gfc_expr *unit)
|
gfc_check_ftell (gfc_expr *unit)
|
{
|
{
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
|
gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
|
{
|
{
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (offset, 1, BT_INTEGER) == FAILURE)
|
if (type_check (offset, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (offset, 1) == FAILURE)
|
if (scalar_check (offset, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_stat (gfc_expr *name, gfc_expr *array)
|
gfc_check_stat (gfc_expr *name, gfc_expr *array)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (array, 1) == FAILURE)
|
if (array_check (array, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
|
gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
if (type_check (array, 1, BT_INTEGER) == FAILURE
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (array, 1) == FAILURE)
|
if (array_check (array, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE
|
if (type_check (status, 2, BT_INTEGER) == FAILURE
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
|
gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
|
{
|
{
|
mpz_t nelems;
|
mpz_t nelems;
|
|
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
{
|
{
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (coarray_check (coarray, 0) == FAILURE)
|
if (coarray_check (coarray, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (sub->rank != 1)
|
if (sub->rank != 1)
|
{
|
{
|
gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
|
gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
|
gfc_current_intrinsic_arg[1]->name, &sub->where);
|
gfc_current_intrinsic_arg[1]->name, &sub->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (gfc_array_size (sub, &nelems) == SUCCESS)
|
if (gfc_array_size (sub, &nelems) == SUCCESS)
|
{
|
{
|
int corank = gfc_get_corank (coarray);
|
int corank = gfc_get_corank (coarray);
|
|
|
if (mpz_cmp_ui (nelems, corank) != 0)
|
if (mpz_cmp_ui (nelems, corank) != 0)
|
{
|
{
|
gfc_error ("The number of array elements of the SUB argument to "
|
gfc_error ("The number of array elements of the SUB argument to "
|
"IMAGE_INDEX at %L shall be %d (corank) not %d",
|
"IMAGE_INDEX at %L shall be %d (corank) not %d",
|
&sub->where, corank, (int) mpz_get_si (nelems));
|
&sub->where, corank, (int) mpz_get_si (nelems));
|
mpz_clear (nelems);
|
mpz_clear (nelems);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
mpz_clear (nelems);
|
mpz_clear (nelems);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
|
gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
|
{
|
{
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
{
|
{
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (dim != NULL && coarray == NULL)
|
if (dim != NULL && coarray == NULL)
|
{
|
{
|
gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
|
gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
|
"intrinsic at %L", &dim->where);
|
"intrinsic at %L", &dim->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (coarray == NULL)
|
if (coarray == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (coarray_check (coarray, 0) == FAILURE)
|
if (coarray_check (coarray, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim != NULL)
|
if (dim != NULL)
|
{
|
{
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_corank_check (dim, coarray) == FAILURE)
|
if (dim_corank_check (dim, coarray) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
/* Calculate the sizes for transfer, used by gfc_check_transfer and also
|
/* Calculate the sizes for transfer, used by gfc_check_transfer and also
|
by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
|
by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
|
|
|
gfc_try
|
gfc_try
|
gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
|
gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
|
size_t *source_size, size_t *result_size,
|
size_t *source_size, size_t *result_size,
|
size_t *result_length_p)
|
size_t *result_length_p)
|
|
|
{
|
{
|
size_t result_elt_size;
|
size_t result_elt_size;
|
mpz_t tmp;
|
mpz_t tmp;
|
gfc_expr *mold_element;
|
gfc_expr *mold_element;
|
|
|
if (source->expr_type == EXPR_FUNCTION)
|
if (source->expr_type == EXPR_FUNCTION)
|
return FAILURE;
|
return FAILURE;
|
|
|
/* Calculate the size of the source. */
|
/* Calculate the size of the source. */
|
if (source->expr_type == EXPR_ARRAY
|
if (source->expr_type == EXPR_ARRAY
|
&& gfc_array_size (source, &tmp) == FAILURE)
|
&& gfc_array_size (source, &tmp) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
*source_size = gfc_target_expr_size (source);
|
*source_size = gfc_target_expr_size (source);
|
|
|
mold_element = mold->expr_type == EXPR_ARRAY
|
mold_element = mold->expr_type == EXPR_ARRAY
|
? gfc_constructor_first (mold->value.constructor)->expr
|
? gfc_constructor_first (mold->value.constructor)->expr
|
: mold;
|
: mold;
|
|
|
/* Determine the size of the element. */
|
/* Determine the size of the element. */
|
result_elt_size = gfc_target_expr_size (mold_element);
|
result_elt_size = gfc_target_expr_size (mold_element);
|
if (result_elt_size == 0)
|
if (result_elt_size == 0)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
|
if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
|
{
|
{
|
int result_length;
|
int result_length;
|
|
|
if (size)
|
if (size)
|
result_length = (size_t)mpz_get_ui (size->value.integer);
|
result_length = (size_t)mpz_get_ui (size->value.integer);
|
else
|
else
|
{
|
{
|
result_length = *source_size / result_elt_size;
|
result_length = *source_size / result_elt_size;
|
if (result_length * result_elt_size < *source_size)
|
if (result_length * result_elt_size < *source_size)
|
result_length += 1;
|
result_length += 1;
|
}
|
}
|
|
|
*result_size = result_length * result_elt_size;
|
*result_size = result_length * result_elt_size;
|
if (result_length_p)
|
if (result_length_p)
|
*result_length_p = result_length;
|
*result_length_p = result_length;
|
}
|
}
|
else
|
else
|
*result_size = result_elt_size;
|
*result_size = result_elt_size;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
|
gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
|
{
|
{
|
size_t source_size;
|
size_t source_size;
|
size_t result_size;
|
size_t result_size;
|
|
|
if (mold->ts.type == BT_HOLLERITH)
|
if (mold->ts.type == BT_HOLLERITH)
|
{
|
{
|
gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
|
gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
|
&mold->where, gfc_basic_typename (BT_HOLLERITH));
|
&mold->where, gfc_basic_typename (BT_HOLLERITH));
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (size != NULL)
|
if (size != NULL)
|
{
|
{
|
if (type_check (size, 2, BT_INTEGER) == FAILURE)
|
if (type_check (size, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (size, 2) == FAILURE)
|
if (scalar_check (size, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonoptional_check (size, 2) == FAILURE)
|
if (nonoptional_check (size, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (!gfc_option.warn_surprising)
|
if (!gfc_option.warn_surprising)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
/* If we can't calculate the sizes, we cannot check any more.
|
/* If we can't calculate the sizes, we cannot check any more.
|
Return SUCCESS for that case. */
|
Return SUCCESS for that case. */
|
|
|
if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
|
if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
|
&result_size, NULL) == FAILURE)
|
&result_size, NULL) == FAILURE)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (source_size < result_size)
|
if (source_size < result_size)
|
gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
|
gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
|
"source size %ld < result size %ld", &source->where,
|
"source size %ld < result size %ld", &source->where,
|
(long) source_size, (long) result_size);
|
(long) source_size, (long) result_size);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_transpose (gfc_expr *matrix)
|
gfc_check_transpose (gfc_expr *matrix)
|
{
|
{
|
if (rank_check (matrix, 0, 2) == FAILURE)
|
if (rank_check (matrix, 0, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
{
|
{
|
if (array_check (array, 0) == FAILURE)
|
if (array_check (array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_rank_check (dim, array, 0) == FAILURE)
|
if (dim_rank_check (dim, array, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
|
gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
|
{
|
{
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
|
{
|
{
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (coarray_check (coarray, 0) == FAILURE)
|
if (coarray_check (coarray, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim != NULL)
|
if (dim != NULL)
|
{
|
{
|
if (dim_check (dim, 1, false) == FAILURE)
|
if (dim_check (dim, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dim_corank_check (dim, coarray) == FAILURE)
|
if (dim_corank_check (dim, coarray) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
|
gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
|
{
|
{
|
mpz_t vector_size;
|
mpz_t vector_size;
|
|
|
if (rank_check (vector, 0, 1) == FAILURE)
|
if (rank_check (vector, 0, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (mask, 1) == FAILURE)
|
if (array_check (mask, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
|
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (same_type_check (vector, 0, field, 2) == FAILURE)
|
if (same_type_check (vector, 0, field, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (mask->expr_type == EXPR_ARRAY
|
if (mask->expr_type == EXPR_ARRAY
|
&& gfc_array_size (vector, &vector_size) == SUCCESS)
|
&& gfc_array_size (vector, &vector_size) == SUCCESS)
|
{
|
{
|
int mask_true_count = 0;
|
int mask_true_count = 0;
|
gfc_constructor *mask_ctor;
|
gfc_constructor *mask_ctor;
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
while (mask_ctor)
|
while (mask_ctor)
|
{
|
{
|
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
|
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
|
{
|
{
|
mask_true_count = 0;
|
mask_true_count = 0;
|
break;
|
break;
|
}
|
}
|
|
|
if (mask_ctor->expr->value.logical)
|
if (mask_ctor->expr->value.logical)
|
mask_true_count++;
|
mask_true_count++;
|
|
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
}
|
}
|
|
|
if (mpz_get_si (vector_size) < mask_true_count)
|
if (mpz_get_si (vector_size) < mask_true_count)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must "
|
"provide at least as many elements as there "
|
"provide at least as many elements as there "
|
"are .TRUE. values in '%s' (%ld/%d)",
|
"are .TRUE. values in '%s' (%ld/%d)",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&vector->where, gfc_current_intrinsic_arg[1]->name,
|
&vector->where, gfc_current_intrinsic_arg[1]->name,
|
mpz_get_si (vector_size), mask_true_count);
|
mpz_get_si (vector_size), mask_true_count);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
mpz_clear (vector_size);
|
mpz_clear (vector_size);
|
}
|
}
|
|
|
if (mask->rank != field->rank && field->rank != 0)
|
if (mask->rank != field->rank && field->rank != 0)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
|
"the same rank as '%s' or be a scalar",
|
"the same rank as '%s' or be a scalar",
|
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
|
&field->where, gfc_current_intrinsic_arg[1]->name);
|
&field->where, gfc_current_intrinsic_arg[1]->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (mask->rank == field->rank)
|
if (mask->rank == field->rank)
|
{
|
{
|
int i;
|
int i;
|
for (i = 0; i < field->rank; i++)
|
for (i = 0; i < field->rank; i++)
|
if (! identical_dimen_shape (mask, i, field, i))
|
if (! identical_dimen_shape (mask, i, field, i))
|
{
|
{
|
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
|
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
|
"must have identical shape.",
|
"must have identical shape.",
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic_arg[2]->name,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&field->where);
|
&field->where);
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
|
gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
|
{
|
{
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
if (same_type_check (x, 0, y, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
|
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
|
if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
|
"with KIND argument at %L",
|
"with KIND argument at %L",
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
gfc_current_intrinsic, &kind->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_trim (gfc_expr *x)
|
gfc_check_trim (gfc_expr *x)
|
{
|
{
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (x, 0) == FAILURE)
|
if (scalar_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ttynam (gfc_expr *unit)
|
gfc_check_ttynam (gfc_expr *unit)
|
{
|
{
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Common check function for the half a dozen intrinsics that have a
|
/* Common check function for the half a dozen intrinsics that have a
|
single real argument. */
|
single real argument. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_x (gfc_expr *x)
|
gfc_check_x (gfc_expr *x)
|
{
|
{
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/************* Check functions for intrinsic subroutines *************/
|
/************* Check functions for intrinsic subroutines *************/
|
|
|
gfc_try
|
gfc_try
|
gfc_check_cpu_time (gfc_expr *time)
|
gfc_check_cpu_time (gfc_expr *time)
|
{
|
{
|
if (scalar_check (time, 0) == FAILURE)
|
if (scalar_check (time, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (time, 0, BT_REAL) == FAILURE)
|
if (type_check (time, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (time, 0, false) == FAILURE)
|
if (variable_check (time, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
|
gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
|
gfc_expr *zone, gfc_expr *values)
|
gfc_expr *zone, gfc_expr *values)
|
{
|
{
|
if (date != NULL)
|
if (date != NULL)
|
{
|
{
|
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (date, 0) == FAILURE)
|
if (scalar_check (date, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (variable_check (date, 0, false) == FAILURE)
|
if (variable_check (date, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (time != NULL)
|
if (time != NULL)
|
{
|
{
|
if (type_check (time, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (time, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (time, 1) == FAILURE)
|
if (scalar_check (time, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (variable_check (time, 1, false) == FAILURE)
|
if (variable_check (time, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (zone != NULL)
|
if (zone != NULL)
|
{
|
{
|
if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
|
if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (zone, 2) == FAILURE)
|
if (scalar_check (zone, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (variable_check (zone, 2, false) == FAILURE)
|
if (variable_check (zone, 2, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (values != NULL)
|
if (values != NULL)
|
{
|
{
|
if (type_check (values, 3, BT_INTEGER) == FAILURE)
|
if (type_check (values, 3, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (array_check (values, 3) == FAILURE)
|
if (array_check (values, 3) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (rank_check (values, 3, 1) == FAILURE)
|
if (rank_check (values, 3, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (variable_check (values, 3, false) == FAILURE)
|
if (variable_check (values, 3, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
|
gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
|
gfc_expr *to, gfc_expr *topos)
|
gfc_expr *to, gfc_expr *topos)
|
{
|
{
|
if (type_check (from, 0, BT_INTEGER) == FAILURE)
|
if (type_check (from, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
|
if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (len, 2, BT_INTEGER) == FAILURE)
|
if (type_check (len, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (same_type_check (from, 0, to, 3) == FAILURE)
|
if (same_type_check (from, 0, to, 3) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (to, 3, false) == FAILURE)
|
if (variable_check (to, 3, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (topos, 4, BT_INTEGER) == FAILURE)
|
if (type_check (topos, 4, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("frompos", frompos) == FAILURE)
|
if (nonnegative_check ("frompos", frompos) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("topos", topos) == FAILURE)
|
if (nonnegative_check ("topos", topos) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (nonnegative_check ("len", len) == FAILURE)
|
if (nonnegative_check ("len", len) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
|
if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
|
== FAILURE)
|
== FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
|
if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_random_number (gfc_expr *harvest)
|
gfc_check_random_number (gfc_expr *harvest)
|
{
|
{
|
if (type_check (harvest, 0, BT_REAL) == FAILURE)
|
if (type_check (harvest, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (harvest, 0, false) == FAILURE)
|
if (variable_check (harvest, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
|
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
|
{
|
{
|
unsigned int nargs = 0, kiss_size;
|
unsigned int nargs = 0, kiss_size;
|
locus *where = NULL;
|
locus *where = NULL;
|
mpz_t put_size, get_size;
|
mpz_t put_size, get_size;
|
bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
|
bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
|
|
|
have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
|
have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
|
|
|
/* Keep the number of bytes in sync with kiss_size in
|
/* Keep the number of bytes in sync with kiss_size in
|
libgfortran/intrinsics/random.c. */
|
libgfortran/intrinsics/random.c. */
|
kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
|
kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
|
|
|
if (size != NULL)
|
if (size != NULL)
|
{
|
{
|
if (size->expr_type != EXPR_VARIABLE
|
if (size->expr_type != EXPR_VARIABLE
|
|| !size->symtree->n.sym->attr.optional)
|
|| !size->symtree->n.sym->attr.optional)
|
nargs++;
|
nargs++;
|
|
|
if (scalar_check (size, 0) == FAILURE)
|
if (scalar_check (size, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (size, 0, BT_INTEGER) == FAILURE)
|
if (type_check (size, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (size, 0, false) == FAILURE)
|
if (variable_check (size, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (put != NULL)
|
if (put != NULL)
|
{
|
{
|
if (put->expr_type != EXPR_VARIABLE
|
if (put->expr_type != EXPR_VARIABLE
|
|| !put->symtree->n.sym->attr.optional)
|
|| !put->symtree->n.sym->attr.optional)
|
{
|
{
|
nargs++;
|
nargs++;
|
where = &put->where;
|
where = &put->where;
|
}
|
}
|
|
|
if (array_check (put, 1) == FAILURE)
|
if (array_check (put, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (put, 1, 1) == FAILURE)
|
if (rank_check (put, 1, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (put, 1, BT_INTEGER) == FAILURE)
|
if (type_check (put, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_array_size (put, &put_size) == SUCCESS
|
if (gfc_array_size (put, &put_size) == SUCCESS
|
&& mpz_get_ui (put_size) < kiss_size)
|
&& mpz_get_ui (put_size) < kiss_size)
|
gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
|
gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
|
"too small (%i/%i)",
|
"too small (%i/%i)",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
where, (int) mpz_get_ui (put_size), kiss_size);
|
where, (int) mpz_get_ui (put_size), kiss_size);
|
}
|
}
|
|
|
if (get != NULL)
|
if (get != NULL)
|
{
|
{
|
if (get->expr_type != EXPR_VARIABLE
|
if (get->expr_type != EXPR_VARIABLE
|
|| !get->symtree->n.sym->attr.optional)
|
|| !get->symtree->n.sym->attr.optional)
|
{
|
{
|
nargs++;
|
nargs++;
|
where = &get->where;
|
where = &get->where;
|
}
|
}
|
|
|
if (array_check (get, 2) == FAILURE)
|
if (array_check (get, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (get, 2, 1) == FAILURE)
|
if (rank_check (get, 2, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (get, 2, BT_INTEGER) == FAILURE)
|
if (type_check (get, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (get, 2, false) == FAILURE)
|
if (variable_check (get, 2, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (gfc_array_size (get, &get_size) == SUCCESS
|
if (gfc_array_size (get, &get_size) == SUCCESS
|
&& mpz_get_ui (get_size) < kiss_size)
|
&& mpz_get_ui (get_size) < kiss_size)
|
gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
|
gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
|
"too small (%i/%i)",
|
"too small (%i/%i)",
|
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
|
where, (int) mpz_get_ui (get_size), kiss_size);
|
where, (int) mpz_get_ui (get_size), kiss_size);
|
}
|
}
|
|
|
/* RANDOM_SEED may not have more than one non-optional argument. */
|
/* RANDOM_SEED may not have more than one non-optional argument. */
|
if (nargs > 1)
|
if (nargs > 1)
|
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
|
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_second_sub (gfc_expr *time)
|
gfc_check_second_sub (gfc_expr *time)
|
{
|
{
|
if (scalar_check (time, 0) == FAILURE)
|
if (scalar_check (time, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (time, 0, BT_REAL) == FAILURE)
|
if (type_check (time, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(time, 0, 4) == FAILURE)
|
if (kind_value_check(time, 0, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
|
/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
|
count, count_rate, and count_max are all optional arguments */
|
count, count_rate, and count_max are all optional arguments */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
|
gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
|
gfc_expr *count_max)
|
gfc_expr *count_max)
|
{
|
{
|
if (count != NULL)
|
if (count != NULL)
|
{
|
{
|
if (scalar_check (count, 0) == FAILURE)
|
if (scalar_check (count, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (count, 0, BT_INTEGER) == FAILURE)
|
if (type_check (count, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (count, 0, false) == FAILURE)
|
if (variable_check (count, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (count_rate != NULL)
|
if (count_rate != NULL)
|
{
|
{
|
if (scalar_check (count_rate, 1) == FAILURE)
|
if (scalar_check (count_rate, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
|
if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (count_rate, 1, false) == FAILURE)
|
if (variable_check (count_rate, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (count != NULL
|
if (count != NULL
|
&& same_type_check (count, 0, count_rate, 1) == FAILURE)
|
&& same_type_check (count, 0, count_rate, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
}
|
}
|
|
|
if (count_max != NULL)
|
if (count_max != NULL)
|
{
|
{
|
if (scalar_check (count_max, 2) == FAILURE)
|
if (scalar_check (count_max, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
|
if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (count_max, 2, false) == FAILURE)
|
if (variable_check (count_max, 2, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (count != NULL
|
if (count != NULL
|
&& same_type_check (count, 0, count_max, 2) == FAILURE)
|
&& same_type_check (count, 0, count_max, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (count_rate != NULL
|
if (count_rate != NULL
|
&& same_type_check (count_rate, 1, count_max, 2) == FAILURE)
|
&& same_type_check (count_rate, 1, count_max, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_irand (gfc_expr *x)
|
gfc_check_irand (gfc_expr *x)
|
{
|
{
|
if (x == NULL)
|
if (x == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (scalar_check (x, 0) == FAILURE)
|
if (scalar_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
|
gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
|
{
|
{
|
if (scalar_check (seconds, 0) == FAILURE)
|
if (scalar_check (seconds, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
|
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (int_or_proc_check (handler, 1) == FAILURE)
|
if (int_or_proc_check (handler, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
|
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_rand (gfc_expr *x)
|
gfc_check_rand (gfc_expr *x)
|
{
|
{
|
if (x == NULL)
|
if (x == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (scalar_check (x, 0) == FAILURE)
|
if (scalar_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_srand (gfc_expr *x)
|
gfc_check_srand (gfc_expr *x)
|
{
|
{
|
if (scalar_check (x, 0) == FAILURE)
|
if (scalar_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
|
gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
|
{
|
{
|
if (scalar_check (time, 0) == FAILURE)
|
if (scalar_check (time, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (type_check (time, 0, BT_INTEGER) == FAILURE)
|
if (type_check (time, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (result, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (result, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_dtime_etime (gfc_expr *x)
|
gfc_check_dtime_etime (gfc_expr *x)
|
{
|
{
|
if (array_check (x, 0) == FAILURE)
|
if (array_check (x, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (x, 0, 1) == FAILURE)
|
if (rank_check (x, 0, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (x, 0, false) == FAILURE)
|
if (variable_check (x, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
if (kind_value_check(x, 0, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
|
gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
|
{
|
{
|
if (array_check (values, 0) == FAILURE)
|
if (array_check (values, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (values, 0, 1) == FAILURE)
|
if (rank_check (values, 0, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (values, 0, false) == FAILURE)
|
if (variable_check (values, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (values, 0, BT_REAL) == FAILURE)
|
if (type_check (values, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(values, 0, 4) == FAILURE)
|
if (kind_value_check(values, 0, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (time, 1) == FAILURE)
|
if (scalar_check (time, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (time, 1, BT_REAL) == FAILURE)
|
if (type_check (time, 1, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(time, 1, 4) == FAILURE)
|
if (kind_value_check(time, 1, 4) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_fdate_sub (gfc_expr *date)
|
gfc_check_fdate_sub (gfc_expr *date)
|
{
|
{
|
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_gerror (gfc_expr *msg)
|
gfc_check_gerror (gfc_expr *msg)
|
{
|
{
|
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
|
gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
|
{
|
{
|
if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (scalar_check (status, 1) == FAILURE)
|
if (scalar_check (status, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
|
gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
|
{
|
{
|
if (type_check (pos, 0, BT_INTEGER) == FAILURE)
|
if (type_check (pos, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (pos->ts.kind > gfc_default_integer_kind)
|
if (pos->ts.kind > gfc_default_integer_kind)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
|
"not wider than the default kind (%d)",
|
"not wider than the default kind (%d)",
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
|
&pos->where, gfc_default_integer_kind);
|
&pos->where, gfc_default_integer_kind);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (type_check (value, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (value, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_getlog (gfc_expr *msg)
|
gfc_check_getlog (gfc_expr *msg)
|
{
|
{
|
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_exit (gfc_expr *status)
|
gfc_check_exit (gfc_expr *status)
|
{
|
{
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 0, BT_INTEGER) == FAILURE)
|
if (type_check (status, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 0) == FAILURE)
|
if (scalar_check (status, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_flush (gfc_expr *unit)
|
gfc_check_flush (gfc_expr *unit)
|
{
|
{
|
if (unit == NULL)
|
if (unit == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_free (gfc_expr *i)
|
gfc_check_free (gfc_expr *i)
|
{
|
{
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
if (type_check (i, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (i, 0) == FAILURE)
|
if (scalar_check (i, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_hostnm (gfc_expr *name)
|
gfc_check_hostnm (gfc_expr *name)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
|
gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (scalar_check (status, 1) == FAILURE)
|
if (scalar_check (status, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_itime_idate (gfc_expr *values)
|
gfc_check_itime_idate (gfc_expr *values)
|
{
|
{
|
if (array_check (values, 0) == FAILURE)
|
if (array_check (values, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (values, 0, 1) == FAILURE)
|
if (rank_check (values, 0, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (values, 0, false) == FAILURE)
|
if (variable_check (values, 0, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (values, 0, BT_INTEGER) == FAILURE)
|
if (type_check (values, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
|
gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
|
{
|
{
|
if (type_check (time, 0, BT_INTEGER) == FAILURE)
|
if (type_check (time, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (time, 0) == FAILURE)
|
if (scalar_check (time, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (array_check (values, 1) == FAILURE)
|
if (array_check (values, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (rank_check (values, 1, 1) == FAILURE)
|
if (rank_check (values, 1, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (variable_check (values, 1, false) == FAILURE)
|
if (variable_check (values, 1, false) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (values, 1, BT_INTEGER) == FAILURE)
|
if (type_check (values, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
|
gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
|
{
|
{
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (name, 1, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 1, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_isatty (gfc_expr *unit)
|
gfc_check_isatty (gfc_expr *unit)
|
{
|
{
|
if (unit == NULL)
|
if (unit == NULL)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (unit, 0) == FAILURE)
|
if (scalar_check (unit, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_isnan (gfc_expr *x)
|
gfc_check_isnan (gfc_expr *x)
|
{
|
{
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
if (type_check (x, 0, BT_REAL) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_perror (gfc_expr *string)
|
gfc_check_perror (gfc_expr *string)
|
{
|
{
|
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_umask (gfc_expr *mask)
|
gfc_check_umask (gfc_expr *mask)
|
{
|
{
|
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
|
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (mask, 0) == FAILURE)
|
if (scalar_check (mask, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
|
gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
|
{
|
{
|
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
|
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (mask, 0) == FAILURE)
|
if (scalar_check (mask, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (old == NULL)
|
if (old == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (scalar_check (old, 1) == FAILURE)
|
if (scalar_check (old, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (old, 1, BT_INTEGER) == FAILURE)
|
if (type_check (old, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_unlink (gfc_expr *name)
|
gfc_check_unlink (gfc_expr *name)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
|
gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
|
{
|
{
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (scalar_check (status, 1) == FAILURE)
|
if (scalar_check (status, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_signal (gfc_expr *number, gfc_expr *handler)
|
gfc_check_signal (gfc_expr *number, gfc_expr *handler)
|
{
|
{
|
if (scalar_check (number, 0) == FAILURE)
|
if (scalar_check (number, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (type_check (number, 0, BT_INTEGER) == FAILURE)
|
if (type_check (number, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (int_or_proc_check (handler, 1) == FAILURE)
|
if (int_or_proc_check (handler, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
|
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
|
gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
|
{
|
{
|
if (scalar_check (number, 0) == FAILURE)
|
if (scalar_check (number, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (type_check (number, 0, BT_INTEGER) == FAILURE)
|
if (type_check (number, 0, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (int_or_proc_check (handler, 1) == FAILURE)
|
if (int_or_proc_check (handler, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
|
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (status == NULL)
|
if (status == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (scalar_check (status, 2) == FAILURE)
|
if (scalar_check (status, 2) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
|
gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
|
{
|
{
|
if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
|
if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
|
if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (status, 1) == FAILURE)
|
if (scalar_check (status, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
|
if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* This is used for the GNU intrinsics AND, OR and XOR. */
|
/* This is used for the GNU intrinsics AND, OR and XOR. */
|
gfc_try
|
gfc_try
|
gfc_check_and (gfc_expr *i, gfc_expr *j)
|
gfc_check_and (gfc_expr *i, gfc_expr *j)
|
{
|
{
|
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
|
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
|
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic, &i->where);
|
gfc_current_intrinsic, &i->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
|
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
|
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
|
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
|
gfc_current_intrinsic, &j->where);
|
gfc_current_intrinsic, &j->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (i->ts.type != j->ts.type)
|
if (i->ts.type != j->ts.type)
|
{
|
{
|
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
|
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
|
"have the same type", gfc_current_intrinsic_arg[0]->name,
|
"have the same type", gfc_current_intrinsic_arg[0]->name,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&j->where);
|
&j->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (scalar_check (i, 0) == FAILURE)
|
if (scalar_check (i, 0) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (j, 1) == FAILURE)
|
if (scalar_check (j, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
|
gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
|
{
|
{
|
if (kind == NULL)
|
if (kind == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (type_check (kind, 1, BT_INTEGER) == FAILURE)
|
if (type_check (kind, 1, BT_INTEGER) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (scalar_check (kind, 1) == FAILURE)
|
if (scalar_check (kind, 1) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (kind->expr_type != EXPR_CONSTANT)
|
if (kind->expr_type != EXPR_CONSTANT)
|
{
|
{
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
|
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
|
&kind->where);
|
&kind->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
