GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* These functions check to see if an argument list is compatible with
#include "intrinsic.h"
+/* Make sure an expression is a scalar. */
+
+static try
+scalar_check (gfc_expr *e, int n)
+{
+ if (e->rank == 0)
+ return SUCCESS;
+
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+
+ return FAILURE;
+}
+
+
/* Check the type of an expression. */
static try
if (type_check (k, n, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (scalar_check (k, n) == FAILURE)
+ return FAILURE;
+
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
}
-/* Make sure an expression is a scalar. */
-
-static try
-scalar_check (gfc_expr *e, int n)
-{
- if (e->rank == 0)
- return SUCCESS;
-
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
-
- return FAILURE;
-}
-
-
/* Make sure two expressions have the same type. */
static try
/* Check the common DIM parameter for correctness. */
static try
-dim_check (gfc_expr *dim, int n, int optional)
+dim_check (gfc_expr *dim, int n, bool optional)
{
- if (optional && dim == NULL)
+ if (dim == NULL)
return SUCCESS;
if (dim == NULL)
if (scalar_check (dim, n) == FAILURE)
return FAILURE;
- if (nonoptional_check (dim, n) == FAILURE)
+ if (!optional && nonoptional_check (dim, n) == FAILURE)
return FAILURE;
return SUCCESS;
}
-/* Error return for transformational intrinsics not allowed in
- initialization expressions. */
-
+/* Check whether two character expressions have the same length;
+ returns SUCCESS if they have or if the length cannot be determined. */
+
static try
-non_init_transformational (void)
+check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
{
- gfc_error ("transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", gfc_current_intrinsic,
- gfc_current_intrinsic_where);
- return FAILURE;
+ long len_a, len_b;
+ len_a = len_b = -1;
+
+ if (a->ts.cl && a->ts.cl->length
+ && a->ts.cl->length->expr_type == EXPR_CONSTANT)
+ len_a = mpz_get_si (a->ts.cl->length->value.integer);
+ else if (a->expr_type == EXPR_CONSTANT
+ && (a->ts.cl == NULL || a->ts.cl->length == NULL))
+ len_a = a->value.character.length;
+ else
+ return SUCCESS;
+
+ if (b->ts.cl && b->ts.cl->length
+ && b->ts.cl->length->expr_type == EXPR_CONSTANT)
+ len_b = mpz_get_si (b->ts.cl->length->value.integer);
+ else if (b->expr_type == EXPR_CONSTANT
+ && (b->ts.cl == NULL || b->ts.cl->length == NULL))
+ len_b = b->value.character.length;
+ else
+ return SUCCESS;
+
+ if (len_a == len_b)
+ return SUCCESS;
+
+ gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
+ "at %L", len_a, len_b, name, &a->where);
+ return FAILURE;
}
+
/***** Check functions *****/
/* Check subroutine suitable for intrinsics taking a real argument and
try
-gfc_check_achar (gfc_expr *a)
+gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
if (type_check (a, 0, BT_INTEGER) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
if (variable_check (array, 0) == FAILURE)
return FAILURE;
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
-
attr = gfc_variable_attr (array, NULL);
if (!attr.allocatable)
{
return FAILURE;
}
+ if (array_check (array, 0) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
try
-gfc_check_count (gfc_expr *mask, gfc_expr *dim)
+gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
if (logical_array_check (mask, 0) == FAILURE)
return FAILURE;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
return FAILURE;
-
- if (gfc_init_expr)
- return non_init_transformational ();
return SUCCESS;
}
/* TODO: more requirements on shift parameter. */
}
- if (dim_check (dim, 2, 1) == FAILURE)
+ /* FIXME (PR33317): Allow optional DIM=. */
+ if (dim_check (dim, 2, false) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
{
- gfc_error ("different shape for arguments '%s' and '%s' at %L for "
+ gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
"intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], &vector_a->where);
return FAILURE;
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
/* TODO: more restrictions on boundary. */
}
- if (dim_check (dim, 1, 1) == FAILURE)
+ /* FIXME (PR33317): Allow optional DIM=. */
+ if (dim_check (dim, 4, false) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
try
-gfc_check_ichar_iachar (gfc_expr *c)
+gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
{
int i;
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
{
gfc_expr *start;
try
-gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
+gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
+ gfc_expr *kind)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE
|| type_check (substring, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
-
if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
if (string->ts.kind != substring->ts.kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
if (numeric_check (x, 0) == FAILURE)
return FAILURE;
- if (kind != NULL)
- {
- if (type_check (kind, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
-
- if (scalar_check (kind, 1) == FAILURE)
- return FAILURE;
- }
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
try
-gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
+gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 1) == FAILURE)
return FAILURE;
}
+
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
+{
+ if (type_check (s, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
x = arg->expr;
- if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+ if (x->ts.type == BT_CHARACTER)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with CHARACTER argument at %L",
+ gfc_current_intrinsic, &x->where) == FAILURE)
+ return FAILURE;
+ }
+ else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
- gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
- "or REAL", gfc_current_intrinsic, &x->where);
+ gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+ "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
return FAILURE;
}
/* 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' "
+ gfc_error ("Different shape on dimension 1 for arguments '%s' "
"and '%s' at %L for intrinsic matmul",
gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], &matrix_a->where);
- 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 "
+ gfc_error ("Different shape on dimension 2 for argument '%s' and "
"dimension 1 for argument '%s' at %L for intrinsic "
"matmul", gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[1], &matrix_a->where);
return FAILURE;
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
ap->next->next->expr = m;
}
- if (dim_check (d, 1, 1) == FAILURE)
+ if (d && dim_check (d, 1, false) == FAILURE)
return FAILURE;
if (d && dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
ap->next->next->expr = m;
}
- if (dim_check (d, 1, 1) == FAILURE)
+ if (d && dim_check (d, 1, false) == FAILURE)
return FAILURE;
if (d && dim_rank_check (d, a, 0) == FAILURE)
|| array_check (ap->expr, 0) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return check_reduction (ap);
}
|| array_check (ap->expr, 0) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return check_reduction (ap);
}
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (tsource->ts.type == BT_CHARACTER)
+ return check_same_strlen (tsource, fsource, "MERGE");
+
return SUCCESS;
}
+
try
gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
{
/* TODO: More constraints here. */
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
try
-gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
+gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
if (same_type_check (x, 0, y, 1) == FAILURE)
return FAILURE;
try
-gfc_check_size (gfc_expr *array, gfc_expr *dim)
+gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
- if (type_check (dim, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
-
- if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
+ if (dim_check (dim, 1, true) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 0) == FAILURE)
return FAILURE;
}
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_sizeof (gfc_expr *arg __attribute__((unused)))
+{
return SUCCESS;
}
return FAILURE;
}
- if (dim_check (dim, 1, 0) == FAILURE)
+ if (dim == NULL)
+ return FAILURE;
+
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
if (scalar_check (ncopies, 2) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
if (rank_check (matrix, 0, 2) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
try
-gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
+gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (dim != NULL)
{
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
if (dim_rank_check (dim, array, 0) == FAILURE)
return FAILURE;
}
+ if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
if (same_type_check (vector, 0, field, 2) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
try
-gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
+gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
{
if (type_check (x, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with KIND argument at %L",
+ gfc_current_intrinsic, &kind->where) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
try
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
+ unsigned int nargs = 0;
+ locus *where = NULL;
+
if (size != NULL)
{
+ if (size->expr_type != EXPR_VARIABLE
+ || !size->symtree->n.sym->attr.optional)
+ nargs++;
+
if (scalar_check (size, 0) == FAILURE)
return FAILURE;
if (put != NULL)
{
-
- if (size != NULL)
- gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
- &put->where);
+ if (put->expr_type != EXPR_VARIABLE
+ || !put->symtree->n.sym->attr.optional)
+ {
+ nargs++;
+ where = &put->where;
+ }
if (array_check (put, 1) == FAILURE)
return FAILURE;
if (get != NULL)
{
-
- if (size != NULL || put != NULL)
- gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
- &get->where);
+ if (get->expr_type != EXPR_VARIABLE
+ || !get->symtree->n.sym->attr.optional)
+ {
+ nargs++;
+ where = &get->where;
+ }
if (array_check (get, 2) == FAILURE)
return FAILURE;
return FAILURE;
}
+ /* 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 SUCCESS;
}
try
+gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
+{
+ if (type_check (pos, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (pos->ts.kind > gfc_default_integer_kind)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+ "not wider than the default kind (%d)",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &pos->where, gfc_default_integer_kind);
+ return FAILURE;
+ }
+
+ if (type_check (value, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
gfc_check_getlog (gfc_expr *msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
try
+gfc_check_isnan (gfc_expr *x)
+{
+ if (type_check (x, 0, BT_REAL) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
gfc_check_perror (gfc_expr *string)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
OSDN Git Service
