/* Check functions
- Copyright (C) 2002-2015 Free Software Foundation, Inc.
+ Copyright (C) 2002-2017 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
-#include "flags.h"
+#include "options.h"
#include "gfortran.h"
#include "intrinsic.h"
#include "constructor.h"
static bool
numeric_check (gfc_expr *e, int n)
{
+ /* Users sometime use a subroutine designator as an actual argument to
+ an intrinsic subprogram that expects an argument with a numeric type. */
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+ goto error;
+
if (gfc_numeric_ts (&e->ts))
return true;
return true;
}
- gfc_error ("%qs argument of %qs intrinsic at %L must be a numeric type",
+error:
+
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
static bool
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
{
- if (gfc_compare_types (&e->ts, &f->ts))
+ gfc_typespec *ets = &e->ts;
+ gfc_typespec *fts = &f->ts;
+
+ if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
+ ets = &e->symtree->n.sym->ts;
+ if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
+ fts = &f->symtree->n.sym->ts;
+
+ if (gfc_compare_types (ets, fts))
return true;
gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
bool
gfc_check_allocated (gfc_expr *array)
{
+ /* Tests on allocated components of coarrays need to detour the check to
+ argument of the _caf_get. */
+ if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
+ && array->value.function.isym
+ && array->value.function.isym->id == GFC_ISYM_CAF_GET)
+ {
+ array = array->value.function.actual->expr;
+ if (!array->ref)
+ return false;
+ }
+
if (!variable_check (array, 0, false))
return false;
if (!allocatable_check (array, 0))
if (a->ts.kind != p->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&p->where))
return false;
}
return false;
}
- if (!gfc_expr_attr (atom).codimension)
+ if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom))
{
gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
"coarray or coindexed", &atom->where, gfc_current_intrinsic);
if (atom->ts.type != value->ts.type)
{
- gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same "
- "type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
+ "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
gfc_current_intrinsic, &value->where,
gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
return false;
return true;
}
+bool
+gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
+{
+ if (event->ts.type != BT_DERIVED
+ || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
+ "shall be of type EVENT_TYPE", &event->where);
+ return false;
+ }
+
+ if (!scalar_check (event, 0))
+ return false;
+
+ if (!gfc_check_vardef_context (count, false, false, false, NULL))
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall be definable", &count->where);
+ return false;
+ }
+
+ if (!type_check (count, 1, BT_INTEGER))
+ return false;
+
+ int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
+ int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+ if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall have at least the range of the default integer",
+ &count->where);
+ return false;
+ }
+
+ if (stat != NULL)
+ {
+ if (!type_check (stat, 2, BT_INTEGER))
+ return false;
+ if (!scalar_check (stat, 2))
+ return false;
+ if (!variable_check (stat, 2, false))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L",
+ gfc_current_intrinsic, &stat->where))
+ return false;
+ }
+
+ return true;
+}
+
bool
gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
if (!gfc_compare_types (&a->ts, &sym->result->ts))
{
- gfc_error_1 ("A argument at %L has type %s but the function passed as "
+ gfc_error ("A argument at %L has type %s but the function passed as "
"OPERATOR at %L returns %s",
&a->where, gfc_typename (&a->ts), &op->where,
gfc_typename (&sym->result->ts));
&& ((formal_size1 && actual_size != formal_size1)
|| (formal_size2 && actual_size != formal_size2)))
{
- gfc_error_1 ("The character length of the A argument at %L and of the "
- "arguments of the OPERATOR at %L shall be the same",
+ gfc_error ("The character length of the A argument at %L and of the "
+ "arguments of the OPERATOR at %L shall be the same",
&a->where, &op->where);
return false;
}
if (actual_size && result_size && actual_size != result_size)
{
- gfc_error_1 ("The character length of the A argument at %L and of the "
- "function result of the OPERATOR at %L shall be the same",
- &a->where, &op->where);
+ gfc_error ("The character length of the A argument at %L and of the "
+ "function result of the OPERATOR at %L shall be the same",
+ &a->where, &op->where);
return false;
}
}
if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
&& a->ts.type != BT_CHARACTER)
{
- gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall be of type "
- "integer, real or character",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
+ gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
+ "integer, real or character",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &a->where);
return false;
}
return check_co_collective (a, result_image, stat, errmsg, 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",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
if (i->is_boz && j->is_boz)
{
- gfc_error_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal "
+ gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
"constants", &i->where, &j->where);
return false;
}
}
else if (boundary->rank == array->rank - 1)
{
- if (!gfc_check_conformance (shift, boundary,
+ if (!gfc_check_conformance (shift, boundary,
"arguments '%s' and '%s' for "
- "intrinsic %s",
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic_arg[2]->name,
+ "intrinsic %s",
+ gfc_current_intrinsic_arg[1]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
return false;
}
if ((a->ts.kind != gfc_default_integer_kind)
&& !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
- "kind argument to %s intrinsic at %L",
+ "kind argument to %s intrinsic at %L",
gfc_current_intrinsic, &a->where))
return false;
if (i->ts.kind != j->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&i->where))
return false;
}
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
if (i->ts.kind != j->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&i->where))
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",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
if (i->ts.kind != j->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&i->where))
return false;
}
if (i2 > i3)
{
- gfc_error_1 ("The absolute value of SHIFT at %L must be less "
- "than or equal to SIZE at %L", &shift->where,
- &size->where);
+ gfc_error ("The absolute value of SHIFT at %L must be less "
+ "than or equal to SIZE at %L", &shift->where,
+ &size->where);
return false;
}
}
bool
gfc_check_kind (gfc_expr *x)
{
- if (x->ts.type == BT_DERIVED || x->ts.type == BT_CLASS)
+ if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be of "
"intrinsic type", gfc_current_intrinsic_arg[0]->name,
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->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",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
if (x->ts.type == BT_CHARACTER)
{
if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with CHARACTER argument at %L",
+ "with CHARACTER argument at %L",
gfc_current_intrinsic, &x->where))
return false;
}
return false;
if (m != NULL
- && !gfc_check_conformance (a, m,
- "arguments '%s' and '%s' for intrinsic %s",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[2]->name,
+ && !gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
return false;
return false;
if (m != NULL
- && !gfc_check_conformance (a, m,
- "arguments '%s' and '%s' for intrinsic %s",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[2]->name,
+ && !gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
return false;
return false;
}
+ /* This is based losely on F2003 12.4.1.7. It is intended to prevent
+ the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
+ and cmp2 are allocatable. After the allocation is transferred,
+ the 'to' chain is broken by the nullification of the 'from'. A bit
+ of reflection reveals that this can only occur for derived types
+ with recursive allocatable components. */
+ if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
+ && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
+ {
+ gfc_ref *to_ref, *from_ref;
+ to_ref = to->ref;
+ from_ref = from->ref;
+ bool aliasing = true;
+
+ for (; from_ref && to_ref;
+ from_ref = from_ref->next, to_ref = to_ref->next)
+ {
+ if (to_ref->type != from->ref->type)
+ aliasing = false;
+ else if (to_ref->type == REF_ARRAY
+ && to_ref->u.ar.type != AR_FULL
+ && from_ref->u.ar.type != AR_FULL)
+ /* Play safe; assume sections and elements are different. */
+ aliasing = false;
+ else if (to_ref->type == REF_COMPONENT
+ && to_ref->u.c.component != from_ref->u.c.component)
+ aliasing = false;
+
+ if (!aliasing)
+ break;
+ }
+
+ if (aliasing)
+ {
+ gfc_error ("The FROM and TO arguments at %L violate aliasing "
+ "restrictions (F2003 12.4.1.7)", &to->where);
+ return false;
+ }
+ }
+
/* CLASS arguments: Make sure the vtab of from is present. */
if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
gfc_find_vtab (&from->ts);
if (!type_check (mask, 1, BT_LOGICAL))
return false;
- if (!gfc_check_conformance (array, mask,
- "arguments '%s' and '%s' for intrinsic '%s'",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name,
+ if (!gfc_check_conformance (array, mask,
+ "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic))
return false;
bool
-gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
+gfc_check_rank (gfc_expr *a)
{
/* 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). */
}
}
}
+ 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)
+ {
+ 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 (!type_check (order, 3, BT_INTEGER))
return false;
- if (order->expr_type == EXPR_ARRAY)
+ if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
{
int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
gfc_expr *e;
{
gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid permutation of dimensions (dimension "
- "%<%d%> duplicated)",
+ "%qd duplicated)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
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",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
{
if (p == NULL && r == NULL
&& !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
- " neither %<P%> nor %<R%> argument at %L",
+ " neither %<P%> nor %<R%> argument at %L",
gfc_current_intrinsic_where))
return false;
return false;
if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
- "RADIX argument at %L", gfc_current_intrinsic,
+ "RADIX argument at %L", gfc_current_intrinsic,
&radix->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",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
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",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
}
if (expr->ts.u.cl && expr->ts.u.cl->length
- && !gfc_simplify_expr (expr, 0))
+ && !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
&x->where);
return false;
}
-
+
if (x->rank
- && !gfc_notify_std (GFC_STD_F2008_TS,
+ && !gfc_notify_std (GFC_STD_F2008_TS,
"Noninteroperable array at %L as"
" argument to C_LOC: %s", &x->where, msg))
return false;
if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
&& !attr.allocatable
- && !gfc_notify_std (GFC_STD_F2008,
+ && !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))
if ((a->ts.kind != gfc_default_double_kind)
&& !gfc_notify_std (GFC_STD_GNU, "non double precision "
- "REAL argument to %s intrinsic at %L",
+ "REAL argument to %s intrinsic at %L",
gfc_current_intrinsic, &a->where))
return false;
/* 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,
+ if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
&result_size, NULL))
return true;
if (source_size < result_size)
- gfc_warning ("Intrinsic TRANSFER at %L has partly undefined result: "
+ 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);
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
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",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
bool
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
- unsigned int nargs = 0, kiss_size;
+ unsigned int nargs = 0, seed_size;
locus *where = NULL;
mpz_t put_size, get_size;
- bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
- have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
-
- /* Keep the number of bytes in sync with kiss_size in
- libgfortran/intrinsics/random.c. */
- kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
+ /* Keep the number of bytes in sync with master_state in
+ libgfortran/intrinsics/random.c. +1 due to the integer p which is
+ part of the state too. */
+ seed_size = 128 / gfc_default_integer_kind + 1;
if (size != NULL)
{
return false;
if (gfc_array_size (put, &put_size)
- && mpz_get_ui (put_size) < kiss_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,
- where, (int) mpz_get_ui (put_size), kiss_size);
+ where, (int) mpz_get_ui (put_size), seed_size);
}
if (get != NULL)
return false;
if (gfc_array_size (get, &get_size)
- && mpz_get_ui (get_size) < kiss_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,
- where, (int) mpz_get_ui (get_size), kiss_size);
+ where, (int) mpz_get_ui (get_size), seed_size);
}
/* RANDOM_SEED may not have more than one non-optional argument. */
return true;
}
+bool
+gfc_check_fe_runtime_error (gfc_actual_arglist *a)
+{
+ gfc_expr *e;
+ int 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; i<len-1; i++)
+ if (e->value.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)
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(*)",
projects / thirdparty / gcc.git / blobdiff