/* Check functions
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
#include "flags.h"
#include "gfortran.h"
#include "intrinsic.h"
+#include "constructor.h"
/* Make sure an expression is a scalar. */
-static try
+static gfc_try
scalar_check (gfc_expr *e, int n)
{
if (e->rank == 0)
/* 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;
/* 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 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
+static gfc_try
dim_check (gfc_expr *dim, int n, bool optional)
{
if (dim == NULL)
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)
/* 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)
+gfc_try
+gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
{
long len_a, len_b;
len_a = len_b = -1;
- if (a->ts.cl && a->ts.cl->length
- && a->ts.cl->length->expr_type == EXPR_CONSTANT)
- len_a = mpz_get_si (a->ts.cl->length->value.integer);
+ 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.cl == NULL || a->ts.cl->length == NULL))
+ && (a->ts.u.cl == NULL || a->ts.u.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);
+ 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.cl == NULL || b->ts.cl->length == NULL))
+ && (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 and %ld) in %s intrinsic "
- "at %L", len_a, len_b, name, &a->where);
+ gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+ len_a, len_b, name, &a->where);
return FAILURE;
}
/* 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_try
gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
if (type_check (a, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE
}
-try
+gfc_try
gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
{
if (logical_array_check (mask, 0) == FAILURE)
if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
+ if (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
-try
+gfc_try
gfc_check_allocated (gfc_expr *array)
{
symbol_attribute attr;
return FAILURE;
}
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
/* Common check function where the first argument must be real or
integer and the second argument must be the same as the first. */
-try
+gfc_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)
}
-try
+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 (type_check (n, 0, BT_INTEGER) == 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)
}
-try
+gfc_try
gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
}
-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_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, 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 "
}
-try
+gfc_try
gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
if (array_check (array, 0) == FAILURE)
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ 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, true) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
-try
+gfc_try
gfc_check_ctime (gfc_expr *time)
{
if (scalar_check (time, 0) == FAILURE)
}
-try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
+gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
{
if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
-try
+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)
}
-try
+gfc_try
gfc_check_dprod (gfc_expr *x, gfc_expr *y)
{
if (type_check (x, 0, BT_REAL) == FAILURE
}
-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, 4, true) == FAILURE)
- return FAILURE;
-
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)
/* A single double argument. */
-try
+gfc_try
gfc_check_fn_d (gfc_expr *a)
{
if (double_check (a, 0) == FAILURE)
/* 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)
}
-try
+gfc_try
gfc_check_hypot (gfc_expr *x, gfc_expr *y)
{
if (type_check (x, 0, BT_REAL) == FAILURE)
/* 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_try
gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
{
int i;
{
/* 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_try
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
gfc_expr *kind)
{
}
-try
+gfc_try
gfc_check_int (gfc_expr *x, gfc_expr *kind)
{
if (numeric_check (x, 0) == FAILURE)
}
-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_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, false) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 1) == FAILURE)
- return FAILURE;
- }
+ if (dim_rank_check (dim, array, 1) == FAILURE)
+ return FAILURE;
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
return FAILURE;
}
-try
+gfc_try
gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
{
if (type_check (s, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
{
if (type_check (a, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_link (gfc_expr *path1, gfc_expr *path2)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
}
-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)
}
-try
+gfc_try
gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
}
-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
+static gfc_try
check_rest (bt type, int kind, gfc_actual_arglist *arglist)
{
gfc_actual_arglist *arg, *tmp;
}
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)
+ 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;
}
-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:
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 (d && dim_check (d, 1, false) == 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;
}
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 (d && dim_check (d, 1, false) == 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
}
-try
+gfc_try
gfc_check_product_sum (gfc_actual_arglist *ap)
{
if (numeric_check (ap->expr, 0) == FAILURE
}
-try
+gfc_try
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
return FAILURE;
if (tsource->ts.type == BT_CHARACTER)
- return check_same_strlen (tsource, fsource, "MERGE");
+ 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 (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)
}
-try
+gfc_try
gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
}
-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_try
gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == 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)
}
-try
+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;
}
-try
+gfc_try
gfc_check_sign (gfc_expr *a, gfc_expr *b)
{
if (int_or_real_check (a, 0) == FAILURE)
}
-try
+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 (dim_check (dim, 1, true) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, true) == 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;
}
-try
+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)
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;
/* 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)
}
-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)
}
-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)
}
-try
+gfc_try
gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
{
}
-try
+gfc_try
gfc_check_transpose (gfc_expr *matrix)
{
if (rank_check (matrix, 0, 2) == FAILURE)
}
-try
+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, false) == 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;
}
-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 (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_try
gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
}
-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)
{
}
-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;
+ 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 (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 (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. */
}
-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)
}
-try
+gfc_try
gfc_check_dtime_etime (gfc_expr *x)
{
if (array_check (x, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
{
if (array_check (values, 0) == FAILURE)
}
-try
+gfc_try
gfc_check_fdate_sub (gfc_expr *date)
{
if (type_check (date, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_gerror (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
{
if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
}
-try
+gfc_try
gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
{
if (type_check (pos, 0, BT_INTEGER) == FAILURE)
}
-try
+gfc_try
gfc_check_getlog (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
}
-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)
}
-try
+gfc_try
gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
}
-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)
}
-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)
}
-try
+gfc_try
gfc_check_perror (gfc_expr *string)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
}
-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)
}
-try
+gfc_try
gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
}
-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)
/* 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
