static gfc_try
coarray_check (gfc_expr *e, int n)
{
+ if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
+ && CLASS_DATA (e)->attr.codimension
+ && CLASS_DATA (e)->as->corank)
+ {
+ gfc_add_class_array_ref (e);
+ return SUCCESS;
+ }
+
if (!gfc_is_coarray (e))
{
gfc_error ("Expected coarray variable as '%s' argument to the %s "
static gfc_try
array_check (gfc_expr *e, int n)
{
- if (e->rank != 0)
+ if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
+ && CLASS_DATA (e)->attr.dimension
+ && CLASS_DATA (e)->as->rank)
+ {
+ gfc_add_class_array_ref (e);
+ return SUCCESS;
+ }
+
+ if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
{
gfc_extract_int (expr2, &i2);
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
+
+ /* For ISHFT[C], check that |shift| <= bit_size(i). */
+ if (arg2 == NULL)
+ {
+ if (i2 < 0)
+ i2 = -i2;
+
+ if (i2 > gfc_integer_kinds[i3].bit_size)
+ {
+ gfc_error ("The absolute value of SHIFT at %L must be less "
+ "than or equal to BIT_SIZE('%s')",
+ &expr2->where, arg1);
+ return FAILURE;
+ }
+ }
+
if (or_equal)
{
if (i2 > gfc_integer_kinds[i3].bit_size)
&& (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
|| gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
- gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
- &e->where);
- return FAILURE;
+ gfc_ref *ref;
+ bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
+ && CLASS_DATA (e->symtree->n.sym)
+ ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
+ : e->symtree->n.sym->attr.pointer;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (pointer && ref->type == REF_COMPONENT)
+ break;
+ if (ref->type == REF_COMPONENT
+ && ((ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
+ || (ref->u.c.component->ts.type != BT_CLASS
+ && ref->u.c.component->attr.pointer)))
+ break;
+ }
+
+ if (!ref)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
+ "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return FAILURE;
+ }
}
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor != FL_PARAMETER
- && (allow_proc
- || !e->symtree->n.sym->attr.function
- || (e->symtree->n.sym == e->symtree->n.sym->result
- && (e->symtree->n.sym == gfc_current_ns->proc_name
- || (gfc_current_ns->parent
- && e->symtree->n.sym
- == gfc_current_ns->parent->proc_name)))))
+ && (allow_proc || !e->symtree->n.sym->attr.function))
return SUCCESS;
+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
+ && e->symtree->n.sym == e->symtree->n.sym->result)
+ {
+ gfc_namespace *ns;
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (ns->proc_name == e->symtree->n.sym)
+ return SUCCESS;
+ }
+
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
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;
+
+ if (array->ts.type == BT_CLASS)
+ return SUCCESS;
- ar = gfc_find_array_ref (array);
- corank = ar->as->corank;
+ corank = gfc_get_corank (array);
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS;
+ if (array->ts.type == BT_CLASS)
+ return SUCCESS;
+
if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
&& array->value.function.isym->id == GFC_ISYM_SPREAD)
rank = array->rank + 1;
if (attr1.pointer && gfc_is_coindexed (pointer))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
- "conindexed", gfc_current_intrinsic_arg[0]->name,
+ "coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &pointer->where);
return FAILURE;
}
if (attr1.pointer && gfc_is_coindexed (target))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
- "conindexed", gfc_current_intrinsic_arg[1]->name,
+ "coindexed", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &target->where);
return FAILURE;
}
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
+ /* gfc_notify_std would be a waste 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)
if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (same_type_check (i, 0, j, 1) == FAILURE)
+ if (i->is_boz && j->is_boz)
+ {
+ gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
+ "constants", &i->where, &j->where);
+ return FAILURE;
+ }
+
+ if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE)
return FAILURE;
if (type_check (shift, 2, BT_INTEGER) == FAILURE)
if (nonnegative_check ("SHIFT", shift) == FAILURE)
return FAILURE;
- if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
- return FAILURE;
+ if (i->is_boz)
+ {
+ if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE)
+ return FAILURE;
+ i->ts.kind = j->ts.kind;
+ }
+ else
+ {
+ if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
+ return FAILURE;
+ j->ts.kind = i->ts.kind;
+ }
return SUCCESS;
}
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
+ if (size != NULL)
+ {
+ int i2, i3;
+
+ if (type_check (size, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE)
+ return FAILURE;
+
+ if (size->expr_type == EXPR_CONSTANT)
+ {
+ gfc_extract_int (size, &i3);
+ if (i3 <= 0)
+ {
+ gfc_error ("SIZE at %L must be positive", &size->where);
+ return FAILURE;
+ }
+
+ if (shift->expr_type == EXPR_CONSTANT)
+ {
+ gfc_extract_int (shift, &i2);
+ if (i2 < 0)
+ i2 = -i2;
+
+ if (i2 > i3)
+ {
+ gfc_error ("The absolute value of SHIFT at %L must be less "
+ "than or equal to SIZE at %L", &shift->where,
+ &size->where);
+ return FAILURE;
+ }
+ }
+ }
+ }
+ else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
return FAILURE;
return SUCCESS;
if (allocatable_check (to, 1) == FAILURE)
return FAILURE;
+ if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
+ {
+ gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
+ "polymorphic if FROM is polymorphic",
+ &from->where);
+ return FAILURE;
+ }
+
if (same_type_check (to, 1, from, 0) == FAILURE)
return FAILURE;
return FAILURE;
}
- /* CLASS arguments: Make sure the vtab is present. */
+ /* CLASS arguments: Make sure the vtab of from is present. */
if (to->ts.type == BT_CLASS)
gfc_find_derived_vtab (from->ts.u.derived);
if (type_check (s, 1, BT_REAL) == FAILURE)
return FAILURE;
+ if (s->expr_type == EXPR_CONSTANT)
+ {
+ if (mpfr_sgn (s->value.real) == 0)
+ {
+ gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
+ &s->where);
+ return FAILURE;
+ }
+ }
+
return SUCCESS;
}
if (gfc_is_coindexed (mold))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
- "conindexed", gfc_current_intrinsic_arg[0]->name,
+ "coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
return FAILURE;
}
gfc_try
-gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
+gfc_check_sizeof (gfc_expr *arg)
{
+ if (arg->ts.type == BT_PROCEDURE)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &arg->where);
+ return FAILURE;
+ }
return SUCCESS;
}
gfc_try
gfc_check_c_sizeof (gfc_expr *arg)
{
- if (verify_c_interop (&arg->ts) != SUCCESS)
+ if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
"interoperable data entity",
gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
size_t *source_size, size_t *result_size,
size_t *result_length_p)
-
{
size_t result_elt_size;
- mpz_t tmp;
- gfc_expr *mold_element;
if (source->expr_type == EXPR_FUNCTION)
return FAILURE;
- /* Calculate the size of the source. */
- if (source->expr_type == EXPR_ARRAY
- && gfc_array_size (source, &tmp) == FAILURE)
+ if (size && size->expr_type != EXPR_CONSTANT)
return FAILURE;
+ /* Calculate the size of the source. */
*source_size = gfc_target_expr_size (source);
-
- mold_element = mold->expr_type == EXPR_ARRAY
- ? gfc_constructor_first (mold->value.constructor)->expr
- : mold;
+ if (*source_size == 0)
+ return FAILURE;
/* Determine the size of the element. */
- result_elt_size = gfc_target_expr_size (mold_element);
+ result_elt_size = gfc_element_size (mold);
if (result_elt_size == 0)
return FAILURE;
OSDN Git Service
