/* Check functions
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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. */
}
+/* Check whether an expression is a coarray (without array designator). */
+
+static bool
+is_coarray (gfc_expr *e)
+{
+ bool coarray = false;
+ gfc_ref *ref;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ coarray = e->symtree->n.sym->attr.codimension;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT)
+ coarray = ref->u.c.component->attr.codimension;
+ else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
+ || ref->u.ar.codimen != 0)
+ coarray = false;
+ }
+
+ return coarray;
+}
+
+
/* Make sure the expression is a logical array. */
static gfc_try
}
+/* If a coarray DIM parameter is a constant, make sure that it is greater than
+ zero and less than or equal to the corank of the given array. */
+
+static gfc_try
+dim_corank_check (gfc_expr *dim, gfc_expr *array)
+{
+ gfc_array_ref *ar;
+ int corank;
+
+ gcc_assert (array->expr_type == EXPR_VARIABLE);
+
+ if (dim->expr_type != EXPR_CONSTANT)
+ return SUCCESS;
+
+ ar = gfc_find_array_ref (array);
+ corank = ar->as->corank;
+
+ if (mpz_cmp_ui (dim->value.integer, 1) < 0
+ || mpz_cmp_ui (dim->value.integer, corank) > 0)
+ {
+ gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+ "codimension index", gfc_current_intrinsic, &dim->where);
+
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* If a DIM parameter is a constant, make sure that it is greater than
zero and less than or equal to the rank of the given array. If
allow_assumed is zero then dim must be less than the rank of the array
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_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
+{
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return FAILURE;
+ }
+
+ if (!is_coarray (coarray))
+ {
+ gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND "
+ "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+ return FAILURE;
+ }
+
+ if (dim != NULL)
+ {
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+
+ if (dim_corank_check (dim, coarray) == FAILURE)
+ return FAILURE;
+ }
+
+ if (kind_check (kind, 2, BT_INTEGER) == 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)
if (mask->expr_type == EXPR_ARRAY)
{
- gfc_constructor *mask_ctor = mask->value.constructor;
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor)
{
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
if (mask_ctor->expr->value.logical)
mask_true_values++;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
}
else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
int i, extent;
for (i = 0; i < shape_size; ++i)
{
- e = gfc_get_array_element (shape, i);
+ e = gfc_constructor_lookup_expr (shape->value.constructor, i);
if (e->expr_type != EXPR_CONSTANT)
- {
- gfc_free_expr (e);
- continue;
- }
+ continue;
gfc_extract_int (e, &extent);
if (extent < 0)
gfc_current_intrinsic, &e->where, extent);
return FAILURE;
}
-
- gfc_free_expr (e);
}
}
for (i = 1; i <= order_size; ++i)
{
- e = gfc_get_array_element (order, i-1);
+ e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
if (e->expr_type != EXPR_CONSTANT)
- {
- gfc_free_expr (e);
- continue;
- }
+ continue;
gfc_extract_int (e, &dim);
}
perm[dim-1] = 1;
- gfc_free_expr (e);
}
}
}
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_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return FAILURE;
+ }
+
+ if (!is_coarray (coarray))
+ {
+ gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX "
+ "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+ return FAILURE;
+ }
+
+ if (sub->rank != 1)
+ {
+ gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
+ gfc_current_intrinsic_arg[1], &sub->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return FAILURE;
+ }
+
+ if (dim != NULL && coarray == NULL)
+ {
+ gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
+ "intrinsic at %L", &dim->where);
+ return FAILURE;
+ }
+
+ if (coarray == NULL)
+ return SUCCESS;
+
+ if (!is_coarray (coarray))
+ {
+ gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE "
+ "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+ return FAILURE;
+ }
+
+ if (dim != NULL)
+ {
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+
+ if (dim_corank_check (dim, coarray) == FAILURE)
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
{
gfc_try
+gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
+{
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return FAILURE;
+ }
+
+ if (!is_coarray (coarray))
+ {
+ gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND "
+ "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+ return FAILURE;
+ }
+
+ if (dim != NULL)
+ {
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+
+ if (dim_corank_check (dim, coarray) == FAILURE)
+ return FAILURE;
+ }
+
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
{
mpz_t vector_size;
&& gfc_array_size (vector, &vector_size) == SUCCESS)
{
int mask_true_count = 0;
- gfc_constructor *mask_ctor = mask->value.constructor;
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor)
{
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
if (mask_ctor->expr->value.logical)
mask_true_count++;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
if (mpz_get_si (vector_size) < mask_true_count)
OSDN Git Service
