2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* These functions check to see if an argument list is compatible with
24 a particular intrinsic function or subroutine. Presence of
25 required arguments has already been established, the argument list
26 has been sorted into the right order and has NULL arguments in the
27 correct places for missing optional arguments. */
33 #include "intrinsic.h"
36 /* The fundamental complaint function of this source file. This
37 function can be called in all kinds of ways. */
40 must_be (gfc_expr * e, int n, const char *thing)
42 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
43 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
48 /* Check the type of an expression. */
51 type_check (gfc_expr * e, int n, bt type)
53 if (e->ts.type == type)
56 must_be (e, n, gfc_basic_typename (type));
62 /* Check that the expression is a numeric type. */
65 numeric_check (gfc_expr * e, int n)
67 if (gfc_numeric_ts (&e->ts))
70 must_be (e, n, "a numeric type");
76 /* Check that an expression is integer or real. */
79 int_or_real_check (gfc_expr * e, int n)
81 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
83 must_be (e, n, "INTEGER or REAL");
91 /* Check that an expression is real or complex. */
94 real_or_complex_check (gfc_expr * e, int n)
96 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
98 must_be (e, n, "REAL or COMPLEX");
106 /* Check that the expression is an optional constant integer
107 and that it specifies a valid kind for that type. */
110 kind_check (gfc_expr * k, int n, bt type)
117 if (type_check (k, n, BT_INTEGER) == FAILURE)
120 if (k->expr_type != EXPR_CONSTANT)
122 must_be (k, n, "a constant");
126 if (gfc_extract_int (k, &kind) != NULL
127 || gfc_validate_kind (type, kind, true) < 0)
129 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
138 /* Make sure the expression is a double precision real. */
141 double_check (gfc_expr * d, int n)
143 if (type_check (d, n, BT_REAL) == FAILURE)
146 if (d->ts.kind != gfc_default_double_kind)
148 must_be (d, n, "double precision");
156 /* Make sure the expression is a logical array. */
159 logical_array_check (gfc_expr * array, int n)
161 if (array->ts.type != BT_LOGICAL || array->rank == 0)
163 must_be (array, n, "a logical array");
171 /* Make sure an expression is an array. */
174 array_check (gfc_expr * e, int n)
179 must_be (e, n, "an array");
185 /* Make sure an expression is a scalar. */
188 scalar_check (gfc_expr * e, int n)
193 must_be (e, n, "a scalar");
199 /* Make sure two expression have the same type. */
202 same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
206 if (gfc_compare_types (&e->ts, &f->ts))
209 sprintf (message, "the same type and kind as '%s'",
210 gfc_current_intrinsic_arg[n]);
212 must_be (f, m, message);
218 /* Make sure that an expression has a certain (nonzero) rank. */
221 rank_check (gfc_expr * e, int n, int rank)
228 sprintf (message, "of rank %d", rank);
230 must_be (e, n, message);
236 /* Make sure a variable expression is not an optional dummy argument. */
239 nonoptional_check (gfc_expr * e, int n)
241 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
243 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
244 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
249 /* TODO: Recursive check on nonoptional variables? */
255 /* Check that an expression has a particular kind. */
258 kind_value_check (gfc_expr * e, int n, int k)
265 sprintf (message, "of kind %d", k);
267 must_be (e, n, message);
272 /* Make sure an expression is a variable. */
275 variable_check (gfc_expr * e, int n)
277 if ((e->expr_type == EXPR_VARIABLE
278 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
279 || (e->expr_type == EXPR_FUNCTION
280 && e->symtree->n.sym->result == e->symtree->n.sym))
283 if (e->expr_type == EXPR_VARIABLE
284 && e->symtree->n.sym->attr.intent == INTENT_IN)
286 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
287 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
292 must_be (e, n, "a variable");
298 /* Check the common DIM parameter for correctness. */
301 dim_check (gfc_expr * dim, int n, int optional)
308 if (nonoptional_check (dim, n) == FAILURE)
316 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
317 gfc_current_intrinsic, gfc_current_intrinsic_where);
321 if (type_check (dim, n, BT_INTEGER) == FAILURE)
324 if (scalar_check (dim, n) == FAILURE)
331 /* If a DIM parameter is a constant, make sure that it is greater than
332 zero and less than or equal to the rank of the given array. If
333 allow_assumed is zero then dim must be less than the rank of the array
334 for assumed size arrays. */
337 dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
342 if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
345 ar = gfc_find_array_ref (array);
347 if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
350 if (mpz_cmp_ui (dim->value.integer, 1) < 0
351 || mpz_cmp_ui (dim->value.integer, rank) > 0)
353 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
354 "dimension index", gfc_current_intrinsic, &dim->where);
363 /***** Check functions *****/
365 /* Check subroutine suitable for intrinsics taking a real argument and
366 a kind argument for the result. */
369 check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
371 if (type_check (a, 0, BT_REAL) == FAILURE)
373 if (kind_check (kind, 1, type) == FAILURE)
379 /* Check subroutine suitable for ceiling, floor and nint. */
382 gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
384 return check_a_kind (a, kind, BT_INTEGER);
387 /* Check subroutine suitable for aint, anint. */
390 gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
392 return check_a_kind (a, kind, BT_REAL);
396 gfc_check_abs (gfc_expr * a)
398 if (numeric_check (a, 0) == FAILURE)
405 gfc_check_achar (gfc_expr * a)
408 if (type_check (a, 0, BT_INTEGER) == FAILURE)
416 gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
418 if (logical_array_check (mask, 0) == FAILURE)
421 if (dim_check (dim, 1, 1) == FAILURE)
429 gfc_check_allocated (gfc_expr * array)
431 if (variable_check (array, 0) == FAILURE)
434 if (array_check (array, 0) == FAILURE)
437 if (!array->symtree->n.sym->attr.allocatable)
439 must_be (array, 0, "ALLOCATABLE");
447 /* Common check function where the first argument must be real or
448 integer and the second argument must be the same as the first. */
451 gfc_check_a_p (gfc_expr * a, gfc_expr * p)
453 if (int_or_real_check (a, 0) == FAILURE)
456 if (same_type_check (a, 0, p, 1) == FAILURE)
464 gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
466 symbol_attribute attr;
470 if (variable_check (pointer, 0) == FAILURE)
473 attr = gfc_variable_attr (pointer, NULL);
476 must_be (pointer, 0, "a POINTER");
483 /* Target argument is optional. */
484 if (target->expr_type == EXPR_NULL)
486 gfc_error ("NULL pointer at %L is not permitted as actual argument "
487 "of '%s' intrinsic function",
488 &target->where, gfc_current_intrinsic);
492 attr = gfc_variable_attr (target, NULL);
493 if (!attr.pointer && !attr.target)
495 must_be (target, 1, "a POINTER or a TARGET");
500 if (same_type_check (pointer, 0, target, 1) == FAILURE)
502 if (rank_check (target, 0, pointer->rank) == FAILURE)
504 if (target->rank > 0)
506 for (i = 0; i < target->rank; i++)
507 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
509 gfc_error ("Array section with a vector subscript at %L shall not "
510 "be the target of an pointer",
521 gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
523 if (type_check (y, 0, BT_REAL) == FAILURE)
525 if (same_type_check (y, 0, x, 1) == FAILURE)
532 /* BESJN and BESYN functions. */
535 gfc_check_besn (gfc_expr * n, gfc_expr * x)
537 if (scalar_check (n, 0) == FAILURE)
540 if (type_check (n, 0, BT_INTEGER) == FAILURE)
543 if (scalar_check (x, 1) == FAILURE)
546 if (type_check (x, 1, BT_REAL) == FAILURE)
554 gfc_check_btest (gfc_expr * i, gfc_expr * pos)
556 if (type_check (i, 0, BT_INTEGER) == FAILURE)
558 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
566 gfc_check_char (gfc_expr * i, gfc_expr * kind)
568 if (type_check (i, 0, BT_INTEGER) == FAILURE)
570 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
578 gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
580 if (numeric_check (x, 0) == FAILURE)
585 if (numeric_check (y, 1) == FAILURE)
588 if (x->ts.type == BT_COMPLEX)
590 must_be (y, 1, "not be present if 'x' is COMPLEX");
595 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
603 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
605 if (logical_array_check (mask, 0) == FAILURE)
607 if (dim_check (dim, 1, 1) == FAILURE)
615 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
617 if (array_check (array, 0) == FAILURE)
620 if (array->rank == 1)
622 if (scalar_check (shift, 1) == FAILURE)
627 /* TODO: more requirements on shift parameter. */
630 if (dim_check (dim, 2, 1) == FAILURE)
638 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
640 if (numeric_check (x, 0) == FAILURE)
645 if (numeric_check (y, 1) == FAILURE)
648 if (x->ts.type == BT_COMPLEX)
650 must_be (y, 1, "not be present if 'x' is COMPLEX");
660 gfc_check_dble (gfc_expr * x)
662 if (numeric_check (x, 0) == FAILURE)
670 gfc_check_digits (gfc_expr * x)
672 if (int_or_real_check (x, 0) == FAILURE)
680 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
682 switch (vector_a->ts.type)
685 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
692 if (numeric_check (vector_b, 1) == FAILURE)
697 must_be (vector_a, 0, "numeric or LOGICAL");
701 if (rank_check (vector_a, 0, 1) == FAILURE)
704 if (rank_check (vector_b, 1, 1) == FAILURE)
712 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
715 if (array_check (array, 0) == FAILURE)
718 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
721 if (array->rank == 1)
723 if (scalar_check (shift, 2) == FAILURE)
728 /* TODO: more weird restrictions on shift. */
731 if (boundary != NULL)
733 if (same_type_check (array, 0, boundary, 2) == FAILURE)
736 /* TODO: more restrictions on boundary. */
739 if (dim_check (dim, 1, 1) == FAILURE)
746 /* A single complex argument. */
749 gfc_check_fn_c (gfc_expr * a)
751 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
758 /* A single real argument. */
761 gfc_check_fn_r (gfc_expr * a)
763 if (type_check (a, 0, BT_REAL) == FAILURE)
770 /* A single real or complex argument. */
773 gfc_check_fn_rc (gfc_expr * a)
775 if (real_or_complex_check (a, 0) == FAILURE)
783 gfc_check_fnum (gfc_expr * unit)
785 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
788 if (scalar_check (unit, 0) == FAILURE)
795 /* This is used for the g77 one-argument Bessel functions, and the
799 gfc_check_g77_math1 (gfc_expr * x)
801 if (scalar_check (x, 0) == FAILURE)
804 if (type_check (x, 0, BT_REAL) == FAILURE)
812 gfc_check_huge (gfc_expr * x)
814 if (int_or_real_check (x, 0) == FAILURE)
821 /* Check that the single argument is an integer. */
824 gfc_check_i (gfc_expr * i)
826 if (type_check (i, 0, BT_INTEGER) == FAILURE)
834 gfc_check_iand (gfc_expr * i, gfc_expr * j)
836 if (type_check (i, 0, BT_INTEGER) == FAILURE)
839 if (type_check (j, 1, BT_INTEGER) == FAILURE)
842 if (i->ts.kind != j->ts.kind)
844 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
845 &i->where) == FAILURE)
854 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
856 if (type_check (i, 0, BT_INTEGER) == FAILURE)
859 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
867 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
869 if (type_check (i, 0, BT_INTEGER) == FAILURE)
872 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
875 if (type_check (len, 2, BT_INTEGER) == FAILURE)
883 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
885 if (type_check (i, 0, BT_INTEGER) == FAILURE)
888 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
896 gfc_check_idnint (gfc_expr * a)
898 if (double_check (a, 0) == FAILURE)
906 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
908 if (type_check (i, 0, BT_INTEGER) == FAILURE)
911 if (type_check (j, 1, BT_INTEGER) == FAILURE)
914 if (i->ts.kind != j->ts.kind)
916 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
917 &i->where) == FAILURE)
926 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
928 if (type_check (string, 0, BT_CHARACTER) == FAILURE
929 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
933 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
936 if (string->ts.kind != substring->ts.kind)
938 must_be (substring, 1, "the same kind as 'string'");
947 gfc_check_int (gfc_expr * x, gfc_expr * kind)
949 if (numeric_check (x, 0) == FAILURE)
954 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
957 if (scalar_check (kind, 1) == FAILURE)
966 gfc_check_ior (gfc_expr * i, gfc_expr * j)
968 if (type_check (i, 0, BT_INTEGER) == FAILURE)
971 if (type_check (j, 1, BT_INTEGER) == FAILURE)
974 if (i->ts.kind != j->ts.kind)
976 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
977 &i->where) == FAILURE)
986 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
988 if (type_check (i, 0, BT_INTEGER) == FAILURE
989 || type_check (shift, 1, BT_INTEGER) == FAILURE)
997 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
999 if (type_check (i, 0, BT_INTEGER) == FAILURE
1000 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1003 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1011 gfc_check_kind (gfc_expr * x)
1013 if (x->ts.type == BT_DERIVED)
1015 must_be (x, 0, "a non-derived type");
1024 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1026 if (array_check (array, 0) == FAILURE)
1031 if (dim_check (dim, 1, 1) == FAILURE)
1034 if (dim_rank_check (dim, array, 1) == FAILURE)
1042 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1044 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1046 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1053 /* Min/max family. */
1056 min_max_args (gfc_actual_arglist * arg)
1058 if (arg == NULL || arg->next == NULL)
1060 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1061 gfc_current_intrinsic, gfc_current_intrinsic_where);
1070 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1075 if (min_max_args (arg) == FAILURE)
1080 for (; arg; arg = arg->next, n++)
1083 if (x->ts.type != type || x->ts.kind != kind)
1085 if (x->ts.type == type)
1087 if (gfc_notify_std (GFC_STD_GNU,
1088 "Extension: Different type kinds at %L", &x->where)
1094 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1095 n, gfc_current_intrinsic, &x->where,
1096 gfc_basic_typename (type), kind);
1107 gfc_check_min_max (gfc_actual_arglist * arg)
1111 if (min_max_args (arg) == FAILURE)
1116 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1119 ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1120 gfc_current_intrinsic, &x->where);
1124 return check_rest (x->ts.type, x->ts.kind, arg);
1129 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1131 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1136 gfc_check_min_max_real (gfc_actual_arglist * arg)
1138 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1143 gfc_check_min_max_double (gfc_actual_arglist * arg)
1145 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1148 /* End of min/max family. */
1152 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1154 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1156 must_be (matrix_a, 0, "numeric or LOGICAL");
1160 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1162 must_be (matrix_b, 0, "numeric or LOGICAL");
1166 switch (matrix_a->rank)
1169 if (rank_check (matrix_b, 1, 2) == FAILURE)
1174 if (matrix_b->rank == 2)
1176 if (rank_check (matrix_b, 1, 1) == FAILURE)
1181 must_be (matrix_a, 0, "of rank 1 or 2");
1189 /* Whoever came up with this interface was probably on something.
1190 The possibilities for the occupation of the second and third
1197 NULL MASK minloc(array, mask=m)
1200 I.e. in the case of minloc(array,mask), mask will be in the second
1201 position of the argument list and we'll have to fix that up. */
1204 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1206 gfc_expr *a, *m, *d;
1209 if (int_or_real_check (a, 0) == FAILURE
1210 || array_check (a, 0) == FAILURE)
1214 m = ap->next->next->expr;
1216 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1217 && ap->next->name[0] == '\0')
1222 ap->next->expr = NULL;
1223 ap->next->next->expr = m;
1227 && (scalar_check (d, 1) == FAILURE
1228 || type_check (d, 1, BT_INTEGER) == FAILURE))
1231 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1238 /* Similar to minloc/maxloc, the argument list might need to be
1239 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1240 difference is that MINLOC/MAXLOC take an additional KIND argument.
1241 The possibilities are:
1247 NULL MASK minval(array, mask=m)
1250 I.e. in the case of minval(array,mask), mask will be in the second
1251 position of the argument list and we'll have to fix that up. */
1254 check_reduction (gfc_actual_arglist * ap)
1259 m = ap->next->next->expr;
1261 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1262 && ap->next->name[0] == '\0')
1267 ap->next->expr = NULL;
1268 ap->next->next->expr = m;
1272 && (scalar_check (d, 1) == FAILURE
1273 || type_check (d, 1, BT_INTEGER) == FAILURE))
1276 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1284 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1286 if (int_or_real_check (ap->expr, 0) == FAILURE
1287 || array_check (ap->expr, 0) == FAILURE)
1290 return check_reduction (ap);
1295 gfc_check_product_sum (gfc_actual_arglist * ap)
1297 if (numeric_check (ap->expr, 0) == FAILURE
1298 || array_check (ap->expr, 0) == FAILURE)
1301 return check_reduction (ap);
1306 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1308 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1311 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1319 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1321 if (type_check (x, 0, BT_REAL) == FAILURE)
1324 if (type_check (s, 1, BT_REAL) == FAILURE)
1332 gfc_check_null (gfc_expr * mold)
1334 symbol_attribute attr;
1339 if (variable_check (mold, 0) == FAILURE)
1342 attr = gfc_variable_attr (mold, NULL);
1346 must_be (mold, 0, "a POINTER");
1355 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1357 if (array_check (array, 0) == FAILURE)
1360 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1363 if (mask->rank != 0 && mask->rank != array->rank)
1365 must_be (array, 0, "conformable with 'mask' argument");
1371 if (same_type_check (array, 0, vector, 2) == FAILURE)
1374 if (rank_check (vector, 2, 1) == FAILURE)
1377 /* TODO: More constraints here. */
1385 gfc_check_precision (gfc_expr * x)
1387 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1389 must_be (x, 0, "of type REAL or COMPLEX");
1398 gfc_check_present (gfc_expr * a)
1402 if (variable_check (a, 0) == FAILURE)
1405 sym = a->symtree->n.sym;
1406 if (!sym->attr.dummy)
1408 must_be (a, 0, "a dummy variable");
1412 if (!sym->attr.optional)
1414 must_be (a, 0, "an OPTIONAL dummy variable");
1423 gfc_check_radix (gfc_expr * x)
1425 if (int_or_real_check (x, 0) == FAILURE)
1433 gfc_check_range (gfc_expr * x)
1435 if (numeric_check (x, 0) == FAILURE)
1442 /* real, float, sngl. */
1444 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1446 if (numeric_check (a, 0) == FAILURE)
1449 if (kind_check (kind, 1, BT_REAL) == FAILURE)
1457 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1459 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1462 if (scalar_check (x, 0) == FAILURE)
1465 if (type_check (y, 0, BT_INTEGER) == FAILURE)
1468 if (scalar_check (y, 1) == FAILURE)
1476 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1477 gfc_expr * pad, gfc_expr * order)
1482 if (array_check (source, 0) == FAILURE)
1485 if (rank_check (shape, 1, 1) == FAILURE)
1488 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1491 if (gfc_array_size (shape, &size) != SUCCESS)
1493 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1494 "array of constant size", &shape->where);
1498 m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1504 ("'shape' argument of 'reshape' intrinsic at %L has more than "
1505 stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1511 if (same_type_check (source, 0, pad, 2) == FAILURE)
1513 if (array_check (pad, 2) == FAILURE)
1517 if (order != NULL && array_check (order, 3) == FAILURE)
1525 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1527 if (type_check (x, 0, BT_REAL) == FAILURE)
1530 if (type_check (i, 1, BT_INTEGER) == FAILURE)
1538 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1540 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1543 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1546 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1549 if (same_type_check (x, 0, y, 1) == FAILURE)
1557 gfc_check_selected_int_kind (gfc_expr * r)
1560 if (type_check (r, 0, BT_INTEGER) == FAILURE)
1563 if (scalar_check (r, 0) == FAILURE)
1571 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1573 if (p == NULL && r == NULL)
1575 gfc_error ("Missing arguments to %s intrinsic at %L",
1576 gfc_current_intrinsic, gfc_current_intrinsic_where);
1581 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1584 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1592 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1594 if (type_check (x, 0, BT_REAL) == FAILURE)
1597 if (type_check (i, 1, BT_INTEGER) == FAILURE)
1605 gfc_check_shape (gfc_expr * source)
1609 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1612 ar = gfc_find_array_ref (source);
1614 if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1616 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1617 "an assumed size array", &source->where);
1626 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1628 if (int_or_real_check (a, 0) == FAILURE)
1631 if (same_type_check (a, 0, b, 1) == FAILURE)
1639 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1641 if (array_check (array, 0) == FAILURE)
1646 if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1649 if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1652 if (dim_rank_check (dim, array, 0) == FAILURE)
1661 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1663 if (source->rank >= GFC_MAX_DIMENSIONS)
1665 must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1669 if (dim_check (dim, 1, 0) == FAILURE)
1672 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1675 if (scalar_check (ncopies, 2) == FAILURE)
1683 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
1685 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1688 if (scalar_check (unit, 0) == FAILURE)
1691 if (type_check (array, 1, BT_INTEGER) == FAILURE
1692 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
1695 if (array_check (array, 1) == FAILURE)
1703 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
1705 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1708 if (scalar_check (unit, 0) == FAILURE)
1711 if (type_check (array, 1, BT_INTEGER) == FAILURE
1712 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1715 if (array_check (array, 1) == FAILURE)
1721 if (type_check (status, 2, BT_INTEGER) == FAILURE
1722 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
1725 if (scalar_check (status, 2) == FAILURE)
1733 gfc_check_stat (gfc_expr * name, gfc_expr * array)
1735 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1738 if (type_check (array, 1, BT_INTEGER) == FAILURE
1739 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1742 if (array_check (array, 1) == FAILURE)
1750 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
1752 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1755 if (type_check (array, 1, BT_INTEGER) == FAILURE
1756 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1759 if (array_check (array, 1) == FAILURE)
1765 if (type_check (status, 2, BT_INTEGER) == FAILURE
1766 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1769 if (scalar_check (status, 2) == FAILURE)
1777 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1778 gfc_expr * mold ATTRIBUTE_UNUSED,
1783 if (type_check (size, 2, BT_INTEGER) == FAILURE)
1786 if (scalar_check (size, 2) == FAILURE)
1789 if (nonoptional_check (size, 2) == FAILURE)
1798 gfc_check_transpose (gfc_expr * matrix)
1800 if (rank_check (matrix, 0, 2) == FAILURE)
1808 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
1810 if (array_check (array, 0) == FAILURE)
1815 if (dim_check (dim, 1, 1) == FAILURE)
1818 if (dim_rank_check (dim, array, 0) == FAILURE)
1827 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1829 if (rank_check (vector, 0, 1) == FAILURE)
1832 if (array_check (mask, 1) == FAILURE)
1835 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1838 if (same_type_check (vector, 0, field, 2) == FAILURE)
1846 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1848 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1851 if (same_type_check (x, 0, y, 1) == FAILURE)
1854 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1862 gfc_check_trim (gfc_expr * x)
1864 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1867 if (scalar_check (x, 0) == FAILURE)
1874 /* Common check function for the half a dozen intrinsics that have a
1875 single real argument. */
1878 gfc_check_x (gfc_expr * x)
1880 if (type_check (x, 0, BT_REAL) == FAILURE)
1887 /************* Check functions for intrinsic subroutines *************/
1890 gfc_check_cpu_time (gfc_expr * time)
1892 if (scalar_check (time, 0) == FAILURE)
1895 if (type_check (time, 0, BT_REAL) == FAILURE)
1898 if (variable_check (time, 0) == FAILURE)
1906 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1907 gfc_expr * zone, gfc_expr * values)
1911 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1913 if (scalar_check (date, 0) == FAILURE)
1915 if (variable_check (date, 0) == FAILURE)
1921 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1923 if (scalar_check (time, 1) == FAILURE)
1925 if (variable_check (time, 1) == FAILURE)
1931 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1933 if (scalar_check (zone, 2) == FAILURE)
1935 if (variable_check (zone, 2) == FAILURE)
1941 if (type_check (values, 3, BT_INTEGER) == FAILURE)
1943 if (array_check (values, 3) == FAILURE)
1945 if (rank_check (values, 3, 1) == FAILURE)
1947 if (variable_check (values, 3) == FAILURE)
1956 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1957 gfc_expr * to, gfc_expr * topos)
1959 if (type_check (from, 0, BT_INTEGER) == FAILURE)
1962 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1965 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1968 if (same_type_check (from, 0, to, 3) == FAILURE)
1971 if (variable_check (to, 3) == FAILURE)
1974 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1982 gfc_check_random_number (gfc_expr * harvest)
1984 if (type_check (harvest, 0, BT_REAL) == FAILURE)
1987 if (variable_check (harvest, 0) == FAILURE)
1995 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1999 if (scalar_check (size, 0) == FAILURE)
2002 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2005 if (variable_check (size, 0) == FAILURE)
2008 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2016 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2019 if (array_check (put, 1) == FAILURE)
2022 if (rank_check (put, 1, 1) == FAILURE)
2025 if (type_check (put, 1, BT_INTEGER) == FAILURE)
2028 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2035 if (size != NULL || put != NULL)
2036 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2039 if (array_check (get, 2) == FAILURE)
2042 if (rank_check (get, 2, 1) == FAILURE)
2045 if (type_check (get, 2, BT_INTEGER) == FAILURE)
2048 if (variable_check (get, 2) == FAILURE)
2051 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2059 gfc_check_second_sub (gfc_expr * time)
2061 if (scalar_check (time, 0) == FAILURE)
2064 if (type_check (time, 0, BT_REAL) == FAILURE)
2067 if (kind_value_check(time, 0, 4) == FAILURE)
2074 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2075 count, count_rate, and count_max are all optional arguments */
2078 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2079 gfc_expr * count_max)
2083 if (scalar_check (count, 0) == FAILURE)
2086 if (type_check (count, 0, BT_INTEGER) == FAILURE)
2089 if (variable_check (count, 0) == FAILURE)
2093 if (count_rate != NULL)
2095 if (scalar_check (count_rate, 1) == FAILURE)
2098 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2101 if (variable_check (count_rate, 1) == FAILURE)
2105 && same_type_check (count, 0, count_rate, 1) == FAILURE)
2110 if (count_max != NULL)
2112 if (scalar_check (count_max, 2) == FAILURE)
2115 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2118 if (variable_check (count_max, 2) == FAILURE)
2122 && same_type_check (count, 0, count_max, 2) == FAILURE)
2125 if (count_rate != NULL
2126 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2134 gfc_check_irand (gfc_expr * x)
2139 if (scalar_check (x, 0) == FAILURE)
2142 if (type_check (x, 0, BT_INTEGER) == FAILURE)
2145 if (kind_value_check(x, 0, 4) == FAILURE)
2152 gfc_check_rand (gfc_expr * x)
2157 if (scalar_check (x, 0) == FAILURE)
2160 if (type_check (x, 0, BT_INTEGER) == FAILURE)
2163 if (kind_value_check(x, 0, 4) == FAILURE)
2170 gfc_check_srand (gfc_expr * x)
2172 if (scalar_check (x, 0) == FAILURE)
2175 if (type_check (x, 0, BT_INTEGER) == FAILURE)
2178 if (kind_value_check(x, 0, 4) == FAILURE)
2185 gfc_check_etime (gfc_expr * x)
2187 if (array_check (x, 0) == FAILURE)
2190 if (rank_check (x, 0, 1) == FAILURE)
2193 if (variable_check (x, 0) == FAILURE)
2196 if (type_check (x, 0, BT_REAL) == FAILURE)
2199 if (kind_value_check(x, 0, 4) == FAILURE)
2206 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2208 if (array_check (values, 0) == FAILURE)
2211 if (rank_check (values, 0, 1) == FAILURE)
2214 if (variable_check (values, 0) == FAILURE)
2217 if (type_check (values, 0, BT_REAL) == FAILURE)
2220 if (kind_value_check(values, 0, 4) == FAILURE)
2223 if (scalar_check (time, 1) == FAILURE)
2226 if (type_check (time, 1, BT_REAL) == FAILURE)
2229 if (kind_value_check(time, 1, 4) == FAILURE)
2237 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2239 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2245 if (scalar_check (status, 1) == FAILURE)
2248 if (type_check (status, 1, BT_INTEGER) == FAILURE)
2256 gfc_check_exit (gfc_expr * status)
2261 if (type_check (status, 0, BT_INTEGER) == FAILURE)
2264 if (scalar_check (status, 0) == FAILURE)
2272 gfc_check_flush (gfc_expr * unit)
2277 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2280 if (scalar_check (unit, 0) == FAILURE)
2288 gfc_check_umask (gfc_expr * mask)
2290 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2293 if (scalar_check (mask, 0) == FAILURE)
2301 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2303 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2306 if (scalar_check (mask, 0) == FAILURE)
2312 if (scalar_check (old, 1) == FAILURE)
2315 if (type_check (old, 1, BT_INTEGER) == FAILURE)
2323 gfc_check_unlink (gfc_expr * name)
2325 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2333 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2335 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2341 if (scalar_check (status, 1) == FAILURE)
2344 if (type_check (status, 1, BT_INTEGER) == FAILURE)
2352 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2354 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2357 if (scalar_check (status, 1) == FAILURE)
2360 if (type_check (status, 1, BT_INTEGER) == FAILURE)
2363 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)