intrinsic at %L has more "
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
return false;
}
else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
{
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 ("%qs argument of %qs intrinsic at %L has "
"negative element (%d)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &e->where, extent);
return false;
}
}
}
else if (shape->expr_type == EXPR_VARIABLE && shape->ref
&& shape->ref->u.ar.type == AR_FULL && shape->ref->u.ar.dimen == 1
&& shape->ref->u.ar.as
&& shape->ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
&& shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER
&& shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT
&& shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER
&& shape->symtree->n.sym->attr.flavor == FL_PARAMETER
&& shape->symtree->n.sym->value)
{
int i, extent;
gfc_expr *e, *v;
v = shape->symtree->n.sym->value;
for (i = 0; i < shape_size; i++)
{
e = gfc_constructor_lookup_expr (v->value.constructor, i);
if (e == NULL)
break;
gfc_extract_int (e, &extent);
if (extent < 0)
{
gfc_error ("Element %d of actual argument of RESHAPE at %L "
"cannot be negative", i + 1, &shape->where);
return false;
}
}
}
if (pad != NULL)
{
if (!same_type_check (source, 0, pad, 2))
return false;
if (!array_check (pad, 2))
return false;
}
if (order != NULL)
{
if (!array_check (order, 3))
return false;
if (!type_check (order, 3, BT_INTEGER))
return false;
if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
{
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 ("%qs argument of %qs intrinsic at %L "
"has wrong number of elements (%d/%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &order->where,
order_size, shape_size);
return false;
}
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 ("%qs argument of %qs intrinsic at %L "
"has out-of-range dimension (%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
return false;
}
if (perm[dim-1] != 0)
{
gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid permutation of dimensions (dimension "
"%qd duplicated)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
return false;
}
perm[dim-1] = 1;
}
}
}
if (pad == NULL && shape->expr_type == EXPR_ARRAY
&& gfc_is_constant_expr (shape)
&& !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
&& source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
{
/* Check the match in size between source and destination. */
if (gfc_array_size (source, &nelems))
{
gfc_constructor *c;
bool test;
mpz_init_set_ui (size, 1);
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;
mpz_clear (nelems);
mpz_clear (size);
if (test)
{
gfc_error ("Without padding, there are not enough elements "
"in the intrinsic RESHAPE source at %L to match "
"the shape", &source->where);
return false;
}
}
}
return true;
}
bool
gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
{
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
{
gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
&a->where, gfc_typename (a));
return false;
}
if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
{
gfc_error ("%qs argument of %qs intrinsic at %L "
"must be of an extensible type",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
return false;
}
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
{
gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
&b->where, gfc_typename (b));
return false;
}
if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
{
gfc_error ("%qs argument of %qs intrinsic at %L "
"must be of an extensible type",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&b->where);
return false;
}
return true;
}
bool
gfc_check_scale (gfc_expr *x, gfc_expr *i)
{
if (!type_check (x, 0, BT_REAL))
return false;
if (!type_check (i, 1, BT_INTEGER))
return false;
return true;
}
bool
gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (!type_check (x, 0, BT_CHARACTER))
return false;
if (!type_check (y, 1, BT_CHARACTER))
return false;
if (z != NULL && !type_check (z, 2, BT_LOGICAL))
return false;
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
if (!same_type_check (x, 0, y, 1))
return false;
return true;
}
bool
gfc_check_secnds (gfc_expr *r)
{
if (!type_check (r, 0, BT_REAL))
return false;
if (!kind_value_check (r, 0, 4))
return false;
if (!scalar_check (r, 0))
return false;
return true;
}
bool
gfc_check_selected_char_kind (gfc_expr *name)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
if (!scalar_check (name, 0))
return false;
return true;
}
bool
gfc_check_selected_int_kind (gfc_expr *r)
{
if (!type_check (r, 0, BT_INTEGER))
return false;
if (!scalar_check (r, 0))
return false;
return true;
}
bool
gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
{
if (p == NULL && r == NULL
&& !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
" neither % nor % argument at %L",
gfc_current_intrinsic_where))
return false;
if (p)
{
if (!type_check (p, 0, BT_INTEGER))
return false;
if (!scalar_check (p, 0))
return false;
}
if (r)
{
if (!type_check (r, 1, BT_INTEGER))
return false;
if (!scalar_check (r, 1))
return false;
}
if (radix)
{
if (!type_check (radix, 1, BT_INTEGER))
return false;
if (!scalar_check (radix, 1))
return false;
if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
"RADIX argument at %L", gfc_current_intrinsic,
&radix->where))
return false;
}
return true;
}
bool
gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
{
if (!type_check (x, 0, BT_REAL))
return false;
if (!type_check (i, 1, BT_INTEGER))
return false;
return true;
}
bool
gfc_check_shape (gfc_expr *source, gfc_expr *kind)
{
gfc_array_ref *ar;
if (gfc_invalid_null_arg (source))
return false;
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
return true;
ar = gfc_find_array_ref (source);
if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
{
gfc_error ("% argument of % intrinsic at %L must not be "
"an assumed size array", &source->where);
return false;
}
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
return true;
}
bool
gfc_check_shift (gfc_expr *i, gfc_expr *shift)
{
if (!type_check (i, 0, BT_INTEGER))
return false;
if (!type_check (shift, 0, BT_INTEGER))
return false;
if (!nonnegative_check ("SHIFT", shift))
return false;
if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
return false;
return true;
}
bool
gfc_check_sign (gfc_expr *a, gfc_expr *b)
{
if (!int_or_real_check (a, 0))
return false;
if (!same_type_check (a, 0, b, 1))
return false;
return true;
}
bool
gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (!array_check (array, 0))
return false;
if (!dim_check (dim, 1, true))
return false;
if (!dim_rank_check (dim, array, 0))
return false;
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
return true;
}
bool
gfc_check_sizeof (gfc_expr *arg)
{
if (gfc_invalid_null_arg (arg))
return false;
if (arg->ts.type == BT_PROCEDURE)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return false;
}
/* TYPE(*) is acceptable if and only if it uses an array descriptor. */
if (arg->ts.type == BT_ASSUMED
&& (arg->symtree->n.sym->as == NULL
|| (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
&& arg->symtree->n.sym->as->type != AS_DEFERRED
&& arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return false;
}
if (arg->rank && arg->expr_type == EXPR_VARIABLE
&& arg->symtree->n.sym->as != NULL
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
"assumed-size array", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &arg->where);
return false;
}
return true;
}
/* Check whether an expression is interoperable. When returning false,
msg is set to a string telling why the expression is not interoperable,
otherwise, it is set to NULL. The msg string can be used in diagnostics.
If c_loc is true, character with len > 1 are allowed (cf. Fortran
2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
are permitted. */
static bool
is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
{
*msg = NULL;
if (expr->ts.type == BT_CLASS)
{
*msg = "Expression is polymorphic";
return false;
}
if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
&& !expr->ts.u.derived->ts.is_iso_c)
{
*msg = "Expression is a noninteroperable derived type";
return false;
}
if (expr->ts.type == BT_PROCEDURE)
{
*msg = "Procedure unexpected as argument";
return false;
}
if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
{
int i;
for (i = 0; gfc_logical_kinds[i].kind; i++)
if (gfc_logical_kinds[i].kind == expr->ts.kind)
return true;
*msg = "Extension to use a non-C_Bool-kind LOGICAL";
return false;
}
if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
&& expr->ts.kind != 1)
{
*msg = "Extension to use a non-C_CHAR-kind CHARACTER";
return false;
}
if (expr->ts.type == BT_CHARACTER) {
if (expr->ts.deferred)
{
/* TS 29113 allows deferred-length strings as dummy arguments,
but it is not an interoperable type. */
*msg = "Expression shall not be a deferred-length string";
return false;
}
if (expr->ts.u.cl && expr->ts.u.cl->length
&& !gfc_simplify_expr (expr->ts.u.cl->length, 0))
gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
if (!c_loc && expr->ts.u.cl
&& (!expr->ts.u.cl->length
|| expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
{
*msg = "Type shall have a character length of 1";
return false;
}
}
/* Note: The following checks are about interoperatable variables, Fortran
15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
is allowed, e.g. assumed-shape arrays with TS 29113. */
if (gfc_is_coarray (expr))
{
*msg = "Coarrays are not interoperable";
return false;
}
if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
{
gfc_array_ref *ar = gfc_find_array_ref (expr);
if (ar->type != AR_FULL)
{
*msg = "Only whole-arrays are interoperable";
return false;
}
if (!c_f_ptr && ar->as->type != AS_EXPLICIT
&& ar->as->type != AS_ASSUMED_SIZE)
{
*msg = "Only explicit-size and assumed-size arrays are interoperable";
return false;
}
}
return true;
}
bool
gfc_check_c_sizeof (gfc_expr *arg)
{
const char *msg;
if (!is_c_interoperable (arg, &msg, false, false))
{
gfc_error ("%qs argument of %qs intrinsic at %L must be an "
"interoperable data entity: %s",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where, msg);
return false;
}
if (arg->ts.type == BT_ASSUMED)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return false;
}
if (arg->rank && arg->expr_type == EXPR_VARIABLE
&& arg->symtree->n.sym->as != NULL
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
"assumed-size array", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &arg->where);
return false;
}
return true;
}
bool
gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
{
if (c_ptr_1->ts.type != BT_DERIVED
|| c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
&& c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
{
gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
"type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
return false;
}
if (!scalar_check (c_ptr_1, 0))
return false;
if (c_ptr_2
&& (c_ptr_2->ts.type != BT_DERIVED
|| c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| (c_ptr_1->ts.u.derived->intmod_sym_id
!= c_ptr_2->ts.u.derived->intmod_sym_id)))
{
gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
"same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
gfc_typename (&c_ptr_1->ts),
gfc_typename (&c_ptr_2->ts));
return false;
}
if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
return false;
return true;
}
bool
gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
{
symbol_attribute attr;
const char *msg;
if (cptr->ts.type != BT_DERIVED
|| cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
{
gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
"type TYPE(C_PTR)", &cptr->where);
return false;
}
if (!scalar_check (cptr, 0))
return false;
attr = gfc_expr_attr (fptr);
if (!attr.pointer)
{
gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
&fptr->where);
return false;
}
if (fptr->ts.type == BT_CLASS)
{
gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
&fptr->where);
return false;
}
if (gfc_is_coindexed (fptr))
{
gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
"coindexed", &fptr->where);
return false;
}
if (fptr->rank == 0 && shape)
{
gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
"FPTR", &fptr->where);
return false;
}
else if (fptr->rank && !shape)
{
gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
"FPTR at %L", &fptr->where);
return false;
}
if (shape && !rank_check (shape, 2, 1))
return false;
if (shape && !type_check (shape, 2, BT_INTEGER))
return false;
if (shape)
{
mpz_t size;
if (gfc_array_size (shape, &size))
{
if (mpz_cmp_ui (size, fptr->rank) != 0)
{
mpz_clear (size);
gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
"size as the RANK of FPTR", &shape->where);
return false;
}
mpz_clear (size);
}
}
if (fptr->ts.type == BT_CLASS)
{
gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
return false;
}
if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true))
return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR "
"at %L to C_F_POINTER: %s", &fptr->where, msg);
return true;
}
bool
gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
{
symbol_attribute attr;
if (cptr->ts.type != BT_DERIVED
|| cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
{
gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
"type TYPE(C_FUNPTR)", &cptr->where);
return false;
}
if (!scalar_check (cptr, 0))
return false;
attr = gfc_expr_attr (fptr);
if (!attr.proc_pointer)
{
gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
"pointer", &fptr->where);
return false;
}
if (gfc_is_coindexed (fptr))
{
gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
"coindexed", &fptr->where);
return false;
}
if (!attr.is_bind_c)
return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
"pointer at %L to C_F_PROCPOINTER", &fptr->where);
return true;
}
bool
gfc_check_c_funloc (gfc_expr *x)
{
symbol_attribute attr;
if (gfc_is_coindexed (x))
{
gfc_error ("Argument X at %L to C_FUNLOC shall not be "
"coindexed", &x->where);
return false;
}
attr = gfc_expr_attr (x);
if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
&& x->symtree->n.sym == x->symtree->n.sym->result)
for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
if (x->symtree->n.sym == ns->proc_name)
{
gfc_error ("Function result %qs at %L is invalid as X argument "
"to C_FUNLOC", x->symtree->n.sym->name, &x->where);
return false;
}
if (attr.flavor != FL_PROCEDURE)
{
gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
"or a procedure pointer", &x->where);
return false;
}
if (!attr.is_bind_c)
return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
"at %L to C_FUNLOC", &x->where);
return true;
}
bool
gfc_check_c_loc (gfc_expr *x)
{
symbol_attribute attr;
const char *msg;
if (gfc_is_coindexed (x))
{
gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
return false;
}
if (x->ts.type == BT_CLASS)
{
gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
&x->where);
return false;
}
attr = gfc_expr_attr (x);
if (!attr.pointer
&& (x->expr_type != EXPR_VARIABLE || !attr.target
|| attr.flavor == FL_PARAMETER))
{
gfc_error ("Argument X at %L to C_LOC shall have either "
"the POINTER or the TARGET attribute", &x->where);
return false;
}
if (x->ts.type == BT_CHARACTER
&& gfc_var_strlen (x) == 0)
{
gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
"string", &x->where);
return false;
}
if (!is_c_interoperable (x, &msg, true, false))
{
if (x->ts.type == BT_CLASS)
{
gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
&x->where);
return false;
}
if (x->rank
&& !gfc_notify_std (GFC_STD_F2018,
"Noninteroperable array at %L as"
" argument to C_LOC: %s", &x->where, msg))
return false;
}
else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
{
gfc_array_ref *ar = gfc_find_array_ref (x);
if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
&& !attr.allocatable
&& !gfc_notify_std (GFC_STD_F2008,
"Array of interoperable type at %L "
"to C_LOC which is nonallocatable and neither "
"assumed size nor explicit size", &x->where))
return false;
else if (ar->type != AR_FULL
&& !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
"to C_LOC", &x->where))
return false;
}
return true;
}
bool
gfc_check_sleep_sub (gfc_expr *seconds)
{
if (!type_check (seconds, 0, BT_INTEGER))
return false;
if (!scalar_check (seconds, 0))
return false;
return true;
}
bool
gfc_check_sngl (gfc_expr *a)
{
if (!type_check (a, 0, BT_REAL))
return false;
if ((a->ts.kind != gfc_default_double_kind)
&& !gfc_notify_std (GFC_STD_GNU, "non double precision "
"REAL argument to %s intrinsic at %L",
gfc_current_intrinsic, &a->where))
return false;
return true;
}
bool
gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
{
if (gfc_invalid_null_arg (source))
return false;
if (source->rank >= GFC_MAX_DIMENSIONS)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be less "
"than rank %d", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
return false;
}
if (dim == NULL)
return false;
if (!dim_check (dim, 1, false))
return false;
/* 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 ("%qs argument of %qs intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &dim->where);
return false;
}
if (!type_check (ncopies, 2, BT_INTEGER))
return false;
if (!scalar_check (ncopies, 2))
return false;
return true;
}
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
functions). */
bool
gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
if (!type_check (c, 1, BT_CHARACTER))
return false;
if (!kind_value_check (c, 1, gfc_default_character_kind))
return false;
if (status == NULL)
return true;
if (!type_check (status, 2, BT_INTEGER)
|| !kind_value_check (status, 2, gfc_default_integer_kind)
|| !scalar_check (status, 2))
return false;
return true;
}
bool
gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
{
return gfc_check_fgetputc_sub (unit, c, NULL);
}
bool
gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
{
if (!type_check (c, 0, BT_CHARACTER))
return false;
if (!kind_value_check (c, 0, gfc_default_character_kind))
return false;
if (status == NULL)
return true;
if (!type_check (status, 1, BT_INTEGER)
|| !kind_value_check (status, 1, gfc_default_integer_kind)
|| !scalar_check (status, 1))
return false;
return true;
}
bool
gfc_check_fgetput (gfc_expr *c)
{
return gfc_check_fgetput_sub (c, NULL);
}
bool
gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
if (!type_check (offset, 1, BT_INTEGER))
return false;
if (!scalar_check (offset, 1))
return false;
if (!type_check (whence, 2, BT_INTEGER))
return false;
if (!scalar_check (whence, 2))
return false;
if (status == NULL)
return true;
if (!type_check (status, 3, BT_INTEGER))
return false;
if (!kind_value_check (status, 3, 4))
return false;
if (!scalar_check (status, 3))
return false;
return true;
}
bool
gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
if (!type_check (array, 1, BT_INTEGER)
|| !kind_value_check (unit, 0, gfc_default_integer_kind))
return false;
if (!array_check (array, 1))
return false;
return true;
}
bool
gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
if (!type_check (array, 1, BT_INTEGER)
|| !kind_value_check (array, 1, gfc_default_integer_kind))
return false;
if (!array_check (array, 1))
return false;
if (status == NULL)
return true;
if (!type_check (status, 2, BT_INTEGER)
|| !kind_value_check (status, 2, gfc_default_integer_kind))
return false;
if (!scalar_check (status, 2))
return false;
return true;
}
bool
gfc_check_ftell (gfc_expr *unit)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
return true;
}
bool
gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
if (!type_check (offset, 1, BT_INTEGER))
return false;
if (!scalar_check (offset, 1))
return false;
return true;
}
bool
gfc_check_stat (gfc_expr *name, gfc_expr *array)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
if (!type_check (array, 1, BT_INTEGER)
|| !kind_value_check (array, 1, gfc_default_integer_kind))
return false;
if (!array_check (array, 1))
return false;
return true;
}
bool
gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
if (!type_check (array, 1, BT_INTEGER)
|| !kind_value_check (array, 1, gfc_default_integer_kind))
return false;
if (!array_check (array, 1))
return false;
if (status == NULL)
return true;
if (!type_check (status, 2, BT_INTEGER)
|| !kind_value_check (array, 1, gfc_default_integer_kind))
return false;
if (!scalar_check (status, 2))
return false;
return true;
}
bool
gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
{
mpz_t nelems;
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
}
if (!coarray_check (coarray, 0))
return false;
if (sub->rank != 1)
{
gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
gfc_current_intrinsic_arg[1]->name, &sub->where);
return false;
}
if (gfc_array_size (sub, &nelems))
{
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 false;
}
mpz_clear (nelems);
}
return true;
}
bool
gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
}
if (distance)
{
if (!type_check (distance, 0, BT_INTEGER))
return false;
if (!nonnegative_check ("DISTANCE", distance))
return false;
if (!scalar_check (distance, 0))
return false;
if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
"NUM_IMAGES at %L", &distance->where))
return false;
}
if (failed)
{
if (!type_check (failed, 1, BT_LOGICAL))
return false;
if (!scalar_check (failed, 1))
return false;
if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to "
"NUM_IMAGES at %L", &failed->where))
return false;
}
return true;
}
bool
gfc_check_team_number (gfc_expr *team)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
}
if (team)
{
if (team->ts.type != BT_DERIVED
|| team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
|| team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
{
gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
"shall be of type TEAM_TYPE", &team->where);
return false;
}
}
else
return true;
return true;
}
bool
gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
}
if (coarray == NULL && dim == NULL && distance == NULL)
return true;
if (dim != NULL && coarray == NULL)
{
gfc_error ("DIM argument without COARRAY argument not allowed for "
"THIS_IMAGE intrinsic at %L", &dim->where);
return false;
}
if (distance && (coarray || dim))
{
gfc_error ("The DISTANCE argument may not be specified together with the "
"COARRAY or DIM argument in intrinsic at %L",
&distance->where);
return false;
}
/* Assume that we have "this_image (distance)". */
if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
{
if (dim)
{
gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
&coarray->where);
return false;
}
distance = coarray;
}
if (distance)
{
if (!type_check (distance, 2, BT_INTEGER))
return false;
if (!nonnegative_check ("DISTANCE", distance))
return false;
if (!scalar_check (distance, 2))
return false;
if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
"THIS_IMAGE at %L", &distance->where))
return false;
return true;
}
if (!coarray_check (coarray, 0))
return false;
if (dim != NULL)
{
if (!dim_check (dim, 1, false))
return false;
if (!dim_corank_check (dim, coarray))
return false;
}
return true;
}
/* Calculate the sizes for transfer, used by gfc_check_transfer and also
by gfc_simplify_transfer. Return false if we cannot do so. */
bool
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;
if (source->expr_type == EXPR_FUNCTION)
return false;
if (size && size->expr_type != EXPR_CONSTANT)
return false;
/* Calculate the size of the source. */
if (!gfc_target_expr_size (source, source_size))
return false;
/* Determine the size of the element. */
if (!gfc_element_size (mold, &result_elt_size))
return false;
/* If the storage size of SOURCE is greater than zero and MOLD is an array,
* a scalar with the type and type parameters of MOLD shall not have a
* storage size equal to zero.
* If MOLD is a scalar and SIZE is absent, the result is a scalar.
* If MOLD is an array and SIZE is absent, the result is an array and of
* rank one. Its size is as small as possible such that its physical
* representation is not shorter than that of SOURCE.
* If SIZE is present, the result is an array of rank one and size SIZE.
*/
if (result_elt_size == 0 && *source_size > 0 && !size
&& mold->expr_type == EXPR_ARRAY)
{
gfc_error ("% argument of % intrinsic at %L is an "
"array and shall not have storage size 0 when % "
"argument has size greater than 0", &mold->where);
return false;
}
if (result_elt_size == 0 && *source_size == 0 && !size)
{
*result_size = 0;
if (result_length_p)
*result_length_p = 0;
return true;
}
if ((result_elt_size > 0 && (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 true;
}
bool
gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
size_t source_size;
size_t result_size;
if (gfc_invalid_null_arg (source))
return false;
/* SOURCE shall be a scalar or array of any type. */
if (source->ts.type == BT_PROCEDURE
&& source->symtree->n.sym->attr.subroutine == 1)
{
gfc_error ("% argument of % intrinsic at %L "
"must not be a %s", &source->where,
gfc_basic_typename (source->ts.type));
return false;
}
if (source->ts.type == BT_BOZ && illegal_boz_arg (source))
return false;
if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
return false;
if (gfc_invalid_null_arg (mold))
return false;
/* MOLD shall be a scalar or array of any type. */
if (mold->ts.type == BT_PROCEDURE
&& mold->symtree->n.sym->attr.subroutine == 1)
{
gfc_error ("% argument of % intrinsic at %L "
"must not be a %s", &mold->where,
gfc_basic_typename (mold->ts.type));
return false;
}
if (mold->ts.type == BT_HOLLERITH)
{
gfc_error ("% argument of % intrinsic at %L must not be"
" %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
return false;
}
/* SIZE (optional) shall be an integer scalar. The corresponding actual
argument shall not be an optional dummy argument. */
if (size != NULL)
{
if (!type_check (size, 2, BT_INTEGER))
{
if (size->ts.type == BT_BOZ)
reset_boz (size);
return false;
}
if (!scalar_check (size, 2))
return false;
if (!nonoptional_check (size, 2))
return false;
}
if (!warn_surprising)
return true;
/* If we can't calculate the sizes, we cannot check any more.
Return true for that case. */
if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
&result_size, NULL))
return true;
if (source_size < result_size)
gfc_warning (OPT_Wsurprising,
"Intrinsic TRANSFER at %L has partly undefined result: "
"source size %ld < result size %ld", &source->where,
(long) source_size, (long) result_size);
return true;
}
bool
gfc_check_transpose (gfc_expr *matrix)
{
if (!rank_check (matrix, 0, 2))
return false;
return true;
}
bool
gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (!array_check (array, 0))
return false;
if (!dim_check (dim, 1, false))
return false;
if (!dim_rank_check (dim, array, 0))
return false;
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
return true;
}
bool
gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
}
if (!coarray_check (coarray, 0))
return false;
if (dim != NULL)
{
if (!dim_check (dim, 1, false))
return false;
if (!dim_corank_check (dim, coarray))
return false;
}
if (!kind_check (kind, 2, BT_INTEGER))
return false;
return true;
}
bool
gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
{
mpz_t vector_size;
if (!rank_check (vector, 0, 1))
return false;
if (!array_check (mask, 1))
return false;
if (!type_check (mask, 1, BT_LOGICAL))
return false;
if (!same_type_check (vector, 0, field, 2))
return false;
if (mask->expr_type == EXPR_ARRAY
&& gfc_array_size (vector, &vector_size))
{
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 ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
"are .TRUE. values in %qs (%ld/%d)",
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 false;
}
mpz_clear (vector_size);
}
if (mask->rank != field->rank && field->rank != 0)
{
gfc_error ("%qs argument of %qs intrinsic at %L must have "
"the same rank as %qs or be a scalar",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
&field->where, gfc_current_intrinsic_arg[1]->name);
return false;
}
if (mask->rank == field->rank)
{
int i;
for (i = 0; i < field->rank; i++)
if (! identical_dimen_shape (mask, i, field, i))
{
gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
"must have identical shape.",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&field->where);
}
}
return true;
}
bool
gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (!type_check (x, 0, BT_CHARACTER))
return false;
if (!same_type_check (x, 0, y, 1))
return false;
if (z != NULL && !type_check (z, 2, BT_LOGICAL))
return false;
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
return true;
}
bool
gfc_check_trim (gfc_expr *x)
{
if (!type_check (x, 0, BT_CHARACTER))
return false;
if (gfc_invalid_null_arg (x))
return false;
if (!scalar_check (x, 0))
return false;
return true;
}
bool
gfc_check_ttynam (gfc_expr *unit)
{
if (!scalar_check (unit, 0))
return false;
if (!type_check (unit, 0, BT_INTEGER))
return false;
return true;
}
/************* Check functions for intrinsic subroutines *************/
bool
gfc_check_cpu_time (gfc_expr *time)
{
if (!scalar_check (time, 0))
return false;
if (!type_check (time, 0, BT_REAL))
return false;
if (!variable_check (time, 0, false))
return false;
return true;
}
bool
gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
gfc_expr *zone, gfc_expr *values)
{
if (date != NULL)
{
if (!type_check (date, 0, BT_CHARACTER))
return false;
if (!kind_value_check (date, 0, gfc_default_character_kind))
return false;
if (!scalar_check (date, 0))
return false;
if (!variable_check (date, 0, false))
return false;
}
if (time != NULL)
{
if (!type_check (time, 1, BT_CHARACTER))
return false;
if (!kind_value_check (time, 1, gfc_default_character_kind))
return false;
if (!scalar_check (time, 1))
return false;
if (!variable_check (time, 1, false))
return false;
}
if (zone != NULL)
{
if (!type_check (zone, 2, BT_CHARACTER))
return false;
if (!kind_value_check (zone, 2, gfc_default_character_kind))
return false;
if (!scalar_check (zone, 2))
return false;
if (!variable_check (zone, 2, false))
return false;
}
if (values != NULL)
{
if (!type_check (values, 3, BT_INTEGER))
return false;
if (!array_check (values, 3))
return false;
if (!rank_check (values, 3, 1))
return false;
if (!variable_check (values, 3, false))
return false;
}
return true;
}
bool
gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
gfc_expr *to, gfc_expr *topos)
{
if (!type_check (from, 0, BT_INTEGER))
return false;
if (!type_check (frompos, 1, BT_INTEGER))
return false;
if (!type_check (len, 2, BT_INTEGER))
return false;
if (!same_type_check (from, 0, to, 3))
return false;
if (!variable_check (to, 3, false))
return false;
if (!type_check (topos, 4, BT_INTEGER))
return false;
if (!nonnegative_check ("frompos", frompos))
return false;
if (!nonnegative_check ("topos", topos))
return false;
if (!nonnegative_check ("len", len))
return false;
if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
return false;
if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
return false;
return true;
}
/* Check the arguments for RANDOM_INIT. */
bool
gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
{
if (!type_check (repeatable, 0, BT_LOGICAL))
return false;
if (!scalar_check (repeatable, 0))
return false;
if (!type_check (image_distinct, 1, BT_LOGICAL))
return false;
if (!scalar_check (image_distinct, 1))
return false;
return true;
}
bool
gfc_check_random_number (gfc_expr *harvest)
{
if (!type_check (harvest, 0, BT_REAL))
return false;
if (!variable_check (harvest, 0, false))
return false;
return true;
}
bool
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
unsigned int nargs = 0, seed_size;
locus *where = NULL;
mpz_t put_size, get_size;
/* Keep the number of bytes in sync with master_state in
libgfortran/intrinsics/random.c. */
seed_size = 32 / gfc_default_integer_kind;
if (size != NULL)
{
if (size->expr_type != EXPR_VARIABLE
|| !size->symtree->n.sym->attr.optional)
nargs++;
if (!scalar_check (size, 0))
return false;
if (!type_check (size, 0, BT_INTEGER))
return false;
if (!variable_check (size, 0, false))
return false;
if (!kind_value_check (size, 0, gfc_default_integer_kind))
return false;
}
if (put != NULL)
{
if (put->expr_type != EXPR_VARIABLE
|| !put->symtree->n.sym->attr.optional)
{
nargs++;
where = &put->where;
}
if (!array_check (put, 1))
return false;
if (!rank_check (put, 1, 1))
return false;
if (!type_check (put, 1, BT_INTEGER))
return false;
if (!kind_value_check (put, 1, gfc_default_integer_kind))
return false;
if (gfc_array_size (put, &put_size)
&& mpz_get_ui (put_size) < seed_size)
gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&put->where, (int) mpz_get_ui (put_size), seed_size);
}
if (get != NULL)
{
if (get->expr_type != EXPR_VARIABLE
|| !get->symtree->n.sym->attr.optional)
{
nargs++;
where = &get->where;
}
if (!array_check (get, 2))
return false;
if (!rank_check (get, 2, 1))
return false;
if (!type_check (get, 2, BT_INTEGER))
return false;
if (!variable_check (get, 2, false))
return false;
if (!kind_value_check (get, 2, gfc_default_integer_kind))
return false;
if (gfc_array_size (get, &get_size)
&& mpz_get_ui (get_size) < seed_size)
gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
&get->where, (int) mpz_get_ui (get_size), seed_size);
}
/* RANDOM_SEED may not have more than one non-optional argument. */
if (nargs > 1)
gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
return true;
}
bool
gfc_check_fe_runtime_error (gfc_actual_arglist *a)
{
gfc_expr *e;
size_t len, i;
int num_percent, nargs;
e = a->expr;
if (e->expr_type != EXPR_CONSTANT)
return true;
len = e->value.character.length;
if (e->value.character.string[len-1] != '\0')
gfc_internal_error ("fe_runtime_error string must be null terminated");
num_percent = 0;
for (i=0; ivalue.character.string[i] == '%')
num_percent ++;
nargs = 0;
for (; a; a = a->next)
nargs ++;
if (nargs -1 != num_percent)
gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
nargs, num_percent++);
return true;
}
bool
gfc_check_second_sub (gfc_expr *time)
{
if (!scalar_check (time, 0))
return false;
if (!type_check (time, 0, BT_REAL))
return false;
if (!kind_value_check (time, 0, 4))
return false;
return true;
}
/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
variables in Fortran 95. In Fortran 2003 and later, they can be of any
kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
count_max are all optional arguments */
bool
gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
gfc_expr *count_max)
{
if (count != NULL)
{
if (!scalar_check (count, 0))
return false;
if (!type_check (count, 0, BT_INTEGER))
return false;
if (count->ts.kind != gfc_default_integer_kind
&& !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
"SYSTEM_CLOCK at %L has non-default kind",
&count->where))
return false;
if (!variable_check (count, 0, false))
return false;
}
if (count_rate != NULL)
{
if (!scalar_check (count_rate, 1))
return false;
if (!variable_check (count_rate, 1, false))
return false;
if (count_rate->ts.type == BT_REAL)
{
if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
"SYSTEM_CLOCK at %L", &count_rate->where))
return false;
}
else
{
if (!type_check (count_rate, 1, BT_INTEGER))
return false;
if (count_rate->ts.kind != gfc_default_integer_kind
&& !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
"SYSTEM_CLOCK at %L has non-default kind",
&count_rate->where))
return false;
}
}
if (count_max != NULL)
{
if (!scalar_check (count_max, 2))
return false;
if (!type_check (count_max, 2, BT_INTEGER))
return false;
if (count_max->ts.kind != gfc_default_integer_kind
&& !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
"SYSTEM_CLOCK at %L has non-default kind",
&count_max->where))
return false;
if (!variable_check (count_max, 2, false))
return false;
}
return true;
}
bool
gfc_check_irand (gfc_expr *x)
{
if (x == NULL)
return true;
if (!scalar_check (x, 0))
return false;
if (!type_check (x, 0, BT_INTEGER))
return false;
if (!kind_value_check (x, 0, 4))
return false;
return true;
}
bool
gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
{
if (!scalar_check (seconds, 0))
return false;
if (!type_check (seconds, 0, BT_INTEGER))
return false;
if (!int_or_proc_check (handler, 1))
return false;
if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
return false;
if (status == NULL)
return true;
if (!scalar_check (status, 2))
return false;
if (!type_check (status, 2, BT_INTEGER))
return false;
if (!kind_value_check (status, 2, gfc_default_integer_kind))
return false;
return true;
}
bool
gfc_check_rand (gfc_expr *x)
{
if (x == NULL)
return true;
if (!scalar_check (x, 0))
return false;
if (!type_check (x, 0, BT_INTEGER))
return false;
if (!kind_value_check (x, 0, 4))
return false;
return true;
}
bool
gfc_check_srand (gfc_expr *x)
{
if (!scalar_check (x, 0))
return false;
if (!type_check (x, 0, BT_INTEGER))
return false;
if (!kind_value_check (x, 0, 4))
return false;
return true;
}
bool
gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
{
if (!scalar_check (time, 0))
return false;
if (!type_check (time, 0, BT_INTEGER))
return false;
if (!type_check (result, 1, BT_CHARACTER))
return false;
if (!kind_value_check (result, 1, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_dtime_etime (gfc_expr *x)
{
if (!array_check (x, 0))
return false;
if (!rank_check (x, 0, 1))
return false;
if (!variable_check (x, 0, false))
return false;
if (!type_check (x, 0, BT_REAL))
return false;
if (!kind_value_check (x, 0, 4))
return false;
return true;
}
bool
gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
{
if (!array_check (values, 0))
return false;
if (!rank_check (values, 0, 1))
return false;
if (!variable_check (values, 0, false))
return false;
if (!type_check (values, 0, BT_REAL))
return false;
if (!kind_value_check (values, 0, 4))
return false;
if (!scalar_check (time, 1))
return false;
if (!type_check (time, 1, BT_REAL))
return false;
if (!kind_value_check (time, 1, 4))
return false;
return true;
}
bool
gfc_check_fdate_sub (gfc_expr *date)
{
if (!type_check (date, 0, BT_CHARACTER))
return false;
if (!kind_value_check (date, 0, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_gerror (gfc_expr *msg)
{
if (!type_check (msg, 0, BT_CHARACTER))
return false;
if (!kind_value_check (msg, 0, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
{
if (!type_check (cwd, 0, BT_CHARACTER))
return false;
if (!kind_value_check (cwd, 0, gfc_default_character_kind))
return false;
if (status == NULL)
return true;
if (!scalar_check (status, 1))
return false;
if (!type_check (status, 1, BT_INTEGER))
return false;
return true;
}
bool
gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
{
if (!type_check (pos, 0, BT_INTEGER))
return false;
if (pos->ts.kind > gfc_default_integer_kind)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
"not wider than the default kind (%d)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pos->where, gfc_default_integer_kind);
return false;
}
if (!type_check (value, 1, BT_CHARACTER))
return false;
if (!kind_value_check (value, 1, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_getlog (gfc_expr *msg)
{
if (!type_check (msg, 0, BT_CHARACTER))
return false;
if (!kind_value_check (msg, 0, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_exit (gfc_expr *status)
{
if (status == NULL)
return true;
if (!type_check (status, 0, BT_INTEGER))
return false;
if (!scalar_check (status, 0))
return false;
return true;
}
bool
gfc_check_flush (gfc_expr *unit)
{
if (unit == NULL)
return true;
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
return true;
}
bool
gfc_check_free (gfc_expr *i)
{
if (!type_check (i, 0, BT_INTEGER))
return false;
if (!scalar_check (i, 0))
return false;
return true;
}
bool
gfc_check_hostnm (gfc_expr *name)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
if (status == NULL)
return true;
if (!scalar_check (status, 1))
return false;
if (!type_check (status, 1, BT_INTEGER))
return false;
return true;
}
bool
gfc_check_itime_idate (gfc_expr *values)
{
if (!array_check (values, 0))
return false;
if (!rank_check (values, 0, 1))
return false;
if (!variable_check (values, 0, false))
return false;
if (!type_check (values, 0, BT_INTEGER))
return false;
if (!kind_value_check (values, 0, gfc_default_integer_kind))
return false;
return true;
}
bool
gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
{
if (!type_check (time, 0, BT_INTEGER))
return false;
if (!kind_value_check (time, 0, gfc_default_integer_kind))
return false;
if (!scalar_check (time, 0))
return false;
if (!array_check (values, 1))
return false;
if (!rank_check (values, 1, 1))
return false;
if (!variable_check (values, 1, false))
return false;
if (!type_check (values, 1, BT_INTEGER))
return false;
if (!kind_value_check (values, 1, gfc_default_integer_kind))
return false;
return true;
}
bool
gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
{
if (!scalar_check (unit, 0))
return false;
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!type_check (name, 1, BT_CHARACTER))
return false;
if (!kind_value_check (name, 1, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_is_contiguous (gfc_expr *array)
{
if (array->expr_type == EXPR_NULL)
{
gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
"associated pointer", &array->where, gfc_current_intrinsic);
return false;
}
if (!array_check (array, 0))
return false;
return true;
}
bool
gfc_check_isatty (gfc_expr *unit)
{
if (unit == NULL)
return false;
if (!type_check (unit, 0, BT_INTEGER))
return false;
if (!scalar_check (unit, 0))
return false;
return true;
}
bool
gfc_check_isnan (gfc_expr *x)
{
if (!type_check (x, 0, BT_REAL))
return false;
return true;
}
bool
gfc_check_perror (gfc_expr *string)
{
if (!type_check (string, 0, BT_CHARACTER))
return false;
if (!kind_value_check (string, 0, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_umask (gfc_expr *mask)
{
if (!type_check (mask, 0, BT_INTEGER))
return false;
if (!scalar_check (mask, 0))
return false;
return true;
}
bool
gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
{
if (!type_check (mask, 0, BT_INTEGER))
return false;
if (!scalar_check (mask, 0))
return false;
if (old == NULL)
return true;
if (!scalar_check (old, 1))
return false;
if (!type_check (old, 1, BT_INTEGER))
return false;
return true;
}
bool
gfc_check_unlink (gfc_expr *name)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
return true;
}
bool
gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
if (status == NULL)
return true;
if (!scalar_check (status, 1))
return false;
if (!type_check (status, 1, BT_INTEGER))
return false;
return true;
}
bool
gfc_check_signal (gfc_expr *number, gfc_expr *handler)
{
if (!scalar_check (number, 0))
return false;
if (!type_check (number, 0, BT_INTEGER))
return false;
if (!int_or_proc_check (handler, 1))
return false;
if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
return false;
return true;
}
bool
gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
{
if (!scalar_check (number, 0))
return false;
if (!type_check (number, 0, BT_INTEGER))
return false;
if (!int_or_proc_check (handler, 1))
return false;
if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
return false;
if (status == NULL)
return true;
if (!type_check (status, 2, BT_INTEGER))
return false;
if (!scalar_check (status, 2))
return false;
return true;
}
bool
gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
{
if (!type_check (cmd, 0, BT_CHARACTER))
return false;
if (!kind_value_check (cmd, 0, gfc_default_character_kind))
return false;
if (!scalar_check (status, 1))
return false;
if (!type_check (status, 1, BT_INTEGER))
return false;
if (!kind_value_check (status, 1, gfc_default_integer_kind))
return false;
return true;
}
/* This is used for the GNU intrinsics AND, OR and XOR. */
bool
gfc_check_and (gfc_expr *i, gfc_expr *j)
{
if (i->ts.type != BT_INTEGER
&& i->ts.type != BT_LOGICAL
&& i->ts.type != BT_BOZ)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
"LOGICAL, or a BOZ literal constant",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &i->where);
return false;
}
if (j->ts.type != BT_INTEGER
&& j->ts.type != BT_LOGICAL
&& j->ts.type != BT_BOZ)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
"LOGICAL, or a BOZ literal constant",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
return false;
}
/* i and j cannot both be BOZ literal constants. */
if (!boz_args_check (i, j))
return false;
/* If i is BOZ and j is integer, convert i to type of j. */
if (i->ts.type == BT_BOZ)
{
if (j->ts.type != BT_INTEGER)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
reset_boz (i);
return false;
}
if (!gfc_boz2int (i, j->ts.kind))
return false;
}
/* If j is BOZ and i is integer, convert j to type of i. */
if (j->ts.type == BT_BOZ)
{
if (i->ts.type != BT_INTEGER)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &j->where);
reset_boz (j);
return false;
}
if (!gfc_boz2int (j, i->ts.kind))
return false;
}
if (!same_type_check (i, 0, j, 1, false))
return false;
if (!scalar_check (i, 0))
return false;
if (!scalar_check (j, 1))
return false;
return true;
}
bool
gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
{
if (a->expr_type == EXPR_NULL)
{
gfc_error ("Intrinsic function NULL at %L cannot be an actual "
"argument to STORAGE_SIZE, because it returns a "
"disassociated pointer", &a->where);
return false;
}
if (a->ts.type == BT_ASSUMED)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
return false;
}
if (a->ts.type == BT_PROCEDURE)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
"procedure", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where);
return false;
}
if (a->ts.type == BT_BOZ && illegal_boz_arg (a))
return false;
if (kind == NULL)
return true;
if (!type_check (kind, 1, BT_INTEGER))
return false;
if (!scalar_check (kind, 1))
return false;
if (kind->expr_type != EXPR_CONSTANT)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&kind->where);
return false;
}
return true;
}