/* 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. */
gfc_array_ref *ar;
int rank;
+ if (dim == NULL)
+ return SUCCESS;
+
if (dim->expr_type != EXPR_CONSTANT
|| (array->expr_type != EXPR_VARIABLE
&& array->expr_type != EXPR_ARRAY))
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 (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
+ if (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
return FAILURE;
}
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
where = &pointer->where;
- if (pointer->expr_type == EXPR_VARIABLE)
- attr1 = gfc_variable_attr (pointer, NULL);
- else if (pointer->expr_type == EXPR_FUNCTION)
- attr1 = 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
if (target->expr_type == EXPR_NULL)
goto null_arg;
- if (target->expr_type == EXPR_VARIABLE)
- attr2 = gfc_variable_attr (target, NULL);
- else if (target->expr_type == EXPR_FUNCTION)
- attr2 = 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 "
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)
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)
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 "
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 && shift->rank != 0)
+ else if (shift->rank == array->rank - 1)
{
- gfc_error ("SHIFT argument at %L of CSHIFT must have rank %d or be a "
- "scalar", &shift->where, 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
+ {
+ 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;
}
- /* TODO: Add shape conformance check between array (w/o dimension dim)
- and shift. */
-
- if (dim_check (dim, 2, true) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
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;
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 && shift->rank != 0)
+ 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
{
- gfc_error ("SHIFT argument at %L of EOSHIFT must have rank %d or be a "
- "scalar", &shift->where, array->rank - 1);
+ 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;
}
- /* TODO: Add shape conformance check between array (w/o dimension dim)
- and shift. */
-
if (boundary != NULL)
{
if (same_type_check (array, 0, boundary, 2) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ if (array->rank == 1 || boundary->rank == 0)
{
if (scalar_check (boundary, 2) == FAILURE)
return FAILURE;
}
- else if (boundary->rank != array->rank - 1 && boundary->rank != 0)
+ else if (boundary->rank == array->rank - 1)
{
- gfc_error ("BOUNDARY argument at %L of EOSHIFT must have rank %d or be "
- "a scalar", &boundary->where, array->rank - 1);
- return FAILURE;
+ 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;
}
-
- if (shift->rank == boundary->rank)
+ else
{
- int i;
- for (i = 0; i < shift->rank; i++)
- if (! identical_dimen_shape (shift, i, boundary, i))
- {
- gfc_error ("Different shape in dimension %d for SHIFT and "
- "BOUNDARY arguments of EOSHIFT at %L", shift->rank,
- &boundary->where);
- return FAILURE;
- }
+ 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;
}
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)
{
/* 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;
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;
}
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;
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;
}
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;
}
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)
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;
{
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;
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)
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;
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 (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;
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 ("FIELD argument at %L of UNPACK must have the same rank as "
- "MASK or be a scalar", &field->where);
+ 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;
}
for (i = 0; i < field->rank; i++)
if (! identical_dimen_shape (mask, i, field, i))
{
- gfc_error ("Different shape in dimension %d for MASK and FIELD "
- "arguments of UNPACK at %L", mask->rank, &field->where);
- return FAILURE;
+ 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);
}
}
{
unsigned int nargs = 0, kiss_size;
locus *where = NULL;
- mpz_t put_size;
+ 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 these values in sync with kiss_size in libgfortran/random.c. */
- kiss_size = have_gfc_real_16 ? 12 : 8;
-
+ /* 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
if (gfc_array_size (put, &put_size) == SUCCESS
&& mpz_get_ui (put_size) < kiss_size)
- gfc_error ("Array PUT of intrinsic %s is too small (%i/%i) at %L",
- gfc_current_intrinsic, (int) mpz_get_ui (put_size),
- kiss_size, where);
+ 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. */
OSDN Git Service
