#include "gfortran.h"
#include "intrinsic.h"
#include "constructor.h"
+#include "target-memory.h"
/* Make sure an expression is a scalar. */
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where);
return FAILURE;
}
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
- gfc_basic_typename (type));
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where, gfc_basic_typename (type));
return FAILURE;
}
}
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where);
return FAILURE;
}
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or REAL", gfc_current_intrinsic_arg[n],
+ "or REAL", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return FAILURE;
}
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
- "or COMPLEX", gfc_current_intrinsic_arg[n],
+ "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+/* Check that an expression is INTEGER or PROCEDURE. */
+
+static gfc_try
+int_or_proc_check (gfc_expr *e, int n)
+{
+ if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return FAILURE;
}
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&k->where);
return FAILURE;
}
if (d->ts.kind != gfc_default_double_kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
- "precision", gfc_current_intrinsic_arg[n],
+ "precision", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &d->where);
return FAILURE;
}
}
-/* Check whether an expression is a coarray (without array designator). */
-
-static bool
-is_coarray (gfc_expr *e)
+static gfc_try
+coarray_check (gfc_expr *e, int n)
{
- 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 (!gfc_is_coarray (e))
{
- 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;
+ gfc_error ("Expected coarray variable as '%s' argument to the %s "
+ "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return FAILURE;
}
- return coarray;
-}
+ return SUCCESS;
+}
/* Make sure the expression is a logical array. */
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
- "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
- &array->where);
+ "array", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &array->where);
return FAILURE;
}
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where);
return FAILURE;
}
/* If expr2 is constant, then check that the value is less than
- bit_size(expr1). */
+ (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
static gfc_try
less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
- gfc_expr *expr2)
+ gfc_expr *expr2, bool or_equal)
{
int i2, i3;
{
gfc_extract_int (expr2, &i2);
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
- if (i2 >= gfc_integer_kinds[i3].bit_size)
+ if (or_equal)
{
- gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
- arg2, &expr2->where, arg1);
- return FAILURE;
+ if (i2 > gfc_integer_kinds[i3].bit_size)
+ {
+ gfc_error ("'%s' at %L must be less than "
+ "or equal to BIT_SIZE('%s')",
+ arg2, &expr2->where, arg1);
+ return FAILURE;
+ }
+ }
+ else
+ {
+ if (i2 >= gfc_integer_kinds[i3].bit_size)
+ {
+ gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
+ arg2, &expr2->where, arg1);
+ return FAILURE;
+ }
}
}
}
+/* If expr is constant, then check that the value is less than or equal
+ to the bit_size of the kind k. */
+
+static gfc_try
+less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
+{
+ int i, val;
+
+ if (expr->expr_type != EXPR_CONSTANT)
+ return SUCCESS;
+
+ i = gfc_validate_kind (BT_INTEGER, k, false);
+ gfc_extract_int (expr, &val);
+
+ if (val > gfc_integer_kinds[i].bit_size)
+ {
+ gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
+ "INTEGER(KIND=%d)", arg, &expr->where, k);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* If expr2 and expr3 are constants, then check that the value is less than
or equal to bit_size(expr1). */
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
- "and kind as '%s'", gfc_current_intrinsic_arg[m],
- gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
+ "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
+ gfc_current_intrinsic, &f->where,
+ gfc_current_intrinsic_arg[n]->name);
return FAILURE;
}
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, rank);
return FAILURE;
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
}
}
+/* Check for ALLOCATABLE attribute. */
+
+static gfc_try
+allocatable_check (gfc_expr *e, int n)
+{
+ symbol_attribute attr;
+
+ attr = gfc_variable_attr (e, NULL);
+ if (!attr.allocatable)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* Check that an expression has a particular kind. */
static gfc_try
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, k);
return FAILURE;
/* Make sure an expression is a variable. */
static gfc_try
-variable_check (gfc_expr *e, int n)
+variable_check (gfc_expr *e, int n, bool allow_proc)
{
- if ((e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
- || (e->expr_type == EXPR_FUNCTION
- && e->symtree->n.sym->result == e->symtree->n.sym))
- return SUCCESS;
-
if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.intent == INTENT_IN)
+ && e->symtree->n.sym->attr.intent == INTENT_IN
+ && (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], gfc_current_intrinsic,
+ 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)))))
+ return SUCCESS;
+
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
return FAILURE;
}
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)
if (dim == NULL)
return SUCCESS;
- if (dim->expr_type != EXPR_CONSTANT
- || (array->expr_type != EXPR_VARIABLE
- && array->expr_type != EXPR_ARRAY))
+ if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS;
- rank = array->rank;
+ if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
+ && array->value.function.isym->id == GFC_ISYM_SPREAD)
+ rank = array->rank + 1;
+ else
+ rank = array->rank;
+
if (array->expr_type == EXPR_VARIABLE)
{
ar = gfc_find_array_ref (array);
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;
+ }
}
gfc_try
gfc_check_allocated (gfc_expr *array)
{
- symbol_attribute attr;
-
- if (variable_check (array, 0) == FAILURE)
+ if (variable_check (array, 0, false) == FAILURE)
return FAILURE;
-
- attr = gfc_variable_attr (array, NULL);
- if (!attr.allocatable)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
- gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
- &array->where);
- return FAILURE;
- }
-
+ if (allocatable_check (array, 0) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
if (a->ts.type != p->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
- "have the same type", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ "have the same type", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&p->where);
return FAILURE;
}
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,
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pointer->where);
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;
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
- "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
- gfc_current_intrinsic, &target->where);
+ "or target VARIABLE or FUNCTION",
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &target->where);
return FAILURE;
}
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],
+ "or a TARGET", gfc_current_intrinsic_arg[1]->name,
+ gfc_current_intrinsic, &target->where);
+ 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;
}
}
+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 (n, 0, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (n->expr_type == EXPR_CONSTANT)
+ {
+ int i;
+ gfc_extract_int (n, &i);
+ if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument "
+ "N at %L", &n->where) == FAILURE)
+ return FAILURE;
+ }
if (type_check (x, 1, BT_REAL) == FAILURE)
return FAILURE;
}
+/* Transformational version of the Bessel JN and YN functions. */
+
+gfc_try
+gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
+{
+ if (type_check (n1, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (scalar_check (n1, 0) == FAILURE)
+ return FAILURE;
+ if (nonnegative_check("N1", n1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (n2, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (scalar_check (n2, 1) == FAILURE)
+ return FAILURE;
+ if (nonnegative_check("N2", n2) == FAILURE)
+ return FAILURE;
+
+ if (type_check (x, 2, BT_REAL) == FAILURE)
+ return FAILURE;
+ if (scalar_check (x, 2) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
+{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
gfc_try
gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
{
if (nonnegative_check ("pos", pos) == FAILURE)
return FAILURE;
- if (less_than_bitsize1 ("i", i, "pos", pos) == FAILURE)
+ if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
return FAILURE;
return SUCCESS;
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
- "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
- gfc_current_intrinsic, &y->where);
+ "present if 'x' is COMPLEX",
+ gfc_current_intrinsic_arg[1]->name, 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);
+ "of either REAL or INTEGER",
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &y->where);
return FAILURE;
}
gfc_try
gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
- if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or REAL", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic, &x->where);
- return FAILURE;
- }
+ if (int_or_real_check (x, 0) == FAILURE)
+ return FAILURE;
if (scalar_check (x, 0) == FAILURE)
return FAILURE;
- if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or REAL", gfc_current_intrinsic_arg[1],
- gfc_current_intrinsic, &y->where);
- return FAILURE;
- }
+ if (int_or_real_check (y, 1) == FAILURE)
+ return FAILURE;
if (scalar_check (y, 1) == FAILURE)
return FAILURE;
{
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_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
mpz_get_si (array->shape[i]),
mpz_get_si (shift->shape[j]));
else
{
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
- "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, array->rank - 1);
return FAILURE;
}
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
- "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
- gfc_current_intrinsic, &y->where);
+ "present if 'x' is COMPLEX",
+ gfc_current_intrinsic_arg[1]->name, 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);
+ "of either REAL or INTEGER",
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &y->where);
return FAILURE;
}
}
default:
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
- "or LOGICAL", gfc_current_intrinsic_arg[0],
+ "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &vector_a->where);
return FAILURE;
}
if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
{
gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
- "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], &vector_a->where);
+ "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, &vector_a->where);
return FAILURE;
}
if (x->ts.kind != gfc_default_real_kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
- "real", gfc_current_intrinsic_arg[0],
+ "real", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return FAILURE;
}
if (y->ts.kind != gfc_default_real_kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
- "real", gfc_current_intrinsic_arg[1],
+ "real", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &y->where);
return FAILURE;
}
gfc_try
+gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
+{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (same_type_check (i, 0, j, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (shift, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (nonnegative_check ("SHIFT", shift) == FAILURE)
+ return FAILURE;
+
+ if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
gfc_expr *dim)
{
{
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_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
mpz_get_si (array->shape[i]),
mpz_get_si (shift->shape[j]));
else
{
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
- "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->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_arg[1]->name,
+ gfc_current_intrinsic_arg[2]->name,
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);
+ "rank %d or be a scalar",
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &shift->where, array->rank - 1);
return FAILURE;
}
}
return FAILURE;
if ((a->ts.kind != gfc_default_integer_kind)
- && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER"
+ && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER "
"kind argument to %s intrinsic at %L",
gfc_current_intrinsic, &a->where) == 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)
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &a->where) == FAILURE)
return FAILURE;
return SUCCESS;
if (string->ts.kind != substring->ts.kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
- "kind as '%s'", gfc_current_intrinsic_arg[1],
+ "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &substring->where,
- gfc_current_intrinsic_arg[0]);
+ gfc_current_intrinsic_arg[0]->name);
return FAILURE;
}
if (x->ts.type == BT_DERIVED)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
- "non-derived type", gfc_current_intrinsic_arg[0],
+ "non-derived type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return FAILURE;
}
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 (coarray_check (coarray, 0) == FAILURE)
+ return FAILURE;
if (dim != NULL)
{
gfc_try
gfc_check_loc (gfc_expr *expr)
{
- return variable_check (expr, 0);
+ return variable_check (expr, 0, true);
}
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],
+ "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->where);
return FAILURE;
}
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],
+ "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &matrix_b->where);
return FAILURE;
}
{
gfc_error ("Different shape on dimension 1 for arguments '%s' "
"and '%s' at %L for intrinsic matmul",
- gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], &matrix_a->where);
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return FAILURE;
}
break;
{
gfc_error ("Different shape on dimension 2 for argument '%s' and "
"dimension 1 for argument '%s' at %L for intrinsic "
- "matmul", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], &matrix_a->where);
+ "matmul", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return FAILURE;
}
break;
default:
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
- "1 or 2", gfc_current_intrinsic_arg[0],
+ "1 or 2", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->where);
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_arg[0]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic ) == 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_arg[0]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic) == FAILURE)
return FAILURE;
}
+/* For IANY, IALL and IPARITY. */
+
+gfc_try
+gfc_check_mask (gfc_expr *i, gfc_expr *kind)
+{
+ int k;
+
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (nonnegative_check ("I", i) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind)
+ gfc_extract_int (kind, &k);
+ else
+ k = gfc_default_integer_kind;
+
+ if (less_than_bitsizekind ("I", i, k) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
+{
+ if (ap->expr->ts.type != BT_INTEGER)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &ap->expr->where);
+ return FAILURE;
+ }
+
+ if (array_check (ap->expr, 0) == FAILURE)
+ return FAILURE;
+
+ return check_reduction (ap);
+}
+
+
gfc_try
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
gfc_try
-gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
+gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
{
- symbol_attribute attr;
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (variable_check (from, 0) == FAILURE)
+ if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- attr = gfc_variable_attr (from, NULL);
- if (!attr.allocatable)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
- gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
- &from->where);
- return FAILURE;
- }
+ if (type_check (mask, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
- if (variable_check (to, 0) == FAILURE)
+ if (same_type_check (i, 0, j, 1) == FAILURE)
return FAILURE;
- attr = gfc_variable_attr (to, NULL);
- if (!attr.allocatable)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
- gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
- &to->where);
- return FAILURE;
- }
+ if (same_type_check (i, 0, mask, 2) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
+{
+ if (variable_check (from, 0, false) == FAILURE)
+ return FAILURE;
+ if (allocatable_check (from, 0) == FAILURE)
+ return FAILURE;
+
+ if (variable_check (to, 1, false) == FAILURE)
+ return FAILURE;
+ if (allocatable_check (to, 1) == FAILURE)
+ return FAILURE;
if (same_type_check (to, 1, from, 0) == FAILURE)
return FAILURE;
if (to->rank != from->rank)
{
gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
- "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&to->where, from->rank, to->rank);
return FAILURE;
}
if (to->ts.kind != from->ts.kind)
{
gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
- "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ "be of the same kind %d/%d",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&to->where, from->ts.kind, to->ts.kind);
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;
}
gfc_try
+gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
+{
+ if (type_check (array, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ if (array_check (array, 0) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, false) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+gfc_try
gfc_check_null (gfc_expr *mold)
{
symbol_attribute attr;
if (mold == NULL)
return SUCCESS;
- if (variable_check (mold, 0) == FAILURE)
+ if (variable_check (mold, 0, true) == FAILURE)
return FAILURE;
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_current_intrinsic_arg[0],
+ 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;
}
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_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic) == FAILURE)
return FAILURE;
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],
+ gfc_current_intrinsic_arg[2]->name,
+ gfc_current_intrinsic, &vector->where,
+ gfc_current_intrinsic_arg[1]->name,
mpz_get_si (vector_size), mask_true_values);
return FAILURE;
}
gfc_try
+gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
+{
+ if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
+ if (array_check (mask, 0) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, mask, false) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_precision (gfc_expr *x)
{
- if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
- "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic, &x->where);
- return FAILURE;
- }
+ if (real_or_complex_check (x, 0) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
{
gfc_symbol *sym;
- if (variable_check (a, 0) == FAILURE)
+ if (variable_check (a, 0, true) == FAILURE)
return FAILURE;
sym = a->symtree->n.sym;
if (!sym->attr.dummy)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
- "dummy variable", gfc_current_intrinsic_arg[0],
+ "dummy variable", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where);
return FAILURE;
}
if (!sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
- "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic, &a->where);
+ "an OPTIONAL dummy variable",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &a->where);
return FAILURE;
}
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],
+ "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where, sym->name);
return FAILURE;
}
}
+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)
if (shape_size <= 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&shape->where);
return FAILURE;
}
if (extent < 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
- "negative element (%d)", gfc_current_intrinsic_arg[1],
+ "negative element (%d)",
+ gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &e->where, extent);
return FAILURE;
}
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
"has wrong number of elements (%d/%d)",
- gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &order->where,
order_size, shape_size);
return FAILURE;
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
"has out-of-range dimension (%d)",
- gfc_current_intrinsic_arg[3],
+ gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
return FAILURE;
}
{
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
"invalid permutation of dimensions (dimension "
- "'%d' duplicated)", gfc_current_intrinsic_arg[3],
+ "'%d' duplicated)",
+ gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
return FAILURE;
}
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);
+ "must be of a derived type",
+ gfc_current_intrinsic_arg[0]->name, 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);
+ "must be of an extensible type",
+ gfc_current_intrinsic_arg[0]->name, 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);
+ "must be of a derived type",
+ gfc_current_intrinsic_arg[1]->name, 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);
+ "must be of an extensible type",
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &b->where);
return FAILURE;
}
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_shift (gfc_expr *i, gfc_expr *shift)
+{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (shift, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (nonnegative_check ("SHIFT", shift) == FAILURE)
+ return FAILURE;
+
+ if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
gfc_try
+gfc_check_c_sizeof (gfc_expr *arg)
+{
+ if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
+ {
+ 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;
+ }
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_sleep_sub (gfc_expr *seconds)
{
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
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;
if (source->rank >= GFC_MAX_DIMENSIONS)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
- "than rank %d", gfc_current_intrinsic_arg[0],
+ "than rank %d", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
return FAILURE;
|| 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],
+ "dimension index", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &dim->where);
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 (!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 (coarray_check (coarray, 0) == FAILURE)
+ 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);
+ gfc_current_intrinsic_arg[1]->name, &sub->where);
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;
}
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 (coarray_check (coarray, 0) == FAILURE)
+ return FAILURE;
if (dim != NULL)
{
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;
}
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 (coarray_check (coarray, 0) == FAILURE)
+ return FAILURE;
if (dim != NULL)
{
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],
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &vector->where, gfc_current_intrinsic_arg[1]->name,
mpz_get_si (vector_size), mask_true_count);
return FAILURE;
}
{
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]);
+ gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
+ &field->where, gfc_current_intrinsic_arg[1]->name);
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,
+ gfc_current_intrinsic_arg[2]->name,
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&field->where);
}
}
if (type_check (time, 0, BT_REAL) == FAILURE)
return FAILURE;
- if (variable_check (time, 0) == FAILURE)
+ if (variable_check (time, 0, false) == FAILURE)
return FAILURE;
return SUCCESS;
return FAILURE;
if (scalar_check (date, 0) == FAILURE)
return FAILURE;
- if (variable_check (date, 0) == FAILURE)
+ if (variable_check (date, 0, false) == FAILURE)
return FAILURE;
}
return FAILURE;
if (scalar_check (time, 1) == FAILURE)
return FAILURE;
- if (variable_check (time, 1) == FAILURE)
+ if (variable_check (time, 1, false) == FAILURE)
return FAILURE;
}
return FAILURE;
if (scalar_check (zone, 2) == FAILURE)
return FAILURE;
- if (variable_check (zone, 2) == FAILURE)
+ if (variable_check (zone, 2, false) == FAILURE)
return FAILURE;
}
return FAILURE;
if (rank_check (values, 3, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 3) == FAILURE)
+ if (variable_check (values, 3, false) == FAILURE)
return FAILURE;
}
if (same_type_check (from, 0, to, 3) == FAILURE)
return FAILURE;
- if (variable_check (to, 3) == FAILURE)
+ if (variable_check (to, 3, false) == FAILURE)
return FAILURE;
if (type_check (topos, 4, BT_INTEGER) == FAILURE)
if (type_check (harvest, 0, BT_REAL) == FAILURE)
return FAILURE;
- if (variable_check (harvest, 0) == FAILURE)
+ if (variable_check (harvest, 0, false) == FAILURE)
return FAILURE;
return SUCCESS;
if (type_check (size, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (size, 0) == FAILURE)
+ if (variable_check (size, 0, false) == FAILURE)
return FAILURE;
if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
&& 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);
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ where, (int) mpz_get_ui (put_size), kiss_size);
}
if (get != NULL)
if (type_check (get, 2, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (get, 2) == FAILURE)
+ if (variable_check (get, 2, false) == FAILURE)
return FAILURE;
if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
&& 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);
+ gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
+ where, (int) mpz_get_ui (get_size), kiss_size);
}
/* RANDOM_SEED may not have more than one non-optional argument. */
if (type_check (count, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (count, 0) == FAILURE)
+ if (variable_check (count, 0, false) == FAILURE)
return FAILURE;
}
if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (count_rate, 1) == FAILURE)
+ if (variable_check (count_rate, 1, false) == FAILURE)
return FAILURE;
if (count != NULL
if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (count_max, 2) == FAILURE)
+ if (variable_check (count_max, 2, false) == FAILURE)
return FAILURE;
if (count != NULL
{
if (scalar_check (seconds, 0) == FAILURE)
return FAILURE;
-
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or PROCEDURE", gfc_current_intrinsic_arg[1],
- gfc_current_intrinsic, &handler->where);
- return FAILURE;
- }
-
+ if (int_or_proc_check (handler, 1) == FAILURE)
+ return FAILURE;
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
-
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
-
if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
return FAILURE;
if (rank_check (x, 0, 1) == FAILURE)
return FAILURE;
- if (variable_check (x, 0) == FAILURE)
+ if (variable_check (x, 0, false) == FAILURE)
return FAILURE;
if (type_check (x, 0, BT_REAL) == FAILURE)
if (rank_check (values, 0, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 0) == FAILURE)
+ if (variable_check (values, 0, false) == FAILURE)
return FAILURE;
if (type_check (values, 0, BT_REAL) == FAILURE)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
"not wider than the default kind (%d)",
- gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pos->where, gfc_default_integer_kind);
return FAILURE;
}
if (rank_check (values, 0, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 0) == FAILURE)
+ if (variable_check (values, 0, false) == FAILURE)
return FAILURE;
if (type_check (values, 0, BT_INTEGER) == FAILURE)
if (rank_check (values, 1, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 1) == FAILURE)
+ if (variable_check (values, 1, false) == FAILURE)
return FAILURE;
if (type_check (values, 1, BT_INTEGER) == FAILURE)
{
if (scalar_check (number, 0) == FAILURE)
return FAILURE;
-
if (type_check (number, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or PROCEDURE", gfc_current_intrinsic_arg[1],
- gfc_current_intrinsic, &handler->where);
- return FAILURE;
- }
-
+ if (int_or_proc_check (handler, 1) == FAILURE)
+ return FAILURE;
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
{
if (scalar_check (number, 0) == FAILURE)
return FAILURE;
-
if (type_check (number, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or PROCEDURE", gfc_current_intrinsic_arg[1],
- gfc_current_intrinsic, &handler->where);
- return FAILURE;
- }
-
+ if (int_or_proc_check (handler, 1) == FAILURE)
+ return FAILURE;
if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
return FAILURE;
if (type_check (status, 2, BT_INTEGER) == FAILURE)
return FAILURE;
-
if (scalar_check (status, 2) == FAILURE)
return FAILURE;
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or LOGICAL", gfc_current_intrinsic_arg[0],
+ "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &i->where);
return FAILURE;
}
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
- "or LOGICAL", gfc_current_intrinsic_arg[1],
+ "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
return FAILURE;
}
if (i->ts.type != j->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
- "have the same type", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ "have the same type", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&j->where);
return FAILURE;
}
return SUCCESS;
}
+
+
+gfc_try
+gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+ if (kind == NULL)
+ return SUCCESS;
+
+ if (type_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (kind, 1) == FAILURE)
+ return FAILURE;
+
+ if (kind->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &kind->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
OSDN Git Service
