#include "gfortran.h"
#include "intrinsic.h"
#include "constructor.h"
+#include "target-memory.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;
-}
-
-
static gfc_try
coarray_check (gfc_expr *e, int n)
{
- if (!is_coarray (e))
+ if (!gfc_is_coarray (e))
{
gfc_error ("Expected coarray variable as '%s' argument to the %s "
"intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
{
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)
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;
+ corank = gfc_get_corank (array);
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
return ret;
}
+/* Calculate the length of a character variable, including substrings.
+ Strip away parentheses if necessary. Return -1 if no length could
+ be determined. */
+
+static long
+gfc_var_strlen (const gfc_expr *a)
+{
+ gfc_ref *ra;
+
+ while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
+ a = a->value.op.op1;
+
+ for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
+ ;
+
+ if (ra)
+ {
+ long start_a, end_a;
+
+ if (ra->u.ss.start->expr_type == EXPR_CONSTANT
+ && ra->u.ss.end->expr_type == EXPR_CONSTANT)
+ {
+ start_a = mpz_get_si (ra->u.ss.start->value.integer);
+ end_a = mpz_get_si (ra->u.ss.end->value.integer);
+ return end_a - start_a + 1;
+ }
+ else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
+ return 1;
+ else
+ return -1;
+ }
+
+ if (a->ts.u.cl && a->ts.u.cl->length
+ && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ return 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))
+ return a->value.character.length;
+ else
+ return -1;
+
+}
/* Check whether two character expressions have the same length;
- returns SUCCESS if they have or if the length cannot be determined. */
+ returns SUCCESS if they have or if the length cannot be determined,
+ otherwise return FAILURE and raise a gfc_error. */
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.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;
+ len_a = gfc_var_strlen(a);
+ len_b = gfc_var_strlen(b);
- if (len_a == len_b)
+ if (len_a == -1 || len_b == -1 || 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;
+ else
+ {
+ gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+ len_a, len_b, name, &a->where);
+ return FAILURE;
+ }
}
return FAILURE;
}
+ /* F2008, C1242. */
+ 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,
+ gfc_current_intrinsic, &pointer->where);
+ return FAILURE;
+ }
+
/* Target argument is optional. */
if (target == NULL)
return SUCCESS;
return FAILURE;
}
+ /* F2008, C1242. */
+ 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,
+ gfc_current_intrinsic, &target->where);
+ return FAILURE;
+ }
+
t = SUCCESS;
if (same_type_check (pointer, 0, target, 1) == FAILURE)
t = 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)
}
+static gfc_try
+gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
+{
+ if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
+ && !(atom->ts.type == BT_LOGICAL
+ && atom->ts.kind == gfc_atomic_logical_kind))
+ {
+ gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+ "integer of ATOMIC_INT_KIND or a logical of "
+ "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
+ return FAILURE;
+ }
+
+ if (!gfc_expr_attr (atom).codimension)
+ {
+ gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
+ "coarray or coindexed", &atom->where, gfc_current_intrinsic);
+ return FAILURE;
+ }
+
+ if (atom->ts.type != value->ts.type)
+ {
+ gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
+ "have the same type at %L", gfc_current_intrinsic,
+ &value->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
+{
+ if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
+ return FAILURE;
+
+ if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
+ {
+ gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &atom->where);
+ return FAILURE;
+ }
+
+ return gfc_check_atomic (atom, value);
+}
+
+
+gfc_try
+gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
+{
+ if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
+ return FAILURE;
+
+ if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
+ {
+ gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &value->where);
+ return FAILURE;
+ }
+
+ return gfc_check_atomic (atom, value);
+}
+
+
/* BESJN and BESYN functions. */
gfc_try
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;
return FAILURE;
}
+ /* CLASS arguments: Make sure the vtab is present. */
+ if (to->ts.type == BT_CLASS)
+ gfc_find_derived_vtab (from->ts.u.derived);
+
return SUCCESS;
}
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;
}
attr = gfc_variable_attr (mold, NULL);
- if (!attr.pointer && !attr.proc_pointer)
+ if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
+ "ALLOCATABLE or procedure pointer",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
return FAILURE;
}
+ if (attr.allocatable
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with "
+ "allocatable MOLD at %L", &mold->where) == FAILURE)
+ return FAILURE;
+
+ /* F2008, C1242. */
+ if (gfc_is_coindexed (mold))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ "conindexed", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &mold->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
if (a->ref != NULL
&& !(a->ref->next == NULL && a->ref->type == REF_ARRAY
- && a->ref->u.ar.type == AR_FULL))
+ && (a->ref->u.ar.type == AR_FULL
+ || (a->ref->u.ar.type == AR_ELEMENT
+ && a->ref->u.ar.as->rank == 0))))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
"subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
}
+gfc_try
+gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
+{
+ /* Any data object is allowed; a "data object" is a "constant (4.1.3),
+ variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
+
+ bool is_variable = true;
+
+ /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
+ if (a->expr_type == EXPR_FUNCTION)
+ is_variable = a->value.function.esym
+ ? a->value.function.esym->result->attr.pointer
+ : a->symtree->n.sym->result->attr.pointer;
+
+ if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
+ || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
+ || !is_variable)
+ {
+ gfc_error ("The argument of the RANK intrinsic at %L must be a data "
+ "object", &a->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* real, float, sngl. */
gfc_try
gfc_check_real (gfc_expr *a, gfc_expr *kind)
gfc_try
-gfc_check_shape (gfc_expr *source)
+gfc_check_shape (gfc_expr *source, gfc_expr *kind)
{
gfc_array_ref *ar;
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_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 be an "
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
"interoperable data entity",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return FAILURE;
if ((a->ts.kind != gfc_default_double_kind)
- && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision"
+ && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision "
"REAL argument to %s intrinsic at %L",
gfc_current_intrinsic, &a->where) == FAILURE)
return FAILURE;
gfc_try
gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
{
+ mpz_t nelems;
+
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
return FAILURE;
}
+ if (gfc_array_size (sub, &nelems) == SUCCESS)
+ {
+ int corank = gfc_get_corank (coarray);
+
+ if (mpz_cmp_ui (nelems, corank) != 0)
+ {
+ gfc_error ("The number of array elements of the SUB argument to "
+ "IMAGE_INDEX at %L shall be %d (corank) not %d",
+ &sub->where, corank, (int) mpz_get_si (nelems));
+ mpz_clear (nelems);
+ return FAILURE;
+ }
+ mpz_clear (nelems);
+ }
+
return SUCCESS;
}
return SUCCESS;
}
+/* Calculate the sizes for transfer, used by gfc_check_transfer and also
+ by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
gfc_try
-gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
- gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
+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)
+ return FAILURE;
+
+ *source_size = gfc_target_expr_size (source);
+
+ mold_element = mold->expr_type == EXPR_ARRAY
+ ? gfc_constructor_first (mold->value.constructor)->expr
+ : mold;
+
+ /* Determine the size of the element. */
+ result_elt_size = gfc_target_expr_size (mold_element);
+ if (result_elt_size == 0)
+ return FAILURE;
+
+ if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
+ {
+ int result_length;
+
+ if (size)
+ result_length = (size_t)mpz_get_ui (size->value.integer);
+ else
+ {
+ result_length = *source_size / result_elt_size;
+ if (result_length * result_elt_size < *source_size)
+ result_length += 1;
+ }
+
+ *result_size = result_length * result_elt_size;
+ if (result_length_p)
+ *result_length_p = result_length;
+ }
+ else
+ *result_size = result_elt_size;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
+{
+ size_t source_size;
+ size_t result_size;
+
if (mold->ts.type == BT_HOLLERITH)
{
gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
return FAILURE;
}
+ if (!gfc_option.warn_surprising)
+ return SUCCESS;
+
+ /* If we can't calculate the sizes, we cannot check any more.
+ Return SUCCESS for that case. */
+
+ if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+ &result_size, NULL) == FAILURE)
+ return SUCCESS;
+
+ if (source_size < result_size)
+ gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
+ "source size %ld < result size %ld", &source->where,
+ (long) source_size, (long) result_size);
+
return SUCCESS;
}
OSDN Git Service
