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
}
-/* Error return for transformational intrinsics not allowed in
- initialization expressions. */
-
-static try
-non_init_transformational (void)
-{
- gfc_error ("transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", gfc_current_intrinsic,
- gfc_current_intrinsic_where);
- return FAILURE;
-}
-
/***** Check functions *****/
/* Check subroutine suitable for intrinsics taking a real argument and
if (dim_check (dim, 1, 1) == 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)
return FAILURE;
-
- if (gfc_init_expr)
- return non_init_transformational ();
+ 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 (dim_check (dim, 2, 1) == FAILURE)
return FAILURE;
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
return FAILURE;
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
if (dim_check (dim, 1, 1) == 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 "
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_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;
}
return FAILURE;
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
return FAILURE;
}
- if (gfc_init_expr)
- return non_init_transformational ();
-
return SUCCESS;
}
|| 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);
}
/* 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;
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;
}
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;
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_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)