/* Check functions
- Copyright (C) 2002-2014 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"
if (e->rank == 0)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
if (e->ts.type == type)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, gfc_basic_typename (type));
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 ("'%s' argument of '%s' 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);
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
{
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
"or COMPLEX", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
if (!gfc_check_init_expr (k))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&k->where);
return false;
if (d->ts.kind != gfc_default_double_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be double "
"precision", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &d->where);
return false;
if (!gfc_is_coarray (e))
{
- gfc_error ("Expected coarray variable as '%s' argument to the %s "
+ gfc_error ("Expected coarray variable as %qs argument to the %s "
"intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
{
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
"array", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &array->where);
return false;
if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
gfc_extract_int (expr, &i);
if (i < 0)
{
- gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
+ gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
return false;
}
}
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("The absolute value of SHIFT at %L must be less "
- "than or equal to BIT_SIZE('%s')",
+ "than or equal to BIT_SIZE(%qs)",
&expr2->where, arg1);
return false;
}
{
if (i2 > gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s' at %L must be less than "
- "or equal to BIT_SIZE('%s')",
+ gfc_error ("%qs at %L must be less than "
+ "or equal to BIT_SIZE(%qs)",
arg2, &expr2->where, arg1);
return false;
}
{
if (i2 >= gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
+ gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
arg2, &expr2->where, arg1);
return false;
}
if (val > gfc_integer_kinds[i].bit_size)
{
- gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
+ gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
"INTEGER(KIND=%d)", arg, &expr->where, k);
return false;
}
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
if (i2 > gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s + %s' at %L must be less than or equal "
- "to BIT_SIZE('%s')",
+ gfc_error ("%<%s + %s%> at %L must be less than or equal "
+ "to BIT_SIZE(%qs)",
arg2, arg3, &expr2->where, arg1);
return false;
}
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 ("'%s' argument of '%s' intrinsic at %L must be the same type "
- "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
+ "and kind as %qs", gfc_current_intrinsic_arg[m]->name,
gfc_current_intrinsic, &f->where,
gfc_current_intrinsic_arg[n]->name);
if (e->rank == rank)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, rank);
{
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_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
}
attr = gfc_variable_attr (e, NULL);
if (!attr.allocatable || attr.associate_var)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
return false;
if (e->ts.kind == k)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, k);
if (!ref)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
+ gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
"INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
return true;
}
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
return false;
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
{
- gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
"codimension index", gfc_current_intrinsic, &dim->where);
return false;
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
{
- gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic, &dim->where);
return false;
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.type != p->ts.type)
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&p->where);
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;
}
if (!attr1.pointer && !attr1.proc_pointer)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pointer->where);
return false;
/* F2008, C1242. */
if (attr1.pointer && gfc_is_coindexed (pointer))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &pointer->where);
return false;
attr2 = gfc_expr_attr (target);
else
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
"or target VARIABLE or FUNCTION",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&target->where);
if (attr1.pointer && !attr2.pointer && !attr2.target)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
"or a TARGET", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &target->where);
return false;
/* F2008, C1242. */
if (attr1.pointer && gfc_is_coindexed (target))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &target->where);
return false;
null_arg:
gfc_error ("NULL pointer at %L is not permitted as actual argument "
- "of '%s' intrinsic function", where, gfc_current_intrinsic);
+ "of %qs intrinsic function", where, gfc_current_intrinsic);
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 ("'%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 (x->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
- "present if 'x' is COMPLEX",
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be "
+ "present if %<x%> is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
return false;
if (y->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"of either REAL or INTEGER",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
/* Fortran 2008, 12.5.2.4, paragraph 18. */
if (gfc_has_vector_subscript (a))
{
- gfc_error ("Argument 'A' with INTENT(INOUT) at %L of the intrinsic "
+ gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
"subroutine %s shall not have a vector subscript",
&a->where, gfc_current_intrinsic);
return false;
}
}
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
&a->where);
if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
&& a->ts.type != BT_CHARACTER)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type "
+ 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;
if (!kind_check (kind, 2, BT_INTEGER))
return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
{
if (!identical_dimen_shape (array, i, shift, j))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, array->rank - 1);
return false;
if (x->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
- "present if 'x' is COMPLEX",
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be "
+ "present if %<x%> is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
return false;
if (y->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"of either REAL or INTEGER",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
break;
default:
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &vector_a->where);
return false;
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]->name,
+ gfc_error ("Different shape for arguments %qs and %qs at %L for "
+ "intrinsic %<dot_product%>",
+ gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &vector_a->where);
return false;
}
if (x->ts.kind != gfc_default_real_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be default "
"real", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return false;
if (y->ts.kind != gfc_default_real_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be default "
"real", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &y->where);
return false;
if (i->is_boz && j->is_boz)
{
- gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
- "constants", &i->where, &j->where);
+ gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
+ "constants", &i->where, &j->where);
return false;
}
{
if (!identical_dimen_shape (array, i, shift, j))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, array->rank - 1);
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;
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+ gfc_error ("%qs argument of intrinsic %qs at %L of must have "
"rank %d or be a scalar",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&shift->where, array->rank - 1);
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;
return false;
if (a->ts.type == BT_COMPLEX
- && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' "
- "of '%s' intrinsic at %L",
- gfc_current_intrinsic_arg[0]->name,
+ && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
+ "of %qs intrinsic at %L",
+ gfc_current_intrinsic_arg[0]->name,
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;
}
if (!kind_check (kind, 1, BT_INTEGER))
return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "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, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
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]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
+ "kind as %qs", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &substring->where,
gfc_current_intrinsic_arg[0]->name);
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;
}
bool
gfc_check_kind (gfc_expr *x)
{
- if (x->ts.type == BT_DERIVED)
+ if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
- "non-derived type", gfc_current_intrinsic_arg[0]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of "
+ "intrinsic type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return false;
}
+ if (x->ts.type == BT_PROCEDURE)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &x->where);
+ return false;
+ }
return true;
}
if (!kind_check (kind, 2, BT_INTEGER))
return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
bool
gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
{
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
if (!kind_check (kind, 1, BT_INTEGER))
return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
if (args == NULL || args->next == NULL)
{
- gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
+ gfc_error ("Intrinsic %qs at %L must have at least two arguments",
gfc_current_intrinsic, gfc_current_intrinsic_where);
return false;
}
if (!a1 || !a2)
{
- gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
+ gfc_error ("Missing %qs argument to the %s intrinsic at %L",
!a1 ? "a1" : "a2", gfc_current_intrinsic,
gfc_current_intrinsic_where);
return false;
return true;
duplicate:
- gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg->name,
+ gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
&arg->expr->where, gfc_current_intrinsic);
return false;
unknown:
- gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg->name,
+ gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
&arg->expr->where, gfc_current_intrinsic);
return false;
}
}
else
{
- gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
+ gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
"%s(%d)", n, gfc_current_intrinsic, &x->where,
gfc_basic_typename (type), kind);
return false;
}
for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
- if (!gfc_check_conformance (tmp->expr, x,
+ if (!gfc_check_conformance (tmp->expr, x,
"arguments 'a%d' and 'a%d' for "
- "intrinsic '%s'", m, n,
+ "intrinsic '%s'", m, n,
gfc_current_intrinsic))
return false;
}
if (x->ts.type == BT_CHARACTER)
{
- if (!gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
- "with CHARACTER argument at %L",
+ if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with CHARACTER argument at %L",
gfc_current_intrinsic, &x->where))
return false;
}
else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
- gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+ gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
"REAL or CHARACTER", gfc_current_intrinsic, &x->where);
return false;
}
{
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 "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->where);
return false;
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 "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &matrix_b->where);
return false;
if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
|| (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
{
- gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
+ gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
gfc_current_intrinsic, &matrix_a->where,
gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
return false;
/* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
{
- gfc_error ("Different shape on dimension 1 for arguments '%s' "
- "and '%s' at %L for intrinsic matmul",
+ gfc_error ("Different shape on dimension 1 for arguments %qs "
+ "and %qs at %L for intrinsic matmul",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return false;
- matrix_a has shape (n,m) and matrix_b has shape (m). */
if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
{
- gfc_error ("Different shape on dimension 2 for argument '%s' and "
- "dimension 1 for argument '%s' at %L for intrinsic "
+ gfc_error ("Different shape on dimension 2 for argument %qs and "
+ "dimension 1 for argument %qs at %L for intrinsic "
"matmul", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return false;
break;
default:
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
"1 or 2", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->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;
{
if (ap->expr->ts.type != BT_INTEGER)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &ap->expr->where);
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 (mpfr_sgn (s->value.real) == 0)
{
- gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
+ gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
&s->where);
return false;
}
if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
"ALLOCATABLE or procedure pointer",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
/* F2008, C1242. */
if (gfc_is_coindexed (mold))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
return false;
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;
if (mpz_get_si (vector_size) < mask_true_values)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
- "are .TRUE. values in '%s' (%ld/%d)",
+ "are .TRUE. values in %qs (%ld/%d)",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic, &vector->where,
gfc_current_intrinsic_arg[1]->name,
sym = a->symtree->n.sym;
if (!sym->attr.dummy)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
"dummy variable", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where);
return false;
if (!sym->attr.optional)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of "
"an OPTIONAL dummy variable",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
|| (a->ref->u.ar.type == AR_ELEMENT
&& a->ref->u.ar.as->rank == 0))))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
- "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
+ "subobject of %qs", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where, sym->name);
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). */
if (!gfc_array_size (shape, &size))
{
- gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
+ gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
"array of constant size", &shape->where);
return false;
}
if (shape_size <= 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+ gfc_error ("%qs argument of %qs intrinsic at %L is empty",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&shape->where);
return false;
}
else if (shape_size > GFC_MAX_DIMENSIONS)
{
- gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
+ gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
return false;
}
gfc_extract_int (e, &extent);
if (extent < 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ 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);
}
}
}
+ 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;
if (order_size != shape_size)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ 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,
if (dim < 1 || dim > order_size)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ 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);
if (perm[dim-1] != 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ 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 (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ 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);
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ 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);
if (!kind_check (kind, 3, BT_INTEGER))
return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "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;
if (!scalar_check (radix, 1))
return false;
- if (!gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with "
- "RADIX argument at %L", gfc_current_intrinsic,
+ if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
+ "RADIX argument at %L", gfc_current_intrinsic,
&radix->where))
return false;
}
if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
{
- gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
+ gfc_error ("%<source%> argument of %<shape%> 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, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "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, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
{
if (arg->ts.type == BT_PROCEDURE)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a 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;
&& arg->symtree->n.sym->as->type != AS_DEFERRED
&& arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+ 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;
&& 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 ("'%s' argument of '%s' intrinsic at %L shall not be an "
+ 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;
}
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
if (!is_c_interoperable (arg, &msg, false, false))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
+ 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);
if (arg->ts.type == BT_ASSUMED)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
&& 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 ("'%s' argument of '%s' intrinsic at %L shall not be an "
+ 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;
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (x->symtree->n.sym == ns->proc_name)
{
- gfc_error ("Function result '%s' at %L is invalid as X argument "
+ gfc_error ("Function result %qs at %L is invalid as X argument "
"to C_FUNLOC", x->symtree->n.sym->name, &x->where);
return false;
}
&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 (source->rank >= GFC_MAX_DIMENSIONS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
+ 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);
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+ 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;
{
mpz_t nelems;
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
bool
gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
{
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
bool
gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
{
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
if (mold->ts.type == BT_HOLLERITH)
{
- gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
- &mold->where, gfc_basic_typename (BT_HOLLERITH));
+ gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
+ " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
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, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
bool
gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
{
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return false;
if (mpz_get_si (vector_size) < mask_true_count)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
- "are .TRUE. values in '%s' (%ld/%d)",
+ "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);
if (mask->rank != field->rank && field->rank != 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
- "the same rank as '%s' or be a scalar",
+ 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;
for (i = 0; i < field->rank; i++)
if (! identical_dimen_shape (mask, i, field, i))
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
+ 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,
if (!kind_check (kind, 3, BT_INTEGER))
return false;
- if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
- "with KIND argument at %L",
+ if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+ "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)
- gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ && 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)
- gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ && 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)
if (pos->ts.kind > gfc_default_integer_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a 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);
{
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &i->where);
return false;
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
return false;
if (i->ts.type != j->ts.type)
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&j->where);
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 ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+ 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 ("'%s' argument of '%s' intrinsic at %L shall not be a "
+ 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 (kind->expr_type != EXPR_CONSTANT)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a 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;
projects / thirdparty / gcc.git / blobdiff