/* Check functions
- Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* These functions check to see if an argument list is compatible with
#include "intrinsic.h"
+/* Make sure an expression is a scalar. */
+
+static try
+scalar_check (gfc_expr *e, int n)
+{
+ if (e->rank == 0)
+ return SUCCESS;
+
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+
+ return FAILURE;
+}
+
+
/* Check the type of an expression. */
static try
-type_check (gfc_expr * e, int n, bt type)
+type_check (gfc_expr *e, int n, bt type)
{
if (e->ts.type == type)
return SUCCESS;
/* Check that the expression is a numeric type. */
static try
-numeric_check (gfc_expr * e, int n)
+numeric_check (gfc_expr *e, int n)
{
if (gfc_numeric_ts (&e->ts))
return SUCCESS;
+ /* If the expression has not got a type, check if its namespace can
+ offer a default type. */
+ if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
+ && e->symtree->n.sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (e->symtree->n.sym, 0,
+ e->symtree->n.sym->ns) == SUCCESS
+ && gfc_numeric_ts (&e->symtree->n.sym->ts))
+ {
+ e->ts = e->symtree->n.sym->ts;
+ return SUCCESS;
+ }
+
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
/* Check that an expression is integer or real. */
static 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)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or REAL", gfc_current_intrinsic_arg[n],
+ gfc_current_intrinsic, &e->where);
return FAILURE;
}
/* Check that an expression is real or complex. */
static 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)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
+ "or COMPLEX", gfc_current_intrinsic_arg[n],
+ gfc_current_intrinsic, &e->where);
return FAILURE;
}
and that it specifies a valid kind for that type. */
static try
-kind_check (gfc_expr * k, int n, bt type)
+kind_check (gfc_expr *k, int n, bt type)
{
int kind;
if (type_check (k, n, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (scalar_check (k, n) == FAILURE)
+ return FAILURE;
+
if (k->expr_type != EXPR_CONSTANT)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be a constant",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ &k->where);
return FAILURE;
}
/* Make sure the expression is a double precision real. */
static try
-double_check (gfc_expr * d, int n)
+double_check (gfc_expr *d, int n)
{
if (type_check (d, n, BT_REAL) == FAILURE)
return FAILURE;
if (d->ts.kind != gfc_default_double_kind)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be double precision",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
+ "precision", gfc_current_intrinsic_arg[n],
+ gfc_current_intrinsic, &d->where);
return FAILURE;
}
/* Make sure the expression is a logical array. */
static try
-logical_array_check (gfc_expr * array, int n)
+logical_array_check (gfc_expr *array, int n)
{
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be a logical array",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
+ "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ &array->where);
return FAILURE;
}
/* Make sure an expression is an array. */
static try
-array_check (gfc_expr * e, int n)
+array_check (gfc_expr *e, int n)
{
if (e->rank != 0)
return SUCCESS;
}
-/* Make sure an expression is a scalar. */
-
-static try
-scalar_check (gfc_expr * e, int n)
-{
- if (e->rank == 0)
- return SUCCESS;
-
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
-
- return FAILURE;
-}
-
-
-/* Make sure two expression have the same type. */
+/* Make sure two expressions have the same type. */
static try
-same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
+same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
{
if (gfc_compare_types (&e->ts, &f->ts))
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
"and kind as '%s'", gfc_current_intrinsic_arg[m],
gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
+
return FAILURE;
}
/* Make sure that an expression has a certain (nonzero) rank. */
static try
-rank_check (gfc_expr * e, int n, int rank)
+rank_check (gfc_expr *e, int n, int rank)
{
if (e->rank == rank)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where, rank);
+
return FAILURE;
}
/* Make sure a variable expression is not an optional dummy argument. */
static try
-nonoptional_check (gfc_expr * e, int n)
+nonoptional_check (gfc_expr *e, int n)
{
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where);
-
}
/* TODO: Recursive check on nonoptional variables? */
/* Check that an expression has a particular kind. */
static try
-kind_value_check (gfc_expr * e, int n, int k)
+kind_value_check (gfc_expr *e, int n, int k)
{
if (e->ts.kind == k)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
&e->where, k);
+
return FAILURE;
}
/* Make sure an expression is a variable. */
static try
-variable_check (gfc_expr * e, int n)
+variable_check (gfc_expr *e, int n)
{
if ((e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER)
/* Check the common DIM parameter for correctness. */
static try
-dim_check (gfc_expr * dim, int n, int optional)
+dim_check (gfc_expr *dim, int n, bool optional)
{
- if (optional)
- {
- if (dim == NULL)
- return SUCCESS;
-
- if (nonoptional_check (dim, n) == FAILURE)
- return FAILURE;
-
- return SUCCESS;
- }
-
if (dim == NULL)
- {
- gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
- gfc_current_intrinsic, gfc_current_intrinsic_where);
- return FAILURE;
- }
+ return SUCCESS;
if (type_check (dim, n, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (dim, n) == FAILURE)
return FAILURE;
+ if (!optional && nonoptional_check (dim, n) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
for assumed size arrays. */
static 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;
int rank;
ar = gfc_find_array_ref (array);
rank = array->rank;
- if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
+ if (ar->as->type == AS_ASSUMED_SIZE
+ && !allow_assumed
+ && ar->type != AR_ELEMENT
+ && ar->type != AR_SECTION)
rank--;
if (mpz_cmp_ui (dim->value.integer, 1) < 0
}
+/* Compare the size of a along dimension ai with the size of b along
+ dimension bi, returning 0 if they are known not to be identical,
+ and 1 if they are identical, or if this cannot be determined. */
+
+static int
+identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
+{
+ mpz_t a_size, b_size;
+ int ret;
+
+ gcc_assert (a->rank > ai);
+ gcc_assert (b->rank > bi);
+
+ ret = 1;
+
+ if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
+ {
+ if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
+ {
+ if (mpz_cmp (a_size, b_size) != 0)
+ ret = 0;
+
+ mpz_clear (b_size);
+ }
+ mpz_clear (a_size);
+ }
+ return ret;
+}
+
+
+/* Check whether two character expressions have the same length;
+ returns SUCCESS if they have or if the length cannot be determined. */
+
+static try
+check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
+{
+ long len_a, len_b;
+ len_a = len_b = -1;
+
+ if (a->ts.cl && a->ts.cl->length
+ && a->ts.cl->length->expr_type == EXPR_CONSTANT)
+ len_a = mpz_get_si (a->ts.cl->length->value.integer);
+ else if (a->expr_type == EXPR_CONSTANT
+ && (a->ts.cl == NULL || a->ts.cl->length == NULL))
+ len_a = a->value.character.length;
+ else
+ return SUCCESS;
+
+ if (b->ts.cl && b->ts.cl->length
+ && b->ts.cl->length->expr_type == EXPR_CONSTANT)
+ len_b = mpz_get_si (b->ts.cl->length->value.integer);
+ else if (b->expr_type == EXPR_CONSTANT
+ && (b->ts.cl == NULL || b->ts.cl->length == NULL))
+ len_b = b->value.character.length;
+ else
+ return SUCCESS;
+
+ if (len_a == len_b)
+ return SUCCESS;
+
+ gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
+ "at %L", len_a, len_b, name, &a->where);
+ return FAILURE;
+}
+
+
/***** Check functions *****/
/* Check subroutine suitable for intrinsics taking a real argument and
a kind argument for the result. */
static try
-check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
+check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
{
if (type_check (a, 0, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
+
/* Check subroutine suitable for ceiling, floor and nint. */
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);
}
+
/* Check subroutine suitable for aint, anint. */
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);
}
+
try
-gfc_check_abs (gfc_expr * a)
+gfc_check_abs (gfc_expr *a)
{
if (numeric_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
+
try
-gfc_check_achar (gfc_expr * a)
+gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
-
if (type_check (a, 0, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
try
-gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
+gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
{
- if (logical_array_check (mask, 0) == FAILURE)
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE
+ || scalar_check (name, 0) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (type_check (mode, 1, BT_CHARACTER) == FAILURE
+ || scalar_check (mode, 1) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_allocated (gfc_expr * array)
+gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
{
- if (variable_check (array, 0) == FAILURE)
+ if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
- if (array_check (array, 0) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_allocated (gfc_expr *array)
+{
+ symbol_attribute attr;
+
+ if (variable_check (array, 0) == FAILURE)
return FAILURE;
- if (!array->symtree->n.sym->attr.allocatable)
+ attr = gfc_variable_attr (array, NULL);
+ if (!attr.allocatable)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
return FAILURE;
}
+ if (array_check (array, 0) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
integer and the second argument must be the same as the first. */
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)
return FAILURE;
if (a->ts.type != p->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
- "have the same type", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
- &p->where);
+ "have the same type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &p->where);
return FAILURE;
}
if (a->ts.kind != p->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
- &p->where) == FAILURE)
+ &p->where) == FAILURE)
return FAILURE;
}
try
-gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
+gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
+{
+ if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
symbol_attribute attr;
int i;
try t;
+ locus *where;
+
+ where = &pointer->where;
if (pointer->expr_type == EXPR_VARIABLE)
attr = gfc_variable_attr (pointer, NULL);
else if (pointer->expr_type == EXPR_FUNCTION)
attr = pointer->symtree->n.sym->attr;
+ else if (pointer->expr_type == EXPR_NULL)
+ goto null_arg;
else
gcc_assert (0); /* Pointer must be a variable or a function. */
if (target == NULL)
return SUCCESS;
+ where = &target->where;
if (target->expr_type == EXPR_NULL)
- {
- gfc_error ("NULL pointer at %L is not permitted as actual argument "
- "of '%s' intrinsic function",
- &target->where, gfc_current_intrinsic);
- return FAILURE;
- }
+ goto null_arg;
if (target->expr_type == EXPR_VARIABLE)
attr = gfc_variable_attr (target, NULL);
else if (target->expr_type == EXPR_FUNCTION)
attr = target->symtree->n.sym->attr;
else
- gcc_assert (0); /* Target must be a variable or a function. */
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
+ "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &target->where);
+ return FAILURE;
+ }
if (!attr.pointer && !attr.target)
{
if (target->rank > 0)
{
for (i = 0; i < target->rank; i++)
- if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
- {
- gfc_error ("Array section with a vector subscript at %L shall not "
+ if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ {
+ gfc_error ("Array section with a vector subscript at %L shall not "
"be the target of a pointer",
- &target->where);
- t = FAILURE;
- break;
- }
+ &target->where);
+ t = FAILURE;
+ break;
+ }
}
return t;
+
+null_arg:
+
+ gfc_error ("NULL pointer at %L is not permitted as actual argument "
+ "of '%s' intrinsic function", where, gfc_current_intrinsic);
+ return FAILURE;
+
}
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)
return FAILURE;
/* BESJN and BESYN functions. */
try
-gfc_check_besn (gfc_expr * n, gfc_expr * x)
+gfc_check_besn (gfc_expr *n, gfc_expr *x)
{
- if (scalar_check (n, 0) == FAILURE)
- return FAILURE;
-
if (type_check (n, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (scalar_check (x, 1) == FAILURE)
- return FAILURE;
-
if (type_check (x, 1, BT_REAL) == FAILURE)
return FAILURE;
try
-gfc_check_btest (gfc_expr * i, gfc_expr * pos)
+gfc_check_btest (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_chdir (gfc_expr * dir)
+gfc_check_chdir (gfc_expr *dir)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
+gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
+{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
+{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 2) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
try
-gfc_check_complex (gfc_expr * x, gfc_expr * y)
+gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
- gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or REAL", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
return FAILURE;
}
if (scalar_check (x, 0) == FAILURE)
if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or REAL", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
return FAILURE;
}
if (scalar_check (y, 1) == FAILURE)
try
-gfc_check_count (gfc_expr * mask, gfc_expr * dim)
+gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_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)
return FAILURE;
+ if (type_check (shift, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
if (array->rank == 1)
{
if (scalar_check (shift, 1) == FAILURE)
/* TODO: more requirements on shift parameter. */
}
- if (dim_check (dim, 2, 1) == FAILURE)
+ if (dim_check (dim, 2, true) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_ctime (gfc_expr * time)
+gfc_check_ctime (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
}
+try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
+{
+ if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
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)
return FAILURE;
try
-gfc_check_dble (gfc_expr * x)
+gfc_check_dble (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
try
-gfc_check_digits (gfc_expr * x)
+gfc_check_digits (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
try
-gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
+gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
{
switch (vector_a->ts.type)
{
if (rank_check (vector_b, 1, 1) == FAILURE)
return FAILURE;
+ if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
+ {
+ gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
+ "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], &vector_a->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_dprod (gfc_expr *x, gfc_expr *y)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE
+ || type_check (y, 1, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (x->ts.kind != gfc_default_real_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ "real", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
+ return FAILURE;
+ }
+
+ if (y->ts.kind != gfc_default_real_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ "real", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
try
-gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
- gfc_expr * dim)
+gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
+ gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
/* TODO: more restrictions on boundary. */
}
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 4, true) == FAILURE)
return FAILURE;
return SUCCESS;
/* A single complex argument. */
try
-gfc_check_fn_c (gfc_expr * a)
+gfc_check_fn_c (gfc_expr *a)
{
if (type_check (a, 0, BT_COMPLEX) == FAILURE)
return FAILURE;
/* A single real argument. */
try
-gfc_check_fn_r (gfc_expr * a)
+gfc_check_fn_r (gfc_expr *a)
{
if (type_check (a, 0, BT_REAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
-
-/* A single real or complex argument. */
+/* A single double argument. */
try
-gfc_check_fn_rc (gfc_expr * a)
+gfc_check_fn_d (gfc_expr *a)
{
- if (real_or_complex_check (a, 0) == FAILURE)
+ if (double_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
+/* A single real or complex argument. */
try
-gfc_check_fnum (gfc_expr * unit)
+gfc_check_fn_rc (gfc_expr *a)
{
- if (type_check (unit, 0, BT_INTEGER) == FAILURE)
- return FAILURE;
-
- if (scalar_check (unit, 0) == FAILURE)
+ if (real_or_complex_check (a, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/* This is used for the g77 one-argument Bessel functions, and the
- error function. */
-
try
-gfc_check_g77_math1 (gfc_expr * x)
+gfc_check_fnum (gfc_expr *unit)
{
- if (scalar_check (x, 0) == FAILURE)
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (type_check (x, 0, BT_REAL) == FAILURE)
+ if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
return SUCCESS;
try
-gfc_check_huge (gfc_expr * x)
+gfc_check_huge (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
/* Check that the single argument is an integer. */
try
-gfc_check_i (gfc_expr * i)
+gfc_check_i (gfc_expr *i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_iand (gfc_expr * i, gfc_expr * j)
+gfc_check_iand (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (i->ts.kind != j->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
- &i->where) == FAILURE)
+ &i->where) == FAILURE)
return FAILURE;
}
try
-gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
+gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
+gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_ichar_iachar (gfc_expr * c)
+gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
{
int i;
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
{
gfc_expr *start;
if (!ref)
{
- /* Check that the argument is length one. Non-constant lengths
- can't be checked here, so assume thay are ok. */
+ /* Check that the argument is length one. Non-constant lengths
+ can't be checked here, so assume they are ok. */
if (c->ts.cl && c->ts.cl->length)
{
/* If we already have a length for this expression then use it. */
return SUCCESS;
i = mpz_get_si (end->value.integer) + 1
- - mpz_get_si (start->value.integer);
+ - mpz_get_si (start->value.integer);
}
}
else
try
-gfc_check_idnint (gfc_expr * a)
+gfc_check_idnint (gfc_expr *a)
{
if (double_check (a, 0) == FAILURE)
return FAILURE;
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)
return FAILURE;
if (i->ts.kind != j->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
- &i->where) == FAILURE)
+ &i->where) == FAILURE)
return FAILURE;
}
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)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
-
if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
if (string->ts.kind != substring->ts.kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
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)
return FAILURE;
- if (kind != NULL)
- {
- if (type_check (kind, 1, BT_INTEGER) == FAILURE)
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (scalar_check (kind, 1) == FAILURE)
- return FAILURE;
- }
+ return SUCCESS;
+}
+
+
+try
+gfc_check_intconv (gfc_expr *x)
+{
+ if (numeric_check (x, 0) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
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)
return FAILURE;
if (i->ts.kind != j->ts.kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
- &i->where) == FAILURE)
- return FAILURE;
+ &i->where) == FAILURE)
+ return FAILURE;
}
return SUCCESS;
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
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
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
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
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)
return FAILURE;
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)
return FAILURE;
+ if (scalar_check (pid, 0) == FAILURE)
+ return FAILURE;
+
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (scalar_check (sig, 1) == FAILURE)
+ return FAILURE;
+
if (status == NULL)
return SUCCESS;
try
-gfc_check_kind (gfc_expr * x)
+gfc_check_kind (gfc_expr *x)
{
if (x->ts.type == BT_DERIVED)
{
try
-gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
+gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 1) == FAILURE)
return FAILURE;
}
+
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
+{
+ if (type_check (s, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
try
-gfc_check_link (gfc_expr * path1, gfc_expr * path2)
+gfc_check_link (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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)
return FAILURE;
return SUCCESS;
}
+
try
gfc_check_loc (gfc_expr *expr)
{
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)
return FAILURE;
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)
return FAILURE;
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)
return FAILURE;
/* Min/max family. */
static try
-min_max_args (gfc_actual_arglist * arg)
+min_max_args (gfc_actual_arglist *arg)
{
if (arg == NULL || arg->next == NULL)
{
static try
-check_rest (bt type, int kind, gfc_actual_arglist * arg)
+check_rest (bt type, int kind, gfc_actual_arglist *arglist)
{
+ gfc_actual_arglist *arg, *tmp;
+
gfc_expr *x;
- int n;
+ int m, n;
- if (min_max_args (arg) == FAILURE)
+ if (min_max_args (arglist) == FAILURE)
return FAILURE;
- n = 1;
-
- for (; arg; arg = arg->next, n++)
+ for (arg = arglist, n=1; arg; arg = arg->next, n++)
{
x = arg->expr;
if (x->ts.type != type || x->ts.kind != kind)
{
- if (x->ts.type == type)
- {
- if (gfc_notify_std (GFC_STD_GNU,
- "Extension: Different type kinds at %L", &x->where)
- == FAILURE)
+ if (x->ts.type == type)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
+ "kinds at %L", &x->where) == FAILURE)
return FAILURE;
- }
- else
- {
- gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
- n, gfc_current_intrinsic, &x->where,
- gfc_basic_typename (type), kind);
- return FAILURE;
- }
+ }
+ else
+ {
+ gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
+ "%s(%d)", n, gfc_current_intrinsic, &x->where,
+ gfc_basic_typename (type), kind);
+ return FAILURE;
+ }
+ }
+
+ for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
+ {
+ char buffer[80];
+ snprintf (buffer, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
+ m, n, gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, tmp->expr, x) == FAILURE)
+ return FAILURE;
}
}
try
-gfc_check_min_max (gfc_actual_arglist * arg)
+gfc_check_min_max (gfc_actual_arglist *arg)
{
gfc_expr *x;
x = arg->expr;
- if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+ if (x->ts.type == BT_CHARACTER)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with CHARACTER argument at %L",
+ gfc_current_intrinsic, &x->where) == FAILURE)
+ return FAILURE;
+ }
+ else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
- gfc_error
- ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
- gfc_current_intrinsic, &x->where);
+ gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+ "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
return FAILURE;
}
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);
}
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);
}
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);
}
+
/* End of min/max family. */
try
-gfc_check_malloc (gfc_expr * size)
+gfc_check_malloc (gfc_expr *size)
{
if (type_check (size, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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_b->ts))
{
case 1:
if (rank_check (matrix_b, 1, 2) == FAILURE)
return FAILURE;
+ /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
+ if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
+ {
+ gfc_error ("Different shape on dimension 1 for arguments '%s' "
+ "and '%s' at %L for intrinsic matmul",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], &matrix_a->where);
+ return FAILURE;
+ }
break;
case 2:
- if (matrix_b->rank == 2)
- break;
- if (rank_check (matrix_b, 1, 1) == FAILURE)
- return FAILURE;
+ if (matrix_b->rank != 2)
+ {
+ if (rank_check (matrix_b, 1, 1) == FAILURE)
+ return FAILURE;
+ }
+ /* matrix_b has rank 1 or 2 here. Common check for the cases
+ - matrix_a has shape (n,m) and matrix_b has shape (m, k)
+ - matrix_a has shape (n,m) and matrix_b has shape (m). */
+ if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
+ {
+ gfc_error ("Different shape on dimension 2 for argument '%s' and "
+ "dimension 1 for argument '%s' at %L for intrinsic "
+ "matmul", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], &matrix_a->where);
+ return FAILURE;
+ }
break;
default:
The possibilities for the occupation of the second and third
parameters are:
- Arg #2 Arg #3
- NULL NULL
- DIM NULL
- MASK NULL
- NULL MASK minloc(array, mask=m)
- DIM MASK
+ Arg #2 Arg #3
+ NULL NULL
+ DIM NULL
+ MASK NULL
+ NULL MASK minloc(array, mask=m)
+ DIM MASK
I.e. in the case of minloc(array,mask), mask will be in the second
position of the argument list and we'll have to fix that up. */
try
-gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
+gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
{
gfc_expr *a, *m, *d;
a = ap->expr;
- if (int_or_real_check (a, 0) == FAILURE
- || array_check (a, 0) == FAILURE)
+ if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
return FAILURE;
d = ap->next->expr;
{
m = d;
d = NULL;
-
ap->next->expr = NULL;
ap->next->next->expr = m;
}
- if (d != NULL
- && (scalar_check (d, 1) == FAILURE
- || type_check (d, 1, BT_INTEGER) == FAILURE))
+ if (d && dim_check (d, 1, false) == FAILURE)
+ return FAILURE;
+
+ if (d && dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (m != NULL)
+ {
+ char buffer[80];
+ snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, a, m) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
difference is that MINLOC/MAXLOC take an additional KIND argument.
The possibilities are:
- Arg #2 Arg #3
- NULL NULL
- DIM NULL
- MASK NULL
- NULL MASK minval(array, mask=m)
- DIM MASK
+ Arg #2 Arg #3
+ NULL NULL
+ DIM NULL
+ MASK NULL
+ NULL MASK minval(array, mask=m)
+ DIM MASK
I.e. in the case of minval(array,mask), mask will be in the second
position of the argument list and we'll have to fix that up. */
static try
-check_reduction (gfc_actual_arglist * ap)
+check_reduction (gfc_actual_arglist *ap)
{
- gfc_expr *m, *d;
+ gfc_expr *a, *m, *d;
+ a = ap->expr;
d = ap->next->expr;
m = ap->next->next->expr;
{
m = d;
d = NULL;
-
ap->next->expr = NULL;
ap->next->next->expr = m;
}
- if (d != NULL
- && (scalar_check (d, 1) == FAILURE
- || type_check (d, 1, BT_INTEGER) == FAILURE))
+ if (d && dim_check (d, 1, false) == FAILURE)
+ return FAILURE;
+
+ if (d && dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (m != NULL)
+ {
+ char buffer[80];
+ snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, a, m) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
try
-gfc_check_minval_maxval (gfc_actual_arglist * ap)
+gfc_check_minval_maxval (gfc_actual_arglist *ap)
{
if (int_or_real_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
try
-gfc_check_product_sum (gfc_actual_arglist * ap)
+gfc_check_product_sum (gfc_actual_arglist *ap)
{
if (numeric_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
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)
return FAILURE;
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (tsource->ts.type == BT_CHARACTER)
+ return check_same_strlen (tsource, fsource, "MERGE");
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
+{
+ symbol_attribute attr;
+
+ if (variable_check (from, 0) == FAILURE)
+ return FAILURE;
+
+ if (array_check (from, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (from, NULL);
+ if (!attr.allocatable)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &from->where);
+ return FAILURE;
+ }
+
+ if (variable_check (to, 0) == FAILURE)
+ return FAILURE;
+
+ if (array_check (to, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (to, NULL);
+ if (!attr.allocatable)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &to->where);
+ return FAILURE;
+ }
+
+ if (same_type_check (from, 0, to, 1) == FAILURE)
+ return FAILURE;
+
+ if (to->rank != from->rank)
+ {
+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
+ "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &to->where, from->rank, to->rank);
+ return FAILURE;
+ }
+
+ if (to->ts.kind != from->ts.kind)
+ {
+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
+ "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &to->where, from->ts.kind, to->ts.kind);
+ return FAILURE;
+ }
+
return SUCCESS;
}
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)
return FAILURE;
try
-gfc_check_null (gfc_expr * mold)
+gfc_check_new_line (gfc_expr *a)
+{
+ if (type_check (a, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_null (gfc_expr *mold)
{
symbol_attribute attr;
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)
{
+ char buffer[80];
+
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
return FAILURE;
- if (mask->rank != 0 && mask->rank != array->rank)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
- "with '%s' argument", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic, &array->where,
- gfc_current_intrinsic_arg[1]);
- return FAILURE;
- }
+ snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, array, mask) == FAILURE)
+ return FAILURE;
if (vector != NULL)
{
try
-gfc_check_precision (gfc_expr * x)
+gfc_check_precision (gfc_expr *x)
{
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
{
try
-gfc_check_present (gfc_expr * a)
+gfc_check_present (gfc_expr *a)
{
gfc_symbol *sym;
return FAILURE;
}
+ /* 13.14.82 PRESENT(A)
+ ......
+ Argument. A shall be the name of an optional dummy argument that is
+ accessible in the subprogram in which the PRESENT function reference
+ appears... */
+
+ if (a->ref != NULL
+ && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
+ && a->ref->u.ar.type == AR_FULL))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
+ "subobject of '%s'", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where, sym->name);
+ return FAILURE;
+ }
+
return SUCCESS;
}
try
-gfc_check_radix (gfc_expr * x)
+gfc_check_radix (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
return FAILURE;
try
-gfc_check_range (gfc_expr * x)
+gfc_check_range (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
/* real, float, sngl. */
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)
return FAILURE;
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)
return FAILURE;
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)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
- gfc_expr * pad, gfc_expr * order)
+gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
+ gfc_expr *pad, gfc_expr *order)
{
mpz_t size;
+ mpz_t nelems;
int m;
if (array_check (source, 0) == FAILURE)
if (order != NULL && array_check (order, 3) == FAILURE)
return FAILURE;
+ if (pad == NULL && shape->expr_type == EXPR_ARRAY
+ && gfc_is_constant_expr (shape)
+ && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
+ && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
+ {
+ /* Check the match in size between source and destination. */
+ if (gfc_array_size (source, &nelems) == SUCCESS)
+ {
+ gfc_constructor *c;
+ bool test;
+
+ c = shape->value.constructor;
+ mpz_init_set_ui (size, 1);
+ for (; c; c = c->next)
+ mpz_mul (size, size, c->expr->value.integer);
+
+ test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
+ mpz_clear (nelems);
+ mpz_clear (size);
+
+ if (test)
+ {
+ gfc_error ("Without padding, there are not enough elements "
+ "in the intrinsic RESHAPE source at %L to match "
+ "the shape", &source->where);
+ return FAILURE;
+ }
+ }
+ }
+
return SUCCESS;
}
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)
return FAILURE;
try
-gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
+gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
if (same_type_check (x, 0, y, 1) == FAILURE)
return FAILURE;
try
-gfc_check_secnds (gfc_expr * r)
+gfc_check_secnds (gfc_expr *r)
{
-
if (type_check (r, 0, BT_REAL) == FAILURE)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
+gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
{
if (p == NULL && r == NULL)
{
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)
return FAILURE;
try
-gfc_check_shape (gfc_expr * source)
+gfc_check_shape (gfc_expr *source)
{
gfc_array_ref *ar;
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)
return FAILURE;
try
-gfc_check_size (gfc_expr * array, gfc_expr * dim)
+gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
- if (type_check (dim, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
-
- if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
+ if (dim_check (dim, 1, true) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 0) == FAILURE)
return FAILURE;
}
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_sizeof (gfc_expr *arg __attribute__((unused)))
+{
return SUCCESS;
}
try
-gfc_check_sleep_sub (gfc_expr * seconds)
+gfc_check_sleep_sub (gfc_expr *seconds)
{
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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)
{
return FAILURE;
}
- if (dim_check (dim, 1, 0) == FAILURE)
+ if (dim == NULL)
+ return FAILURE;
+
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
functions). */
+
try
-gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
+gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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);
}
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)
return FAILURE;
try
-gfc_check_fgetput (gfc_expr * c)
+gfc_check_fgetput (gfc_expr *c)
{
return gfc_check_fgetput_sub (c, NULL);
}
try
-gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
+gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
+{
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (offset, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (offset, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (whence, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (whence, 2) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check (status, 3, 4) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 3) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+
+try
+gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
+gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_ftell (gfc_expr * unit)
+gfc_check_ftell (gfc_expr *unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
return FAILURE;
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)
return FAILURE;
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)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
- gfc_expr * mold ATTRIBUTE_UNUSED,
- gfc_expr * size)
+gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
+ gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
{
+ if (mold->ts.type == BT_HOLLERITH)
+ {
+ gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
+ &mold->where, gfc_basic_typename (BT_HOLLERITH));
+ return FAILURE;
+ }
+
if (size != NULL)
{
if (type_check (size, 2, BT_INTEGER) == FAILURE)
try
-gfc_check_transpose (gfc_expr * matrix)
+gfc_check_transpose (gfc_expr *matrix)
{
if (rank_check (matrix, 0, 2) == FAILURE)
return FAILURE;
try
-gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
+gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 0) == FAILURE)
return FAILURE;
}
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
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)
{
if (rank_check (vector, 0, 1) == FAILURE)
return FAILURE;
try
-gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
+gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
try
-gfc_check_trim (gfc_expr * x)
+gfc_check_trim (gfc_expr *x)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_ttynam (gfc_expr * unit)
+gfc_check_ttynam (gfc_expr *unit)
{
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
single real argument. */
try
-gfc_check_x (gfc_expr * x)
+gfc_check_x (gfc_expr *x)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
return FAILURE;
/************* Check functions for intrinsic subroutines *************/
try
-gfc_check_cpu_time (gfc_expr * time)
+gfc_check_cpu_time (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
try
-gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
- gfc_expr * zone, gfc_expr * values)
+gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
+ gfc_expr *zone, gfc_expr *values)
{
if (date != NULL)
{
try
-gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
- gfc_expr * to, gfc_expr * topos)
+gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
+ gfc_expr *to, gfc_expr *topos)
{
if (type_check (from, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_random_number (gfc_expr * harvest)
+gfc_check_random_number (gfc_expr *harvest)
{
if (type_check (harvest, 0, BT_REAL) == FAILURE)
return FAILURE;
try
-gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
+gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
+ unsigned int nargs = 0;
+ locus *where = NULL;
+
if (size != NULL)
{
+ if (size->expr_type != EXPR_VARIABLE
+ || !size->symtree->n.sym->attr.optional)
+ nargs++;
+
if (scalar_check (size, 0) == FAILURE)
return FAILURE;
if (put != NULL)
{
-
- if (size != NULL)
- gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
- &put->where);
+ if (put->expr_type != EXPR_VARIABLE
+ || !put->symtree->n.sym->attr.optional)
+ {
+ nargs++;
+ where = &put->where;
+ }
if (array_check (put, 1) == FAILURE)
return FAILURE;
if (get != NULL)
{
-
- if (size != NULL || put != NULL)
- gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
- &get->where);
+ if (get->expr_type != EXPR_VARIABLE
+ || !get->symtree->n.sym->attr.optional)
+ {
+ nargs++;
+ where = &get->where;
+ }
if (array_check (get, 2) == FAILURE)
return FAILURE;
return FAILURE;
}
+ /* RANDOM_SEED may not have more than one non-optional argument. */
+ if (nargs > 1)
+ gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
+
return SUCCESS;
}
+
try
-gfc_check_second_sub (gfc_expr * time)
+gfc_check_second_sub (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
count, count_rate, and count_max are all optional arguments */
try
-gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
- gfc_expr * count_max)
+gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
+ gfc_expr *count_max)
{
if (count != NULL)
{
if (scalar_check (count, 0) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (type_check (count, 0, BT_INTEGER) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (variable_check (count, 0) == FAILURE)
- return FAILURE;
+ return FAILURE;
}
if (count_rate != NULL)
{
if (scalar_check (count_rate, 1) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (variable_check (count_rate, 1) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (count != NULL
&& same_type_check (count, 0, count_rate, 1) == FAILURE)
- return FAILURE;
+ return FAILURE;
}
if (count_max != NULL)
{
if (scalar_check (count_max, 2) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (variable_check (count_max, 2) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (count != NULL
&& same_type_check (count, 0, count_max, 2) == FAILURE)
- return FAILURE;
+ return FAILURE;
if (count_rate != NULL
- && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
- return FAILURE;
+ && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
+ return FAILURE;
}
return SUCCESS;
}
+
try
-gfc_check_irand (gfc_expr * x)
+gfc_check_irand (gfc_expr *x)
{
if (x == NULL)
return SUCCESS;
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)
return FAILURE;
if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or PROCEDURE", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &handler->where);
return FAILURE;
}
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
try
-gfc_check_rand (gfc_expr * x)
+gfc_check_rand (gfc_expr *x)
{
if (x == NULL)
return SUCCESS;
return SUCCESS;
}
+
try
-gfc_check_srand (gfc_expr * x)
+gfc_check_srand (gfc_expr *x)
{
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
+
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)
return FAILURE;
return SUCCESS;
}
+
try
-gfc_check_etime (gfc_expr * x)
+gfc_check_dtime_etime (gfc_expr *x)
{
if (array_check (x, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
+
try
-gfc_check_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)
return FAILURE;
try
-gfc_check_fdate_sub (gfc_expr * date)
+gfc_check_fdate_sub (gfc_expr *date)
{
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_gerror (gfc_expr * msg)
+gfc_check_gerror (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_getlog (gfc_expr * msg)
+gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
+{
+ if (type_check (pos, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (pos->ts.kind > gfc_default_integer_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+ "not wider than the default kind (%d)",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &pos->where, gfc_default_integer_kind);
+ return FAILURE;
+ }
+
+ if (type_check (value, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_getlog (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_exit (gfc_expr * status)
+gfc_check_exit (gfc_expr *status)
{
if (status == NULL)
return SUCCESS;
try
-gfc_check_flush (gfc_expr * unit)
+gfc_check_flush (gfc_expr *unit)
{
if (unit == NULL)
return SUCCESS;
try
-gfc_check_free (gfc_expr * i)
+gfc_check_free (gfc_expr *i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_hostnm (gfc_expr * name)
+gfc_check_hostnm (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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)
return FAILURE;
try
-gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
+gfc_check_itime_idate (gfc_expr *values)
+{
+ if (array_check (values, 0) == FAILURE)
+ return FAILURE;
+
+ if (rank_check (values, 0, 1) == FAILURE)
+ return FAILURE;
+
+ if (variable_check (values, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (values, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
+{
+ if (type_check (time, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (time, 0) == FAILURE)
+ return FAILURE;
+
+ if (array_check (values, 1) == FAILURE)
+ return FAILURE;
+
+ if (rank_check (values, 1, 1) == FAILURE)
+ return FAILURE;
+
+ if (variable_check (values, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (values, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
{
if (scalar_check (unit, 0) == FAILURE)
return FAILURE;
try
-gfc_check_isatty (gfc_expr * unit)
+gfc_check_isatty (gfc_expr *unit)
{
if (unit == NULL)
return FAILURE;
try
-gfc_check_perror (gfc_expr * string)
+gfc_check_isnan (gfc_expr *x)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_perror (gfc_expr *string)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_umask (gfc_expr * mask)
+gfc_check_umask (gfc_expr *mask)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
+gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
return FAILURE;
try
-gfc_check_unlink (gfc_expr * name)
+gfc_check_unlink (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
try
-gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
+gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
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)
return FAILURE;
if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or PROCEDURE", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &handler->where);
return FAILURE;
}
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)
return FAILURE;
if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or PROCEDURE", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &handler->where);
return FAILURE;
}
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)
return FAILURE;
/* This is used for the GNU intrinsics AND, OR and XOR. */
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)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
- gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or LOGICAL", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &i->where);
return FAILURE;
}
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
- gfc_error (
- "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or LOGICAL", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &j->where);
return FAILURE;
}
OSDN Git Service
