diff options
Diffstat (limited to 'gcc/fortran/check.c')
| -rw-r--r-- | gcc/fortran/check.c | 1866 |
1 files changed, 1866 insertions, 0 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c new file mode 100644 index 00000000000..e37964df85d --- /dev/null +++ b/gcc/fortran/check.c @@ -0,0 +1,1866 @@ +/* Check functions + Copyright (C) 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GNU G95. + +GNU G95 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 version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* These functions check to see if an argument list is compatible with + a particular intrinsic function or subroutine. Presence of + required arguments has already been established, the argument list + has been sorted into the right order and has NULL arguments in the + correct places for missing optional arguments. */ + + +#include <stdlib.h> +#include <stdarg.h> + +#include "config.h" +#include "system.h" +#include "flags.h" +#include "gfortran.h" +#include "intrinsic.h" + + +/* The fundamental complaint function of this source file. This + function can be called in all kinds of ways. */ + +static void +must_be (gfc_expr * e, int n, const char *thing) +{ + + gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s", + gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where, + thing); +} + + +/* Check the type of an expression. */ + +static try +type_check (gfc_expr * e, int n, bt type) +{ + + if (e->ts.type == type) + return SUCCESS; + + must_be (e, n, gfc_basic_typename (type)); + + return FAILURE; +} + + +/* Check that the expression is a numeric type. */ + +static try +numeric_check (gfc_expr * e, int n) +{ + + if (gfc_numeric_ts (&e->ts)) + return SUCCESS; + + must_be (e, n, "a numeric type"); + + return FAILURE; +} + + +/* Check that an expression is integer or real. */ + +static try +int_or_real_check (gfc_expr * e, int n) +{ + + if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) + { + must_be (e, n, "INTEGER or REAL"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Check that the expression is an optional constant integer + and that it specifies a valid kind for that type. */ + +static try +kind_check (gfc_expr * k, int n, bt type) +{ + int kind; + + if (k == NULL) + return SUCCESS; + + if (type_check (k, n, BT_INTEGER) == FAILURE) + return FAILURE; + + if (k->expr_type != EXPR_CONSTANT) + { + must_be (k, n, "a constant"); + return FAILURE; + } + + if (gfc_extract_int (k, &kind) != NULL + || gfc_validate_kind (type, kind) == -1) + { + gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), + &k->where); + return FAILURE; + } + + return SUCCESS; +} + + +/* Make sure the expression is a double precision real. */ + +static try +double_check (gfc_expr * d, int n) +{ + + if (type_check (d, n, BT_REAL) == FAILURE) + return FAILURE; + + if (d->ts.kind != gfc_default_double_kind ()) + { + must_be (d, n, "double precision"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Make sure the expression is a logical array. */ + +static try +logical_array_check (gfc_expr * array, int n) +{ + + if (array->ts.type != BT_LOGICAL || array->rank == 0) + { + must_be (array, n, "a logical array"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Make sure an expression is an array. */ + +static try +array_check (gfc_expr * e, int n) +{ + + if (e->rank != 0) + return SUCCESS; + + must_be (e, n, "an array"); + + return FAILURE; +} + + +/* Make sure an expression is a scalar. */ + +static try +scalar_check (gfc_expr * e, int n) +{ + + if (e->rank == 0) + return SUCCESS; + + must_be (e, n, "a scalar"); + + return FAILURE; +} + + +/* Make sure two expression have the same type. */ + +static try +same_type_check (gfc_expr * e, int n, gfc_expr * f, int m) +{ + char message[100]; + + if (gfc_compare_types (&e->ts, &f->ts)) + return SUCCESS; + + sprintf (message, "the same type and kind as '%s'", + gfc_current_intrinsic_arg[n]); + + must_be (f, m, message); + + return FAILURE; +} + + +/* Make sure that an expression has a certain (nonzero) rank. */ + +static try +rank_check (gfc_expr * e, int n, int rank) +{ + char message[100]; + + if (e->rank == rank) + return SUCCESS; + + sprintf (message, "of rank %d", rank); + + must_be (e, n, message); + + return FAILURE; +} + + +/* Make sure a variable expression is not an optional dummy argument. */ + +static try +nonoptional_check (gfc_expr * e, int n) +{ + + 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_current_intrinsic_arg[n], gfc_current_intrinsic, + &e->where); + + } + + /* TODO: Recursive check on nonoptional variables? */ + + return SUCCESS; +} + + +/* Check that an expression has a particular kind. */ + +static try +kind_value_check (gfc_expr * e, int n, int k) +{ + char message[100]; + + if (e->ts.kind == k) + return SUCCESS; + + sprintf (message, "of kind %d", k); + + must_be (e, n, message); + return FAILURE; +} + + +/* Make sure an expression is a variable. */ + +static try +variable_check (gfc_expr * e, int n) +{ + + if ((e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor != FL_PARAMETER) + || (e->expr_type == EXPR_FUNCTION + && e->symtree->n.sym->result == e->symtree->n.sym)) + return SUCCESS; + + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)", + gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + &e->where); + return FAILURE; + } + + must_be (e, n, "a variable"); + + return FAILURE; +} + + +/* Check the common DIM parameter for correctness. */ + +static try +dim_check (gfc_expr * dim, int n, int optional) +{ + + if (optional) + { + if (dim == NULL) + return SUCCESS; + + if (nonoptional_check (dim, n) == FAILURE) + return FAILURE; + + return SUCCESS; + } + + if (dim == NULL) + { + gfc_error ("Missing DIM parameter in intrinsic '%s' at %L", + gfc_current_intrinsic, gfc_current_intrinsic_where); + return FAILURE; + } + + if (type_check (dim, n, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (dim, n) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* If a DIM parameter is a constant, make sure that it is greater than + zero and less than or equal to the rank of the given array. If + allow_assumed is zero then dim must be less than the rank of the array + for assumed size arrays. */ + +static try +dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed) +{ + gfc_array_ref *ar; + int rank; + + if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE) + return SUCCESS; + + ar = gfc_find_array_ref (array); + rank = array->rank; + if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed) + rank--; + + 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 " + "dimension index", gfc_current_intrinsic, &dim->where); + + return FAILURE; + } + + return SUCCESS; +} + + +/***** Check functions *****/ + +/* Check subroutine suitable for intrinsics taking a real argument and + a kind argument for the result. */ + +static try +check_a_kind (gfc_expr * a, gfc_expr * kind, bt type) +{ + + if (type_check (a, 0, BT_REAL) == FAILURE) + return FAILURE; + if (kind_check (kind, 1, type) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +/* Check subroutine suitable for ceiling, floor and nint. */ + +try +gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind) +{ + + return check_a_kind (a, kind, BT_INTEGER); +} + +/* Check subroutine suitable for aint, anint. */ + +try +gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind) +{ + + return check_a_kind (a, kind, BT_REAL); +} + +try +gfc_check_abs (gfc_expr * a) +{ + + if (numeric_check (a, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_all_any (gfc_expr * mask, gfc_expr * dim) +{ + + if (logical_array_check (mask, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_allocated (gfc_expr * array) +{ + + if (variable_check (array, 0) == FAILURE) + return FAILURE; + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (!array->symtree->n.sym->attr.allocatable) + { + must_be (array, 0, "ALLOCATABLE"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Common check function where the first argument must be real or + integer and the second argument must be the same as the first. */ + +try +gfc_check_a_p (gfc_expr * a, gfc_expr * p) +{ + + if (int_or_real_check (a, 0) == FAILURE) + return FAILURE; + + if (same_type_check (a, 0, p, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_associated (gfc_expr * pointer, gfc_expr * target) +{ + symbol_attribute attr; + int i; + try t; + + if (variable_check (pointer, 0) == FAILURE) + return FAILURE; + + attr = gfc_variable_attr (pointer, NULL); + if (!attr.pointer) + { + must_be (pointer, 0, "a POINTER"); + return FAILURE; + } + + if (target == NULL) + return SUCCESS; + + /* Target argument is optional. */ + if (target->expr_type == EXPR_NULL) + { + gfc_error ("NULL pointer at %L is not permitted as actual argument " + "of '%s' intrinsic function", + &target->where, gfc_current_intrinsic); + return FAILURE; + } + + attr = gfc_variable_attr (target, NULL); + if (!attr.pointer && !attr.target) + { + must_be (target, 1, "a POINTER or a TARGET"); + return FAILURE; + } + + t = SUCCESS; + if (same_type_check (pointer, 0, target, 1) == FAILURE) + t = FAILURE; + if (rank_check (target, 0, pointer->rank) == FAILURE) + t = FAILURE; + if (target->rank > 0) + { + for (i = 0; i < target->rank; i++) + if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + { + gfc_error ("Array section with a vector subscript at %L shall not " + "be the target of an pointer", + &target->where); + t = FAILURE; + break; + } + } + return t; +} + + +try +gfc_check_btest (gfc_expr * i, gfc_expr * pos) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + if (type_check (pos, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_char (gfc_expr * i, gfc_expr * kind) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + if (kind_check (kind, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + if (y != NULL) + { + if (numeric_check (y, 1) == FAILURE) + return FAILURE; + + if (x->ts.type == BT_COMPLEX) + { + must_be (y, 1, "not be present if 'x' is COMPLEX"); + return FAILURE; + } + } + + if (kind_check (kind, 2, BT_COMPLEX) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_count (gfc_expr * mask, gfc_expr * dim) +{ + + if (logical_array_check (mask, 0) == FAILURE) + return FAILURE; + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (array->rank == 1) + { + if (scalar_check (shift, 1) == FAILURE) + return FAILURE; + } + else + { + /* TODO: more requirements on shift parameter. */ + } + + if (dim_check (dim, 2, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_dcmplx (gfc_expr * x, gfc_expr * y) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + if (y != NULL) + { + if (numeric_check (y, 1) == FAILURE) + return FAILURE; + + if (x->ts.type == BT_COMPLEX) + { + must_be (y, 1, "not be present if 'x' is COMPLEX"); + return FAILURE; + } + } + + return SUCCESS; +} + + +try +gfc_check_dble (gfc_expr * x) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_digits (gfc_expr * x) +{ + + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b) +{ + + switch (vector_a->ts.type) + { + case BT_LOGICAL: + if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + break; + + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + if (numeric_check (vector_b, 1) == FAILURE) + return FAILURE; + break; + + default: + must_be (vector_a, 0, "numeric or LOGICAL"); + return FAILURE; + } + + if (rank_check (vector_a, 0, 1) == FAILURE) + return FAILURE; + + if (rank_check (vector_b, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary, + gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (type_check (shift, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (array->rank == 1) + { + if (scalar_check (shift, 2) == FAILURE) + return FAILURE; + } + else + { + /* TODO: more weird restrictions on shift. */ + } + + if (boundary != NULL) + { + if (same_type_check (array, 0, boundary, 2) == FAILURE) + return FAILURE; + + /* TODO: more restrictions on boundary. */ + } + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + + +try +gfc_check_huge (gfc_expr * x) +{ + + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Check that the single argument is an integer. */ + +try +gfc_check_i (gfc_expr * i) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_iand (gfc_expr * i, gfc_expr * j) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ibclr (gfc_expr * i, gfc_expr * pos) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (pos, 1, BT_INTEGER) == FAILURE + || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (pos, 1, BT_INTEGER) == FAILURE + || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE + || type_check (len, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ibset (gfc_expr * i, gfc_expr * pos) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (pos, 1, BT_INTEGER) == FAILURE + || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_idnint (gfc_expr * a) +{ + + if (double_check (a, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ieor (gfc_expr * i, gfc_expr * j) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back) +{ + + 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 (string->ts.kind != substring->ts.kind) + { + must_be (substring, 1, "the same kind as 'string'"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_int (gfc_expr * x, gfc_expr * kind) +{ + + if (numeric_check (x, 0) == FAILURE + || kind_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ior (gfc_expr * i, gfc_expr * j) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ishft (gfc_expr * i, gfc_expr * shift) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (shift, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (shift, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_kind (gfc_expr * x) +{ + + if (x->ts.type == BT_DERIVED) + { + must_be (x, 0, "a non-derived type"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_lbound (gfc_expr * array, gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, 1) == FAILURE) + return FAILURE; + } + return SUCCESS; +} + + +try +gfc_check_logical (gfc_expr * a, gfc_expr * kind) +{ + + if (type_check (a, 0, BT_LOGICAL) == FAILURE) + return FAILURE; + if (kind_check (kind, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Min/max family. */ + +static try +min_max_args (gfc_actual_arglist * arg) +{ + + if (arg == NULL || arg->next == NULL) + { + gfc_error ("Intrinsic '%s' at %L must have at least two arguments", + gfc_current_intrinsic, gfc_current_intrinsic_where); + return FAILURE; + } + + return SUCCESS; +} + + +static try +check_rest (bt type, int kind, gfc_actual_arglist * arg) +{ + gfc_expr *x; + int n; + + if (min_max_args (arg) == FAILURE) + return FAILURE; + + n = 1; + + for (; arg; arg = arg->next, n++) + { + x = arg->expr; + if (x->ts.type != type || x->ts.kind != kind) + { + if (x->ts.type == type) + { + if (gfc_notify_std (GFC_STD_GNU, + "Extension: Different type kinds at %L", &x->where) + == FAILURE) + return FAILURE; + } + else + { + gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)", + n, gfc_current_intrinsic, &x->where, + gfc_basic_typename (type), kind); + return FAILURE; + } + } + } + + return SUCCESS; +} + + +try +gfc_check_min_max (gfc_actual_arglist * arg) +{ + gfc_expr *x; + + if (min_max_args (arg) == FAILURE) + return FAILURE; + + x = arg->expr; + + 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); + return FAILURE; + } + + return check_rest (x->ts.type, x->ts.kind, arg); +} + + +try +gfc_check_min_max_integer (gfc_actual_arglist * arg) +{ + + return check_rest (BT_INTEGER, gfc_default_integer_kind (), arg); +} + + +try +gfc_check_min_max_real (gfc_actual_arglist * arg) +{ + + return check_rest (BT_REAL, gfc_default_real_kind (), arg); +} + + +try +gfc_check_min_max_double (gfc_actual_arglist * arg) +{ + + return check_rest (BT_REAL, gfc_default_double_kind (), arg); +} + +/* End of min/max family. */ + + +try +gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b) +{ + + if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) + { + must_be (matrix_a, 0, "numeric or LOGICAL"); + return FAILURE; + } + + if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) + { + must_be (matrix_b, 0, "numeric or LOGICAL"); + return FAILURE; + } + + switch (matrix_a->rank) + { + case 1: + if (rank_check (matrix_b, 1, 2) == FAILURE) + return FAILURE; + break; + + case 2: + if (matrix_b->rank == 2) + break; + if (rank_check (matrix_b, 1, 1) == FAILURE) + return FAILURE; + break; + + default: + must_be (matrix_a, 0, "of rank 1 or 2"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Whoever came up with this interface was probably on something. + The possibilities for the occupation of the second and third + parameters are: + + Arg #2 Arg #3 + NULL NULL + DIM NULL + MASK NULL + NULL MASK minloc(array, mask=m) + DIM MASK +*/ + +try +gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3) +{ + + if (int_or_real_check (array, 0) == FAILURE) + return FAILURE; + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (a3 != NULL) + { + if (logical_array_check (a3, 2) == FAILURE) + return FAILURE; + + if (a2 != NULL) + { + if (scalar_check (a2, 1) == FAILURE) + return FAILURE; + if (type_check (a2, 1, BT_INTEGER) == FAILURE) + return FAILURE; + } + } + else + { + if (a2 != NULL) + { + switch (a2->ts.type) + { + case BT_INTEGER: + if (scalar_check (a2, 1) == FAILURE) + return FAILURE; + break; + + case BT_LOGICAL: /* The '2' makes the error message correct */ + if (logical_array_check (a2, 2) == FAILURE) + return FAILURE; + break; + + default: + type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */ + return FAILURE; + } + } + } + + return SUCCESS; +} + + +try +gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (int_or_real_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (mask != NULL && logical_array_check (mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask) +{ + + if (same_type_check (tsource, 0, fsource, 1) == FAILURE) + return FAILURE; + + if (type_check (mask, 2, BT_LOGICAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_nearest (gfc_expr * x, gfc_expr * s) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (type_check (s, 1, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_null (gfc_expr * mold) +{ + symbol_attribute attr; + + if (mold == NULL) + return SUCCESS; + + if (variable_check (mold, 0) == FAILURE) + return FAILURE; + + attr = gfc_variable_attr (mold, NULL); + + if (!attr.pointer) + { + must_be (mold, 0, "a POINTER"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (type_check (mask, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (mask->rank != 0 && mask->rank != array->rank) + { + must_be (array, 0, "conformable with 'mask' argument"); + return FAILURE; + } + + if (vector != NULL) + { + if (same_type_check (array, 0, vector, 2) == FAILURE) + return FAILURE; + + if (rank_check (vector, 2, 1) == FAILURE) + return FAILURE; + + /* TODO: More constraints here. */ + } + + return SUCCESS; +} + + +try +gfc_check_precision (gfc_expr * x) +{ + + if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX) + { + must_be (x, 0, "of type REAL or COMPLEX"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_present (gfc_expr * a) +{ + gfc_symbol *sym; + + if (variable_check (a, 0) == FAILURE) + return FAILURE; + + sym = a->symtree->n.sym; + if (!sym->attr.dummy) + { + must_be (a, 0, "a dummy variable"); + return FAILURE; + } + + if (!sym->attr.optional) + { + must_be (a, 0, "an OPTIONAL dummy variable"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (numeric_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (mask != NULL && logical_array_check (mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_radix (gfc_expr * x) +{ + + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_range (gfc_expr * x) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* real, float, sngl. */ +try +gfc_check_real (gfc_expr * a, gfc_expr * kind) +{ + + if (numeric_check (a, 0) == FAILURE) + return FAILURE; + + if (kind_check (kind, 1, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_repeat (gfc_expr * x, gfc_expr * y) +{ + + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + if (type_check (y, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (y, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_reshape (gfc_expr * source, gfc_expr * shape, + gfc_expr * pad, gfc_expr * order) +{ + mpz_t size; + int m; + + if (array_check (source, 0) == FAILURE) + return FAILURE; + + if (rank_check (shape, 1, 1) == FAILURE) + return FAILURE; + + if (type_check (shape, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (gfc_array_size (shape, &size) != SUCCESS) + { + gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an " + "array of constant size", &shape->where); + return FAILURE; + } + + m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS); + mpz_clear (size); + + if (m > 0) + { + gfc_error + ("'shape' argument of 'reshape' intrinsic at %L has more than " + stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where); + return FAILURE; + } + + if (pad != NULL) + { + if (same_type_check (source, 0, pad, 2) == FAILURE) + return FAILURE; + if (array_check (pad, 2) == FAILURE) + return FAILURE; + } + + if (order != NULL && array_check (order, 3) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_scale (gfc_expr * x, gfc_expr * i) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (type_check (i, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z) +{ + + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (y, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (same_type_check (x, 0, y, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r) +{ + + if (p == NULL && r == NULL) + { + gfc_error ("Missing arguments to %s intrinsic at %L", + gfc_current_intrinsic, gfc_current_intrinsic_where); + + return FAILURE; + } + + if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_set_exponent (gfc_expr * x, gfc_expr * i) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (type_check (i, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_shape (gfc_expr * source) +{ + gfc_array_ref *ar; + + if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) + return SUCCESS; + + ar = gfc_find_array_ref (source); + + if (ar->as && ar->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("'source' argument of 'shape' intrinsic at %L must not be " + "an assumed size array", &source->where); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_size (gfc_expr * array, gfc_expr * dim) +{ + + 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) + return FAILURE; + + if (dim_rank_check (dim, array, 0) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_sign (gfc_expr * a, gfc_expr * b) +{ + + if (int_or_real_check (a, 0) == FAILURE) + return FAILURE; + + if (same_type_check (a, 0, b, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies) +{ + + if (source->rank >= GFC_MAX_DIMENSIONS) + { + must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS)); + return FAILURE; + } + + if (dim_check (dim, 1, 0) == FAILURE) + return FAILURE; + + if (type_check (ncopies, 2, BT_INTEGER) == FAILURE) + return FAILURE; + if (scalar_check (ncopies, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (numeric_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (mask != NULL && logical_array_check (mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED, + gfc_expr * mold ATTRIBUTE_UNUSED, + gfc_expr * size) +{ + + if (size != NULL) + { + if (type_check (size, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (size, 2) == FAILURE) + return FAILURE; + + if (nonoptional_check (size, 2) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_transpose (gfc_expr * matrix) +{ + + if (rank_check (matrix, 0, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ubound (gfc_expr * array, gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, 0) == FAILURE) + return FAILURE; + } + return SUCCESS; +} + + +try +gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field) +{ + + if (rank_check (vector, 0, 1) == FAILURE) + return FAILURE; + + if (array_check (mask, 1) == FAILURE) + return FAILURE; + + if (type_check (mask, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (same_type_check (vector, 0, field, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z) +{ + + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (same_type_check (x, 0, y, 1) == FAILURE) + return FAILURE; + + if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_trim (gfc_expr * x) +{ + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Common check function for the half a dozen intrinsics that have a + single real argument. */ + +try +gfc_check_x (gfc_expr * x) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/************* Check functions for intrinsic subroutines *************/ + +try +gfc_check_cpu_time (gfc_expr * time) +{ + + if (scalar_check (time, 0) == FAILURE) + return FAILURE; + + if (type_check (time, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (variable_check (time, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_date_and_time (gfc_expr * date, gfc_expr * time, + gfc_expr * zone, gfc_expr * values) +{ + + if (date != NULL) + { + if (type_check (date, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + if (scalar_check (date, 0) == FAILURE) + return FAILURE; + if (variable_check (date, 0) == FAILURE) + return FAILURE; + } + + if (time != NULL) + { + if (type_check (time, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + if (scalar_check (time, 1) == FAILURE) + return FAILURE; + if (variable_check (time, 1) == FAILURE) + return FAILURE; + } + + if (zone != NULL) + { + if (type_check (zone, 2, BT_CHARACTER) == FAILURE) + return FAILURE; + if (scalar_check (zone, 2) == FAILURE) + return FAILURE; + if (variable_check (zone, 2) == FAILURE) + return FAILURE; + } + + if (values != NULL) + { + if (type_check (values, 3, BT_INTEGER) == FAILURE) + return FAILURE; + if (array_check (values, 3) == FAILURE) + return FAILURE; + if (rank_check (values, 3, 1) == FAILURE) + return FAILURE; + if (variable_check (values, 3) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len, + gfc_expr * to, gfc_expr * topos) +{ + + if (type_check (from, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (frompos, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (len, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (from, 0, to, 3) == FAILURE) + return FAILURE; + + if (variable_check (to, 3) == FAILURE) + return FAILURE; + + if (type_check (topos, 4, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_random_number (gfc_expr * harvest) +{ + + if (type_check (harvest, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (variable_check (harvest, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get) +{ + + if (size != NULL) + { + if (scalar_check (size, 0) == FAILURE) + return FAILURE; + + if (type_check (size, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (variable_check (size, 0) == FAILURE) + return FAILURE; + + if (kind_value_check (size, 0, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + } + + if (put != NULL) + { + if (array_check (put, 1) == FAILURE) + return FAILURE; + if (rank_check (put, 1, 1) == FAILURE) + return FAILURE; + + if (type_check (put, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind_value_check (put, 1, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + } + + if (get != NULL) + { + if (array_check (get, 2) == FAILURE) + return FAILURE; + if (rank_check (get, 2, 1) == FAILURE) + return FAILURE; + + if (type_check (get, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (variable_check (get, 2) == FAILURE) + return FAILURE; + + if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} |