/* Check functions
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
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 "flags.h"
#include "gfortran.h"
#include "intrinsic.h"
+#include "constructor.h"
+
+
+/* Make sure an expression is a scalar. */
+
+static gfc_try
+scalar_check (gfc_expr *e, int n)
+{
+ if (e->rank == 0)
+ return SUCCESS;
+
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+
+ return FAILURE;
+}
/* Check the type of an expression. */
-static try
+static gfc_try
type_check (gfc_expr *e, int n, bt type)
{
if (e->ts.type == type)
/* Check that the expression is a numeric type. */
-static try
+static gfc_try
numeric_check (gfc_expr *e, int n)
{
if (gfc_numeric_ts (&e->ts))
/* Check that an expression is integer or real. */
-static try
+static gfc_try
int_or_real_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
/* Check that an expression is real or complex. */
-static try
+static gfc_try
real_or_complex_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
/* Check that the expression is an optional constant integer
and that it specifies a valid kind for that type. */
-static try
+static gfc_try
kind_check (gfc_expr *k, int n, bt type)
{
int kind;
if (type_check (k, n, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (scalar_check (k, n) == FAILURE)
+ return FAILURE;
+
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
/* Make sure the expression is a double precision real. */
-static try
+static gfc_try
double_check (gfc_expr *d, int n)
{
if (type_check (d, n, BT_REAL) == FAILURE)
/* Make sure the expression is a logical array. */
-static try
+static gfc_try
logical_array_check (gfc_expr *array, int n)
{
if (array->ts.type != BT_LOGICAL || array->rank == 0)
/* Make sure an expression is an array. */
-static try
+static gfc_try
array_check (gfc_expr *e, int n)
{
if (e->rank != 0)
}
-/* 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 expressions have the same type. */
-static try
+static gfc_try
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
{
if (gfc_compare_types (&e->ts, &f->ts))
/* Make sure that an expression has a certain (nonzero) rank. */
-static try
+static gfc_try
rank_check (gfc_expr *e, int n, int rank)
{
if (e->rank == rank)
/* Make sure a variable expression is not an optional dummy argument. */
-static try
+static gfc_try
nonoptional_check (gfc_expr *e, int n)
{
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
/* Check that an expression has a particular kind. */
-static try
+static gfc_try
kind_value_check (gfc_expr *e, int n, int k)
{
if (e->ts.kind == k)
/* Make sure an expression is a variable. */
-static try
+static gfc_try
variable_check (gfc_expr *e, int n)
{
if ((e->expr_type == EXPR_VARIABLE
/* Check the common DIM parameter for correctness. */
-static try
-dim_check (gfc_expr *dim, int n, int optional)
+static gfc_try
+dim_check (gfc_expr *dim, int n, bool optional)
{
- if (optional && dim == NULL)
- 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 (nonoptional_check (dim, n) == FAILURE)
+ if (!optional && nonoptional_check (dim, n) == FAILURE)
return FAILURE;
return SUCCESS;
allow_assumed is zero then dim must be less than the rank of the array
for assumed size arrays. */
-static try
+static gfc_try
dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
{
gfc_array_ref *ar;
int rank;
- if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
+ if (dim == NULL)
+ return SUCCESS;
+
+ if (dim->expr_type != EXPR_CONSTANT
+ || (array->expr_type != EXPR_VARIABLE
+ && array->expr_type != EXPR_ARRAY))
return SUCCESS;
- ar = gfc_find_array_ref (array);
rank = array->rank;
- if (ar->as->type == AS_ASSUMED_SIZE
- && !allow_assumed
- && ar->type != AR_ELEMENT
- && ar->type != AR_SECTION)
- rank--;
+ if (array->expr_type == EXPR_VARIABLE)
+ {
+ ar = gfc_find_array_ref (array);
+ if (ar->as->type == AS_ASSUMED_SIZE
+ && !allow_assumed
+ && ar->type != AR_ELEMENT
+ && ar->type != AR_SECTION)
+ rank--;
+ }
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
}
-/* Error return for transformational intrinsics not allowed in
- initialization expressions. */
-
-static try
-non_init_transformational (void)
+/* Check whether two character expressions have the same length;
+ returns SUCCESS if they have or if the length cannot be determined. */
+
+gfc_try
+gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
{
- gfc_error ("transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", gfc_current_intrinsic,
- gfc_current_intrinsic_where);
- return FAILURE;
+ long len_a, len_b;
+ len_a = len_b = -1;
+
+ if (a->ts.u.cl && a->ts.u.cl->length
+ && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
+ else if (a->expr_type == EXPR_CONSTANT
+ && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
+ len_a = a->value.character.length;
+ else
+ return SUCCESS;
+
+ if (b->ts.u.cl && b->ts.u.cl->length
+ && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
+ else if (b->expr_type == EXPR_CONSTANT
+ && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
+ len_b = b->value.character.length;
+ else
+ return SUCCESS;
+
+ if (len_a == len_b)
+ return SUCCESS;
+
+ gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+ len_a, len_b, name, &a->where);
+ return FAILURE;
}
+
/***** Check functions *****/
/* Check subroutine suitable for intrinsics taking a real argument and
a kind argument for the result. */
-static try
+static gfc_try
check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
{
if (type_check (a, 0, BT_REAL) == FAILURE)
/* Check subroutine suitable for ceiling, floor and nint. */
-try
+gfc_try
gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
{
return check_a_kind (a, kind, BT_INTEGER);
/* Check subroutine suitable for aint, anint. */
-try
+gfc_try
gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
{
return check_a_kind (a, kind, BT_REAL);
}
-try
+gfc_try
gfc_check_abs (gfc_expr *a)
{
if (numeric_check (a, 0) == FAILURE)
}
-try
-gfc_check_achar (gfc_expr *a)
+gfc_try
+gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
if (type_check (a, 0, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE
|| scalar_check (name, 0) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE
|| scalar_check (mode, 1) == FAILURE)
return FAILURE;
+ if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
+ if (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_allocated (gfc_expr *array)
{
symbol_attribute attr;
if (variable_check (array, 0) == FAILURE)
return FAILURE;
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
-
attr = gfc_variable_attr (array, NULL);
if (!attr.allocatable)
{
/* Common check function where the first argument must be real or
integer and the second argument must be the same as the first. */
-try
+gfc_try
gfc_check_a_p (gfc_expr *a, gfc_expr *p)
{
if (int_or_real_check (a, 0) == FAILURE)
}
-try
+gfc_try
+gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
+{
+ if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
- symbol_attribute attr;
+ symbol_attribute attr1, attr2;
int i;
- try t;
+ gfc_try t;
locus *where;
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;
+ if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
+ attr1 = gfc_expr_attr (pointer);
else if (pointer->expr_type == EXPR_NULL)
goto null_arg;
else
gcc_assert (0); /* Pointer must be a variable or a function. */
- if (!attr.pointer)
+ if (!attr1.pointer && !attr1.proc_pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
if (target->expr_type == EXPR_NULL)
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;
+ if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
+ attr2 = gfc_expr_attr (target);
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
return FAILURE;
}
- if (!attr.pointer && !attr.target)
+ if (attr1.pointer && !attr2.pointer && !attr2.target)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
"or a TARGET", gfc_current_intrinsic_arg[1],
}
-try
+gfc_try
+gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
+{
+ /* gfc_notify_std would be a wast of time as the return value
+ is seemingly used only for the generic resolution. The error
+ will be: Too many arguments. */
+ if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
+ return FAILURE;
+
+ return gfc_check_atan2 (y, x);
+}
+
+
+gfc_try
gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
{
if (type_check (y, 0, BT_REAL) == FAILURE)
/* BESJN and BESYN functions. */
-try
+gfc_try
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;
}
-try
+gfc_try
gfc_check_btest (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_char (gfc_expr *i, gfc_expr *kind)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_chdir (gfc_expr *dir)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
-
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
}
-try
+gfc_try
gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
if (numeric_check (x, 0) == FAILURE)
gfc_current_intrinsic, &y->where);
return FAILURE;
}
+
+ if (y->ts.type == BT_COMPLEX)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
+ return FAILURE;
+ }
+
}
if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
}
-try
+gfc_try
gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
}
-try
-gfc_check_count (gfc_expr *mask, gfc_expr *dim)
+gfc_try
+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 (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
return FAILURE;
-
- if (gfc_init_expr)
- return non_init_transformational ();
return SUCCESS;
}
-try
+gfc_try
gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ if (type_check (shift, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (dim_check (dim, 2, true) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, false) == FAILURE)
+ return FAILURE;
+
+ if (array->rank == 1 || shift->rank == 0)
{
if (scalar_check (shift, 1) == FAILURE)
return FAILURE;
}
+ else if (shift->rank == array->rank - 1)
+ {
+ int d;
+ if (!dim)
+ d = 1;
+ else if (dim->expr_type == EXPR_CONSTANT)
+ gfc_extract_int (dim, &d);
+ else
+ d = -1;
+
+ if (d > 0)
+ {
+ int i, j;
+ for (i = 0, j = 0; i < array->rank; i++)
+ if (i != d - 1)
+ {
+ if (!identical_dimen_shape (array, i, shift, j))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid shape in dimension %d (%ld/%ld)",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, i + 1,
+ mpz_get_si (array->shape[i]),
+ mpz_get_si (shift->shape[j]));
+ return FAILURE;
+ }
+
+ j += 1;
+ }
+ }
+ }
else
{
- /* TODO: more requirements on shift parameter. */
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
}
- if (dim_check (dim, 2, 1) == FAILURE)
- return FAILURE;
-
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
-try
+gfc_try
gfc_check_ctime (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
}
-try
+gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
+{
+ if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+gfc_try
gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
{
if (numeric_check (x, 0) == FAILURE)
gfc_current_intrinsic, &y->where);
return FAILURE;
}
+
+ if (y->ts.type == BT_COMPLEX)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
+ return FAILURE;
+ }
}
return SUCCESS;
}
-try
+gfc_try
gfc_check_dble (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_digits (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
{
switch (vector_a->ts.type)
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],
gfc_current_intrinsic_arg[1], &vector_a->where);
return FAILURE;
}
- if (gfc_init_expr)
- return non_init_transformational ();
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_dprod (gfc_expr *x, gfc_expr *y)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE
+ || type_check (y, 1, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (x->ts.kind != gfc_default_real_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ "real", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
+ return FAILURE;
+ }
+
+ if (y->ts.kind != gfc_default_real_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ "real", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
+ return FAILURE;
+ }
return SUCCESS;
}
-try
+gfc_try
gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
gfc_expr *dim)
{
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ if (dim_check (dim, 3, true) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, false) == FAILURE)
+ return FAILURE;
+
+ if (array->rank == 1 || shift->rank == 0)
{
- if (scalar_check (shift, 2) == FAILURE)
+ if (scalar_check (shift, 1) == FAILURE)
return FAILURE;
}
+ else if (shift->rank == array->rank - 1)
+ {
+ int d;
+ if (!dim)
+ d = 1;
+ else if (dim->expr_type == EXPR_CONSTANT)
+ gfc_extract_int (dim, &d);
+ else
+ d = -1;
+
+ if (d > 0)
+ {
+ int i, j;
+ for (i = 0, j = 0; i < array->rank; i++)
+ if (i != d - 1)
+ {
+ if (!identical_dimen_shape (array, i, shift, j))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid shape in dimension %d (%ld/%ld)",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, i + 1,
+ mpz_get_si (array->shape[i]),
+ mpz_get_si (shift->shape[j]));
+ return FAILURE;
+ }
+
+ j += 1;
+ }
+ }
+ }
else
{
- /* TODO: more weird restrictions on shift. */
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
}
if (boundary != NULL)
if (same_type_check (array, 0, boundary, 2) == FAILURE)
return FAILURE;
- /* TODO: more restrictions on boundary. */
+ if (array->rank == 1 || boundary->rank == 0)
+ {
+ if (scalar_check (boundary, 2) == FAILURE)
+ return FAILURE;
+ }
+ else if (boundary->rank == array->rank - 1)
+ {
+ if (gfc_check_conformance (shift, boundary,
+ "arguments '%s' and '%s' for "
+ "intrinsic %s",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic ) == FAILURE)
+ return FAILURE;
+ }
+ else
+ {
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+ "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
+ }
}
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
-
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
/* A single complex argument. */
-try
+gfc_try
gfc_check_fn_c (gfc_expr *a)
{
if (type_check (a, 0, BT_COMPLEX) == FAILURE)
/* A single real argument. */
-try
+gfc_try
gfc_check_fn_r (gfc_expr *a)
{
if (type_check (a, 0, BT_REAL) == FAILURE)
return SUCCESS;
}
+/* A single double argument. */
+
+gfc_try
+gfc_check_fn_d (gfc_expr *a)
+{
+ if (double_check (a, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
/* A single real or complex argument. */
-try
+gfc_try
gfc_check_fn_rc (gfc_expr *a)
{
if (real_or_complex_check (a, 0) == FAILURE)
}
-try
+gfc_try
+gfc_check_fn_rc2008 (gfc_expr *a)
+{
+ if (real_or_complex_check (a, 0) == FAILURE)
+ return FAILURE;
+
+ if (a->ts.type == BT_COMPLEX
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
+ "argument of '%s' intrinsic at %L",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &a->where) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_fnum (gfc_expr *unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_huge (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
}
+gfc_try
+gfc_check_hypot (gfc_expr *x, gfc_expr *y)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+ if (same_type_check (x, 0, y, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
/* Check that the single argument is an integer. */
-try
+gfc_try
gfc_check_i (gfc_expr *i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_iand (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
-gfc_check_ichar_iachar (gfc_expr *c)
+gfc_try
+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;
{
/* 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 (c->ts.u.cl && c->ts.u.cl->length)
{
/* If we already have a length for this expression then use it. */
- if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return SUCCESS;
- i = mpz_get_si (c->ts.cl->length->value.integer);
+ i = mpz_get_si (c->ts.u.cl->length->value.integer);
}
else
return SUCCESS;
}
-try
+gfc_try
gfc_check_idnint (gfc_expr *a)
{
if (double_check (a, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_ieor (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
-gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
+gfc_try
+gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
+ gfc_expr *kind)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
-
if (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_try
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)
- return FAILURE;
-
- if (scalar_check (kind, 1) == FAILURE)
- return FAILURE;
- }
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_intconv (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_ior (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE
}
-try
+gfc_try
gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE
}
-try
+gfc_try
gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
{
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
{
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_kind (gfc_expr *x)
{
if (x->ts.type == BT_DERIVED)
}
-try
-gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
+gfc_try
+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)
- return 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;
+}
+
+
+gfc_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;
+}
+
+
+gfc_try
+gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
+{
+ if (type_check (a, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ if (type_check (b, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 1) == FAILURE)
- return FAILURE;
- }
return SUCCESS;
}
-try
+gfc_try
gfc_check_link (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_loc (gfc_expr *expr)
{
return variable_check (expr, 0);
}
-try
+gfc_try
gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_logical (gfc_expr *a, gfc_expr *kind)
{
if (type_check (a, 0, BT_LOGICAL) == FAILURE)
/* Min/max family. */
-static try
+static gfc_try
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)
+static gfc_try
+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)
return FAILURE;
}
}
+
+ for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
+ if (gfc_check_conformance (tmp->expr, x,
+ "arguments 'a%d' and 'a%d' for "
+ "intrinsic '%s'", m, n,
+ gfc_current_intrinsic) == FAILURE)
+ return FAILURE;
}
return SUCCESS;
}
-try
+gfc_try
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_try
gfc_check_min_max_integer (gfc_actual_arglist *arg)
{
return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
}
-try
+gfc_try
gfc_check_min_max_real (gfc_actual_arglist *arg)
{
return check_rest (BT_REAL, gfc_default_real_kind, arg);
}
-try
+gfc_try
gfc_check_min_max_double (gfc_actual_arglist *arg)
{
return check_rest (BT_REAL, gfc_default_double_kind, arg);
/* End of min/max family. */
-try
+gfc_try
gfc_check_malloc (gfc_expr *size)
{
if (type_check (size, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
{
- if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
+ 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 "
"or LOGICAL", gfc_current_intrinsic_arg[0],
return FAILURE;
}
- if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->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 "
"or LOGICAL", gfc_current_intrinsic_arg[1],
return FAILURE;
}
+ if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
+ || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
+ {
+ gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
+ gfc_current_intrinsic, &matrix_a->where,
+ gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
+ return FAILURE;
+ }
+
switch (matrix_a->rank)
{
case 1:
/* 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' "
+ 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);
- 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 "
+ 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;
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
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_try
gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
{
gfc_expr *a, *m, *d;
ap->next->next->expr = m;
}
- if (dim_check (d, 1, 1) == FAILURE)
+ if (dim_check (d, 1, false) == FAILURE)
return FAILURE;
- if (d && dim_rank_check (d, a, 0) == FAILURE)
+ if (dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
- if (m != NULL)
- {
- 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;
- }
-
- if (gfc_init_expr)
- return non_init_transformational ();
+ if (m != NULL
+ && gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic ) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
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
+static gfc_try
check_reduction (gfc_actual_arglist *ap)
{
gfc_expr *a, *m, *d;
ap->next->next->expr = m;
}
- if (dim_check (d, 1, 1) == FAILURE)
+ if (dim_check (d, 1, false) == FAILURE)
return FAILURE;
- if (d && dim_rank_check (d, a, 0) == FAILURE)
+ if (dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
- if (m != NULL)
- {
- 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;
- }
+ if (m != NULL
+ && gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_minval_maxval (gfc_actual_arglist *ap)
{
if (int_or_real_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return check_reduction (ap);
}
-try
+gfc_try
gfc_check_product_sum (gfc_actual_arglist *ap)
{
if (numeric_check (ap->expr, 0) == FAILURE
|| array_check (ap->expr, 0) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return check_reduction (ap);
}
-try
+gfc_try
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
- char buffer[80];
-
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
return FAILURE;
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
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, tsource, fsource) == FAILURE)
- return FAILURE;
-
- 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, tsource, mask) == FAILURE)
- return FAILURE;
+ if (tsource->ts.type == BT_CHARACTER)
+ return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
return SUCCESS;
}
-try
+
+gfc_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)
{
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)
{
return FAILURE;
}
- if (same_type_check (from, 0, to, 1) == FAILURE)
+ if (same_type_check (to, 1, from, 0) == FAILURE)
return FAILURE;
if (to->rank != from->rank)
}
-try
+gfc_try
gfc_check_nearest (gfc_expr *x, gfc_expr *s)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
}
-try
+gfc_try
gfc_check_new_line (gfc_expr *a)
{
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_null (gfc_expr *mold)
{
symbol_attribute attr;
attr = gfc_variable_attr (mold, NULL);
- if (!attr.pointer)
+ if (!attr.pointer && !attr.proc_pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0],
}
-try
+gfc_try
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;
- 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)
+ if (gfc_check_conformance (array, mask,
+ "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic) == FAILURE)
return FAILURE;
if (vector != NULL)
{
+ mpz_t array_size, vector_size;
+ bool have_array_size, have_vector_size;
+
if (same_type_check (array, 0, vector, 2) == FAILURE)
return FAILURE;
if (rank_check (vector, 2, 1) == FAILURE)
return FAILURE;
- /* TODO: More constraints here. */
- }
+ /* VECTOR requires at least as many elements as MASK
+ has .TRUE. values. */
+ have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
+ have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
+
+ if (have_vector_size
+ && (mask->expr_type == EXPR_ARRAY
+ || (mask->expr_type == EXPR_CONSTANT
+ && have_array_size)))
+ {
+ int mask_true_values = 0;
+
+ if (mask->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+ {
+ mask_true_values = 0;
+ break;
+ }
+
+ if (mask_ctor->expr->value.logical)
+ mask_true_values++;
+
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
+ }
+ else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
+ mask_true_values = mpz_get_si (array_size);
+
+ if (mpz_get_si (vector_size) < mask_true_values)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ "provide at least as many elements as there "
+ "are .TRUE. values in '%s' (%ld/%d)",
+ gfc_current_intrinsic_arg[2],gfc_current_intrinsic,
+ &vector->where, gfc_current_intrinsic_arg[1],
+ mpz_get_si (vector_size), mask_true_values);
+ return FAILURE;
+ }
+ }
- if (gfc_init_expr)
- return non_init_transformational ();
+ if (have_array_size)
+ mpz_clear (array_size);
+ if (have_vector_size)
+ mpz_clear (vector_size);
+ }
return SUCCESS;
}
-try
+gfc_try
gfc_check_precision (gfc_expr *x)
{
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
}
-try
+gfc_try
gfc_check_present (gfc_expr *a)
{
gfc_symbol *sym;
}
-try
+gfc_try
gfc_check_radix (gfc_expr *x)
{
if (int_or_real_check (x, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_range (gfc_expr *x)
{
if (numeric_check (x, 0) == FAILURE)
/* real, float, sngl. */
-try
+gfc_try
gfc_check_real (gfc_expr *a, gfc_expr *kind)
{
if (numeric_check (a, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_repeat (gfc_expr *x, gfc_expr *y)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
gfc_expr *pad, gfc_expr *order)
{
mpz_t size;
mpz_t nelems;
- int m;
+ int shape_size;
if (array_check (source, 0) == FAILURE)
return FAILURE;
return FAILURE;
}
- m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
+ shape_size = mpz_get_ui (size);
mpz_clear (size);
- if (m > 0)
+ if (shape_size <= 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &shape->where);
+ return FAILURE;
+ }
+ else if (shape_size > GFC_MAX_DIMENSIONS)
{
gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
return FAILURE;
}
+ else if (shape->expr_type == EXPR_ARRAY)
+ {
+ gfc_expr *e;
+ int i, extent;
+ for (i = 0; i < shape_size; ++i)
+ {
+ e = gfc_constructor_lookup_expr (shape->value.constructor, i);
+ if (e->expr_type != EXPR_CONSTANT)
+ continue;
+
+ gfc_extract_int (e, &extent);
+ if (extent < 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "negative element (%d)", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &e->where, extent);
+ return FAILURE;
+ }
+ }
+ }
if (pad != NULL)
{
if (same_type_check (source, 0, pad, 2) == FAILURE)
return FAILURE;
+
if (array_check (pad, 2) == FAILURE)
return FAILURE;
}
- if (order != NULL && array_check (order, 3) == FAILURE)
- return FAILURE;
+ if (order != NULL)
+ {
+ if (array_check (order, 3) == FAILURE)
+ return FAILURE;
+
+ if (type_check (order, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (order->expr_type == EXPR_ARRAY)
+ {
+ int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+
+ for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
+ perm[i] = 0;
+
+ gfc_array_size (order, &size);
+ order_size = mpz_get_ui (size);
+ mpz_clear (size);
+
+ if (order_size != shape_size)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "has wrong number of elements (%d/%d)",
+ gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &order->where,
+ order_size, shape_size);
+ return FAILURE;
+ }
+
+ for (i = 1; i <= order_size; ++i)
+ {
+ e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
+ if (e->expr_type != EXPR_CONSTANT)
+ continue;
+
+ gfc_extract_int (e, &dim);
+
+ if (dim < 1 || dim > order_size)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "has out-of-range dimension (%d)",
+ gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &e->where, dim);
+ return FAILURE;
+ }
+
+ if (perm[dim-1] != 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid permutation of dimensions (dimension "
+ "'%d' duplicated)", gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic, &e->where, dim);
+ return FAILURE;
+ }
+
+ perm[dim-1] = 1;
+ }
+ }
+ }
if (pad == NULL && shape->expr_type == EXPR_ARRAY
&& gfc_is_constant_expr (shape)
gfc_constructor *c;
bool test;
- c = shape->value.constructor;
+
mpz_init_set_ui (size, 1);
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (shape->value.constructor);
+ c; c = gfc_constructor_next (c))
mpz_mul (size, size, c->expr->value.integer);
test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
}
-try
+gfc_try
+gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+
+ if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of a derived type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
+ return FAILURE;
+ }
+
+ if (!gfc_type_is_extensible (a->ts.u.derived))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of an extensible type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
+ return FAILURE;
+ }
+
+ if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of a derived type", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &b->where);
+ return FAILURE;
+ }
+
+ if (!gfc_type_is_extensible (b->ts.u.derived))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "must be of an extensible type", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &b->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_scale (gfc_expr *x, gfc_expr *i)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
}
-try
-gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
+gfc_try
+gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (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_try
gfc_check_secnds (gfc_expr *r)
{
if (type_check (r, 0, BT_REAL) == FAILURE)
}
-try
+gfc_try
+gfc_check_selected_char_kind (gfc_expr *name)
+{
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (name, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_selected_int_kind (gfc_expr *r)
{
if (type_check (r, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
{
if (p == NULL && r == NULL)
}
-try
+gfc_try
gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
}
-try
+gfc_try
gfc_check_shape (gfc_expr *source)
{
gfc_array_ref *ar;
ar = gfc_find_array_ref (source);
- if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
+ if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
{
gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
"an assumed size array", &source->where);
}
-try
+gfc_try
gfc_check_sign (gfc_expr *a, gfc_expr *b)
{
if (int_or_real_check (a, 0) == FAILURE)
}
-try
-gfc_check_size (gfc_expr *array, gfc_expr *dim)
+gfc_try
+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 (dim_check (dim, 1, true) == FAILURE)
+ return FAILURE;
- if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
- return FAILURE;
+ if (dim_rank_check (dim, array, 0) == FAILURE)
+ return FAILURE;
+
+ 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;
+}
- if (dim_rank_check (dim, array, 0) == FAILURE)
- return FAILURE;
- }
+gfc_try
+gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
+{
return SUCCESS;
}
-try
+gfc_try
gfc_check_sleep_sub (gfc_expr *seconds)
{
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
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;
+ /* dim_rank_check() does not apply here. */
+ if (dim
+ && dim->expr_type == EXPR_CONSTANT
+ && (mpz_cmp_ui (dim->value.integer, 1) < 0
+ || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+ "dimension index", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &dim->where);
+ return FAILURE;
+ }
+
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (ncopies, 2) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
functions). */
-try
+gfc_try
gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
if (type_check (c, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
{
return gfc_check_fgetputc_sub (unit, c, NULL);
}
-try
+gfc_try
gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
{
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_fgetput (gfc_expr *c)
{
return gfc_check_fgetput_sub (c, NULL);
}
-try
+gfc_try
gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
-try
+gfc_try
gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_ftell (gfc_expr *unit)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
{
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_stat (gfc_expr *name, gfc_expr *array)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (array, 1, BT_INTEGER) == FAILURE
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
}
-try
+gfc_try
gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (type_check (array, 1, BT_INTEGER) == FAILURE
|| kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
}
-try
+gfc_try
gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
{
+ if (mold->ts.type == BT_HOLLERITH)
+ {
+ gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
+ &mold->where, gfc_basic_typename (BT_HOLLERITH));
+ return FAILURE;
+ }
+
if (size != NULL)
{
if (type_check (size, 2, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_transpose (gfc_expr *matrix)
{
if (rank_check (matrix, 0, 2) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
-try
-gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
+gfc_try
+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)
- return FAILURE;
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 0) == 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_try
gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
{
+ mpz_t vector_size;
+
if (rank_check (vector, 0, 1) == FAILURE)
return FAILURE;
if (same_type_check (vector, 0, field, 2) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
+ if (mask->expr_type == EXPR_ARRAY
+ && gfc_array_size (vector, &vector_size) == SUCCESS)
+ {
+ int mask_true_count = 0;
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+ {
+ mask_true_count = 0;
+ break;
+ }
+
+ if (mask_ctor->expr->value.logical)
+ mask_true_count++;
+
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
+
+ if (mpz_get_si (vector_size) < mask_true_count)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ "provide at least as many elements as there "
+ "are .TRUE. values in '%s' (%ld/%d)",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &vector->where, gfc_current_intrinsic_arg[1],
+ mpz_get_si (vector_size), mask_true_count);
+ return FAILURE;
+ }
+
+ mpz_clear (vector_size);
+ }
+
+ if (mask->rank != field->rank && field->rank != 0)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
+ "the same rank as '%s' or be a scalar",
+ gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
+ &field->where, gfc_current_intrinsic_arg[1]);
+ return FAILURE;
+ }
+
+ if (mask->rank == field->rank)
+ {
+ int i;
+ for (i = 0; i < field->rank; i++)
+ if (! identical_dimen_shape (mask, i, field, i))
+ {
+ gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
+ "must have identical shape.",
+ gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &field->where);
+ }
+ }
return SUCCESS;
}
-try
-gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
+gfc_try
+gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (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_try
gfc_check_trim (gfc_expr *x)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_ttynam (gfc_expr *unit)
{
if (scalar_check (unit, 0) == FAILURE)
/* Common check function for the half a dozen intrinsics that have a
single real argument. */
-try
+gfc_try
gfc_check_x (gfc_expr *x)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
/************* Check functions for intrinsic subroutines *************/
-try
+gfc_try
gfc_check_cpu_time (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
gfc_expr *zone, gfc_expr *values)
{
{
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (scalar_check (date, 0) == FAILURE)
return FAILURE;
if (variable_check (date, 0) == FAILURE)
{
if (type_check (time, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (scalar_check (time, 1) == FAILURE)
return FAILURE;
if (variable_check (time, 1) == FAILURE)
{
if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (scalar_check (zone, 2) == FAILURE)
return FAILURE;
if (variable_check (zone, 2) == FAILURE)
}
-try
+gfc_try
gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
gfc_expr *to, gfc_expr *topos)
{
}
-try
+gfc_try
gfc_check_random_number (gfc_expr *harvest)
{
if (type_check (harvest, 0, BT_REAL) == FAILURE)
}
-try
+gfc_try
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
+ unsigned int nargs = 0, kiss_size;
+ locus *where = NULL;
+ mpz_t put_size, get_size;
+ bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
+
+ have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
+
+ /* Keep the number of bytes in sync with kiss_size in
+ libgfortran/intrinsics/random.c. */
+ kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
+
if (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 (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
+
+ if (gfc_array_size (put, &put_size) == SUCCESS
+ && mpz_get_ui (put_size) < kiss_size)
+ gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ "too small (%i/%i)",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
+ (int) mpz_get_ui (put_size), kiss_size);
}
if (get != NULL)
{
-
- if (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;
if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
return FAILURE;
+
+ if (gfc_array_size (get, &get_size) == SUCCESS
+ && mpz_get_ui (get_size) < kiss_size)
+ gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ "too small (%i/%i)",
+ gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
+ (int) mpz_get_ui (get_size), kiss_size);
}
+ /* RANDOM_SEED may not have more than one non-optional argument. */
+ if (nargs > 1)
+ gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
+
return SUCCESS;
}
-try
+gfc_try
gfc_check_second_sub (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
count, count_rate, and count_max are all optional arguments */
-try
+gfc_try
gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
gfc_expr *count_max)
{
}
-try
+gfc_try
gfc_check_irand (gfc_expr *x)
{
if (x == NULL)
}
-try
+gfc_try
gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
{
if (scalar_check (seconds, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_rand (gfc_expr *x)
{
if (x == NULL)
}
-try
+gfc_try
gfc_check_srand (gfc_expr *x)
{
if (scalar_check (x, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
{
if (scalar_check (time, 0) == FAILURE)
return FAILURE;
-
if (type_check (time, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (result, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
-gfc_check_etime (gfc_expr *x)
+gfc_try
+gfc_check_dtime_etime (gfc_expr *x)
{
if (array_check (x, 0) == FAILURE)
return FAILURE;
}
-try
-gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
+gfc_try
+gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
{
if (array_check (values, 0) == FAILURE)
return FAILURE;
}
-try
+gfc_try
gfc_check_fdate_sub (gfc_expr *date)
{
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_gerror (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
{
if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
+gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
+{
+ if (type_check (pos, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (pos->ts.kind > gfc_default_integer_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+ "not wider than the default kind (%d)",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &pos->where, gfc_default_integer_kind);
+ return FAILURE;
+ }
+
+ if (type_check (value, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+ if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_getlog (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_exit (gfc_expr *status)
{
if (status == NULL)
}
-try
+gfc_try
gfc_check_flush (gfc_expr *unit)
{
if (unit == NULL)
}
-try
+gfc_try
gfc_check_free (gfc_expr *i)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_hostnm (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_itime_idate (gfc_expr *values)
{
if (array_check (values, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
{
if (type_check (time, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
{
if (scalar_check (unit, 0) == FAILURE)
if (type_check (name, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_isatty (gfc_expr *unit)
{
if (unit == NULL)
}
-try
+gfc_try
+gfc_check_isnan (gfc_expr *x)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_perror (gfc_expr *string)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_umask (gfc_expr *mask)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
{
if (type_check (mask, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_unlink (gfc_expr *name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
-try
+gfc_try
gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (status == NULL)
return SUCCESS;
}
-try
+gfc_try
gfc_check_signal (gfc_expr *number, gfc_expr *handler)
{
if (scalar_check (number, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
{
if (scalar_check (number, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
{
if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
+ return FAILURE;
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
/* This is used for the GNU intrinsics AND, OR and XOR. */
-try
+gfc_try
gfc_check_and (gfc_expr *i, gfc_expr *j)
{
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
OSDN Git Service
