2 Copyright (C) 2002, 2003, 2004 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. */
37 #include "intrinsic.h"
40 /* The fundamental complaint function of this source file. This
41 function can be called in all kinds of ways. */
44 must_be (gfc_expr
* e
, int n
, const char *thing
)
47 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
48 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
,
53 /* Check the type of an expression. */
56 type_check (gfc_expr
* e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 must_be (e
, n
, gfc_basic_typename (type
));
68 /* Check that the expression is a numeric type. */
71 numeric_check (gfc_expr
* e
, int n
)
74 if (gfc_numeric_ts (&e
->ts
))
77 must_be (e
, n
, "a numeric type");
83 /* Check that an expression is integer or real. */
86 int_or_real_check (gfc_expr
* e
, int n
)
89 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
91 must_be (e
, n
, "INTEGER or REAL");
99 /* Check that the expression is an optional constant integer
100 and that it specifies a valid kind for that type. */
103 kind_check (gfc_expr
* k
, int n
, bt type
)
110 if (type_check (k
, n
, BT_INTEGER
) == FAILURE
)
113 if (k
->expr_type
!= EXPR_CONSTANT
)
115 must_be (k
, n
, "a constant");
119 if (gfc_extract_int (k
, &kind
) != NULL
120 || gfc_validate_kind (type
, kind
) == -1)
122 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
131 /* Make sure the expression is a double precision real. */
134 double_check (gfc_expr
* d
, int n
)
137 if (type_check (d
, n
, BT_REAL
) == FAILURE
)
140 if (d
->ts
.kind
!= gfc_default_double_kind ())
142 must_be (d
, n
, "double precision");
150 /* Make sure the expression is a logical array. */
153 logical_array_check (gfc_expr
* array
, int n
)
156 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
158 must_be (array
, n
, "a logical array");
166 /* Make sure an expression is an array. */
169 array_check (gfc_expr
* e
, int n
)
175 must_be (e
, n
, "an array");
181 /* Make sure an expression is a scalar. */
184 scalar_check (gfc_expr
* e
, int n
)
190 must_be (e
, n
, "a scalar");
196 /* Make sure two expression have the same type. */
199 same_type_check (gfc_expr
* e
, int n
, gfc_expr
* f
, int m
)
203 if (gfc_compare_types (&e
->ts
, &f
->ts
))
206 sprintf (message
, "the same type and kind as '%s'",
207 gfc_current_intrinsic_arg
[n
]);
209 must_be (f
, m
, message
);
215 /* Make sure that an expression has a certain (nonzero) rank. */
218 rank_check (gfc_expr
* e
, int n
, int rank
)
225 sprintf (message
, "of rank %d", rank
);
227 must_be (e
, n
, message
);
233 /* Make sure a variable expression is not an optional dummy argument. */
236 nonoptional_check (gfc_expr
* e
, int n
)
239 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
241 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
242 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
247 /* TODO: Recursive check on nonoptional variables? */
253 /* Check that an expression has a particular kind. */
256 kind_value_check (gfc_expr
* e
, int n
, int k
)
263 sprintf (message
, "of kind %d", k
);
265 must_be (e
, n
, message
);
270 /* Make sure an expression is a variable. */
273 variable_check (gfc_expr
* e
, int n
)
276 if ((e
->expr_type
== EXPR_VARIABLE
277 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
)
278 || (e
->expr_type
== EXPR_FUNCTION
279 && e
->symtree
->n
.sym
->result
== e
->symtree
->n
.sym
))
282 if (e
->expr_type
== EXPR_VARIABLE
283 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
285 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
286 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
291 must_be (e
, n
, "a variable");
297 /* Check the common DIM parameter for correctness. */
300 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
)
372 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
374 if (kind_check (kind
, 1, type
) == FAILURE
)
380 /* Check subroutine suitable for ceiling, floor and nint. */
383 gfc_check_a_ikind (gfc_expr
* a
, gfc_expr
* kind
)
386 return check_a_kind (a
, kind
, BT_INTEGER
);
389 /* Check subroutine suitable for aint, anint. */
392 gfc_check_a_xkind (gfc_expr
* a
, gfc_expr
* kind
)
395 return check_a_kind (a
, kind
, BT_REAL
);
399 gfc_check_abs (gfc_expr
* a
)
402 if (numeric_check (a
, 0) == FAILURE
)
410 gfc_check_all_any (gfc_expr
* mask
, gfc_expr
* dim
)
413 if (logical_array_check (mask
, 0) == FAILURE
)
416 if (dim_check (dim
, 1, 1) == FAILURE
)
424 gfc_check_allocated (gfc_expr
* array
)
427 if (variable_check (array
, 0) == FAILURE
)
430 if (array_check (array
, 0) == FAILURE
)
433 if (!array
->symtree
->n
.sym
->attr
.allocatable
)
435 must_be (array
, 0, "ALLOCATABLE");
443 /* Common check function where the first argument must be real or
444 integer and the second argument must be the same as the first. */
447 gfc_check_a_p (gfc_expr
* a
, gfc_expr
* p
)
450 if (int_or_real_check (a
, 0) == FAILURE
)
453 if (same_type_check (a
, 0, p
, 1) == FAILURE
)
461 gfc_check_associated (gfc_expr
* pointer
, gfc_expr
* target
)
463 symbol_attribute attr
;
467 if (variable_check (pointer
, 0) == FAILURE
)
470 attr
= gfc_variable_attr (pointer
, NULL
);
473 must_be (pointer
, 0, "a POINTER");
480 /* Target argument is optional. */
481 if (target
->expr_type
== EXPR_NULL
)
483 gfc_error ("NULL pointer at %L is not permitted as actual argument "
484 "of '%s' intrinsic function",
485 &target
->where
, gfc_current_intrinsic
);
489 attr
= gfc_variable_attr (target
, NULL
);
490 if (!attr
.pointer
&& !attr
.target
)
492 must_be (target
, 1, "a POINTER or a TARGET");
497 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
499 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
501 if (target
->rank
> 0)
503 for (i
= 0; i
< target
->rank
; i
++)
504 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
506 gfc_error ("Array section with a vector subscript at %L shall not "
507 "be the target of an pointer",
518 gfc_check_btest (gfc_expr
* i
, gfc_expr
* pos
)
521 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
523 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
531 gfc_check_char (gfc_expr
* i
, gfc_expr
* kind
)
534 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
536 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
544 gfc_check_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
547 if (numeric_check (x
, 0) == FAILURE
)
552 if (numeric_check (y
, 1) == FAILURE
)
555 if (x
->ts
.type
== BT_COMPLEX
)
557 must_be (y
, 1, "not be present if 'x' is COMPLEX");
562 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
570 gfc_check_count (gfc_expr
* mask
, gfc_expr
* dim
)
573 if (logical_array_check (mask
, 0) == FAILURE
)
575 if (dim_check (dim
, 1, 1) == FAILURE
)
583 gfc_check_cshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* dim
)
586 if (array_check (array
, 0) == FAILURE
)
589 if (array
->rank
== 1)
591 if (scalar_check (shift
, 1) == FAILURE
)
596 /* TODO: more requirements on shift parameter. */
599 if (dim_check (dim
, 2, 1) == FAILURE
)
607 gfc_check_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
610 if (numeric_check (x
, 0) == FAILURE
)
615 if (numeric_check (y
, 1) == FAILURE
)
618 if (x
->ts
.type
== BT_COMPLEX
)
620 must_be (y
, 1, "not be present if 'x' is COMPLEX");
630 gfc_check_dble (gfc_expr
* x
)
633 if (numeric_check (x
, 0) == FAILURE
)
641 gfc_check_digits (gfc_expr
* x
)
644 if (int_or_real_check (x
, 0) == FAILURE
)
652 gfc_check_dot_product (gfc_expr
* vector_a
, gfc_expr
* vector_b
)
655 switch (vector_a
->ts
.type
)
658 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
665 if (numeric_check (vector_b
, 1) == FAILURE
)
670 must_be (vector_a
, 0, "numeric or LOGICAL");
674 if (rank_check (vector_a
, 0, 1) == FAILURE
)
677 if (rank_check (vector_b
, 1, 1) == FAILURE
)
685 gfc_check_eoshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* boundary
,
689 if (array_check (array
, 0) == FAILURE
)
692 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
695 if (array
->rank
== 1)
697 if (scalar_check (shift
, 2) == FAILURE
)
702 /* TODO: more weird restrictions on shift. */
705 if (boundary
!= NULL
)
707 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
710 /* TODO: more restrictions on boundary. */
713 if (dim_check (dim
, 1, 1) == FAILURE
)
722 gfc_check_huge (gfc_expr
* x
)
725 if (int_or_real_check (x
, 0) == FAILURE
)
732 /* Check that the single argument is an integer. */
735 gfc_check_i (gfc_expr
* i
)
738 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
746 gfc_check_iand (gfc_expr
* i
, gfc_expr
* j
)
749 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
750 || type_check (j
, 1, BT_INTEGER
) == FAILURE
)
753 if (same_type_check (i
, 0, j
, 1) == FAILURE
)
761 gfc_check_ibclr (gfc_expr
* i
, gfc_expr
* pos
)
764 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
765 || type_check (pos
, 1, BT_INTEGER
) == FAILURE
766 || kind_value_check (pos
, 1, gfc_default_integer_kind ()) == FAILURE
)
774 gfc_check_ibits (gfc_expr
* i
, gfc_expr
* pos
, gfc_expr
* len
)
777 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
778 || type_check (pos
, 1, BT_INTEGER
) == FAILURE
779 || kind_value_check (pos
, 1, gfc_default_integer_kind ()) == FAILURE
780 || type_check (len
, 2, BT_INTEGER
) == FAILURE
)
788 gfc_check_ibset (gfc_expr
* i
, gfc_expr
* pos
)
791 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
792 || type_check (pos
, 1, BT_INTEGER
) == FAILURE
793 || kind_value_check (pos
, 1, gfc_default_integer_kind ()) == FAILURE
)
801 gfc_check_idnint (gfc_expr
* a
)
804 if (double_check (a
, 0) == FAILURE
)
812 gfc_check_ieor (gfc_expr
* i
, gfc_expr
* j
)
815 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
816 || type_check (j
, 1, BT_INTEGER
) == FAILURE
)
819 if (same_type_check (i
, 0, j
, 1) == FAILURE
)
827 gfc_check_index (gfc_expr
* string
, gfc_expr
* substring
, gfc_expr
* back
)
830 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
831 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
835 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
838 if (string
->ts
.kind
!= substring
->ts
.kind
)
840 must_be (substring
, 1, "the same kind as 'string'");
849 gfc_check_int (gfc_expr
* x
, gfc_expr
* kind
)
852 if (numeric_check (x
, 0) == FAILURE
853 || kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
861 gfc_check_ior (gfc_expr
* i
, gfc_expr
* j
)
864 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
865 || type_check (j
, 1, BT_INTEGER
) == FAILURE
)
868 if (same_type_check (i
, 0, j
, 1) == FAILURE
)
876 gfc_check_ishft (gfc_expr
* i
, gfc_expr
* shift
)
879 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
880 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
888 gfc_check_ishftc (gfc_expr
* i
, gfc_expr
* shift
, gfc_expr
* size
)
891 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
892 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
895 if (size
!= NULL
&& type_check (size
, 2, BT_INTEGER
) == FAILURE
)
903 gfc_check_kind (gfc_expr
* x
)
906 if (x
->ts
.type
== BT_DERIVED
)
908 must_be (x
, 0, "a non-derived type");
917 gfc_check_lbound (gfc_expr
* array
, gfc_expr
* dim
)
920 if (array_check (array
, 0) == FAILURE
)
925 if (dim_check (dim
, 1, 1) == FAILURE
)
928 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
936 gfc_check_logical (gfc_expr
* a
, gfc_expr
* kind
)
939 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
941 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
948 /* Min/max family. */
951 min_max_args (gfc_actual_arglist
* arg
)
954 if (arg
== NULL
|| arg
->next
== NULL
)
956 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
957 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
966 check_rest (bt type
, int kind
, gfc_actual_arglist
* arg
)
971 if (min_max_args (arg
) == FAILURE
)
976 for (; arg
; arg
= arg
->next
, n
++)
979 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
981 if (x
->ts
.type
== type
)
983 if (gfc_notify_std (GFC_STD_GNU
,
984 "Extension: Different type kinds at %L", &x
->where
)
990 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
991 n
, gfc_current_intrinsic
, &x
->where
,
992 gfc_basic_typename (type
), kind
);
1003 gfc_check_min_max (gfc_actual_arglist
* arg
)
1007 if (min_max_args (arg
) == FAILURE
)
1012 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
1015 ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1016 gfc_current_intrinsic
, &x
->where
);
1020 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
1025 gfc_check_min_max_integer (gfc_actual_arglist
* arg
)
1028 return check_rest (BT_INTEGER
, gfc_default_integer_kind (), arg
);
1033 gfc_check_min_max_real (gfc_actual_arglist
* arg
)
1036 return check_rest (BT_REAL
, gfc_default_real_kind (), arg
);
1041 gfc_check_min_max_double (gfc_actual_arglist
* arg
)
1044 return check_rest (BT_REAL
, gfc_default_double_kind (), arg
);
1047 /* End of min/max family. */
1051 gfc_check_matmul (gfc_expr
* matrix_a
, gfc_expr
* matrix_b
)
1054 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
1056 must_be (matrix_a
, 0, "numeric or LOGICAL");
1060 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
1062 must_be (matrix_b
, 0, "numeric or LOGICAL");
1066 switch (matrix_a
->rank
)
1069 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
1074 if (matrix_b
->rank
== 2)
1076 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
1081 must_be (matrix_a
, 0, "of rank 1 or 2");
1089 /* Whoever came up with this interface was probably on something.
1090 The possibilities for the occupation of the second and third
1097 NULL MASK minloc(array, mask=m)
1100 I.e. in the case of minloc(array,mask), mask will be in the second
1101 position of the argument list and we'll have to fix that up. */
1104 gfc_check_minloc_maxloc (gfc_actual_arglist
* ap
)
1106 gfc_expr
*a
, *m
, *d
;
1109 if (int_or_real_check (a
, 0) == FAILURE
1110 || array_check (a
, 0) == FAILURE
)
1114 m
= ap
->next
->next
->expr
;
1116 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1117 && ap
->next
->name
[0] == '\0')
1122 ap
->next
->expr
= NULL
;
1123 ap
->next
->next
->expr
= m
;
1127 && (scalar_check (d
, 1) == FAILURE
1128 || type_check (d
, 1, BT_INTEGER
) == FAILURE
))
1131 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1139 gfc_check_minval_maxval (gfc_expr
* array
, gfc_expr
* dim
, gfc_expr
* mask
)
1142 if (array_check (array
, 0) == FAILURE
)
1145 if (int_or_real_check (array
, 0) == FAILURE
)
1148 if (dim_check (dim
, 1, 1) == FAILURE
)
1151 if (mask
!= NULL
&& logical_array_check (mask
, 2) == FAILURE
)
1159 gfc_check_merge (gfc_expr
* tsource
, gfc_expr
* fsource
, gfc_expr
* mask
)
1162 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
1165 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
1173 gfc_check_nearest (gfc_expr
* x
, gfc_expr
* s
)
1176 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1179 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
1187 gfc_check_null (gfc_expr
* mold
)
1189 symbol_attribute attr
;
1194 if (variable_check (mold
, 0) == FAILURE
)
1197 attr
= gfc_variable_attr (mold
, NULL
);
1201 must_be (mold
, 0, "a POINTER");
1210 gfc_check_pack (gfc_expr
* array
, gfc_expr
* mask
, gfc_expr
* vector
)
1213 if (array_check (array
, 0) == FAILURE
)
1216 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
1219 if (mask
->rank
!= 0 && mask
->rank
!= array
->rank
)
1221 must_be (array
, 0, "conformable with 'mask' argument");
1227 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
1230 if (rank_check (vector
, 2, 1) == FAILURE
)
1233 /* TODO: More constraints here. */
1241 gfc_check_precision (gfc_expr
* x
)
1244 if (x
->ts
.type
!= BT_REAL
&& x
->ts
.type
!= BT_COMPLEX
)
1246 must_be (x
, 0, "of type REAL or COMPLEX");
1255 gfc_check_present (gfc_expr
* a
)
1259 if (variable_check (a
, 0) == FAILURE
)
1262 sym
= a
->symtree
->n
.sym
;
1263 if (!sym
->attr
.dummy
)
1265 must_be (a
, 0, "a dummy variable");
1269 if (!sym
->attr
.optional
)
1271 must_be (a
, 0, "an OPTIONAL dummy variable");
1280 gfc_check_product (gfc_expr
* array
, gfc_expr
* dim
, gfc_expr
* mask
)
1283 if (array_check (array
, 0) == FAILURE
)
1286 if (numeric_check (array
, 0) == FAILURE
)
1289 if (dim_check (dim
, 1, 1) == FAILURE
)
1292 if (mask
!= NULL
&& logical_array_check (mask
, 2) == FAILURE
)
1300 gfc_check_radix (gfc_expr
* x
)
1303 if (int_or_real_check (x
, 0) == FAILURE
)
1311 gfc_check_range (gfc_expr
* x
)
1314 if (numeric_check (x
, 0) == FAILURE
)
1321 /* real, float, sngl. */
1323 gfc_check_real (gfc_expr
* a
, gfc_expr
* kind
)
1326 if (numeric_check (a
, 0) == FAILURE
)
1329 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
1337 gfc_check_repeat (gfc_expr
* x
, gfc_expr
* y
)
1340 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1343 if (scalar_check (x
, 0) == FAILURE
)
1346 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
1349 if (scalar_check (y
, 1) == FAILURE
)
1357 gfc_check_reshape (gfc_expr
* source
, gfc_expr
* shape
,
1358 gfc_expr
* pad
, gfc_expr
* order
)
1363 if (array_check (source
, 0) == FAILURE
)
1366 if (rank_check (shape
, 1, 1) == FAILURE
)
1369 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
1372 if (gfc_array_size (shape
, &size
) != SUCCESS
)
1374 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1375 "array of constant size", &shape
->where
);
1379 m
= mpz_cmp_ui (size
, GFC_MAX_DIMENSIONS
);
1385 ("'shape' argument of 'reshape' intrinsic at %L has more than "
1386 stringize (GFC_MAX_DIMENSIONS
) " elements", &shape
->where
);
1392 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
1394 if (array_check (pad
, 2) == FAILURE
)
1398 if (order
!= NULL
&& array_check (order
, 3) == FAILURE
)
1406 gfc_check_scale (gfc_expr
* x
, gfc_expr
* i
)
1409 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1412 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
1420 gfc_check_scan (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1423 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1426 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
1429 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
1432 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1440 gfc_check_selected_real_kind (gfc_expr
* p
, gfc_expr
* r
)
1443 if (p
== NULL
&& r
== NULL
)
1445 gfc_error ("Missing arguments to %s intrinsic at %L",
1446 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1451 if (p
!= NULL
&& type_check (p
, 0, BT_INTEGER
) == FAILURE
)
1454 if (r
!= NULL
&& type_check (r
, 1, BT_INTEGER
) == FAILURE
)
1462 gfc_check_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
1465 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1468 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
1476 gfc_check_shape (gfc_expr
* source
)
1480 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
1483 ar
= gfc_find_array_ref (source
);
1485 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
)
1487 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1488 "an assumed size array", &source
->where
);
1497 gfc_check_size (gfc_expr
* array
, gfc_expr
* dim
)
1500 if (array_check (array
, 0) == FAILURE
)
1505 if (type_check (dim
, 1, BT_INTEGER
) == FAILURE
)
1508 if (kind_value_check (dim
, 1, gfc_default_integer_kind ()) == FAILURE
)
1511 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
1520 gfc_check_sign (gfc_expr
* a
, gfc_expr
* b
)
1523 if (int_or_real_check (a
, 0) == FAILURE
)
1526 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
1534 gfc_check_spread (gfc_expr
* source
, gfc_expr
* dim
, gfc_expr
* ncopies
)
1537 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
1539 must_be (source
, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS
));
1543 if (dim_check (dim
, 1, 0) == FAILURE
)
1546 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
1548 if (scalar_check (ncopies
, 2) == FAILURE
)
1556 gfc_check_sum (gfc_expr
* array
, gfc_expr
* dim
, gfc_expr
* mask
)
1559 if (array_check (array
, 0) == FAILURE
)
1562 if (numeric_check (array
, 0) == FAILURE
)
1565 if (dim_check (dim
, 1, 1) == FAILURE
)
1568 if (mask
!= NULL
&& logical_array_check (mask
, 2) == FAILURE
)
1576 gfc_check_transfer (gfc_expr
* source ATTRIBUTE_UNUSED
,
1577 gfc_expr
* mold ATTRIBUTE_UNUSED
,
1583 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1586 if (scalar_check (size
, 2) == FAILURE
)
1589 if (nonoptional_check (size
, 2) == FAILURE
)
1598 gfc_check_transpose (gfc_expr
* matrix
)
1601 if (rank_check (matrix
, 0, 2) == FAILURE
)
1609 gfc_check_ubound (gfc_expr
* array
, gfc_expr
* dim
)
1612 if (array_check (array
, 0) == FAILURE
)
1617 if (dim_check (dim
, 1, 1) == FAILURE
)
1620 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
1628 gfc_check_unpack (gfc_expr
* vector
, gfc_expr
* mask
, gfc_expr
* field
)
1631 if (rank_check (vector
, 0, 1) == FAILURE
)
1634 if (array_check (mask
, 1) == FAILURE
)
1637 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
1640 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
1648 gfc_check_verify (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1651 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1654 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1657 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
1665 gfc_check_trim (gfc_expr
* x
)
1667 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1670 if (scalar_check (x
, 0) == FAILURE
)
1677 /* Common check function for the half a dozen intrinsics that have a
1678 single real argument. */
1681 gfc_check_x (gfc_expr
* x
)
1684 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1691 /************* Check functions for intrinsic subroutines *************/
1694 gfc_check_cpu_time (gfc_expr
* time
)
1697 if (scalar_check (time
, 0) == FAILURE
)
1700 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
1703 if (variable_check (time
, 0) == FAILURE
)
1711 gfc_check_date_and_time (gfc_expr
* date
, gfc_expr
* time
,
1712 gfc_expr
* zone
, gfc_expr
* values
)
1717 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
1719 if (scalar_check (date
, 0) == FAILURE
)
1721 if (variable_check (date
, 0) == FAILURE
)
1727 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
1729 if (scalar_check (time
, 1) == FAILURE
)
1731 if (variable_check (time
, 1) == FAILURE
)
1737 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
1739 if (scalar_check (zone
, 2) == FAILURE
)
1741 if (variable_check (zone
, 2) == FAILURE
)
1747 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
1749 if (array_check (values
, 3) == FAILURE
)
1751 if (rank_check (values
, 3, 1) == FAILURE
)
1753 if (variable_check (values
, 3) == FAILURE
)
1762 gfc_check_mvbits (gfc_expr
* from
, gfc_expr
* frompos
, gfc_expr
* len
,
1763 gfc_expr
* to
, gfc_expr
* topos
)
1766 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
1769 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
1772 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1775 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
1778 if (variable_check (to
, 3) == FAILURE
)
1781 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
1789 gfc_check_random_number (gfc_expr
* harvest
)
1792 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
1795 if (variable_check (harvest
, 0) == FAILURE
)
1803 gfc_check_random_seed (gfc_expr
* size
, gfc_expr
* put
, gfc_expr
* get
)
1808 if (scalar_check (size
, 0) == FAILURE
)
1811 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
1814 if (variable_check (size
, 0) == FAILURE
)
1817 if (kind_value_check (size
, 0, gfc_default_integer_kind ()) == FAILURE
)
1825 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
1828 if (array_check (put
, 1) == FAILURE
)
1831 if (rank_check (put
, 1, 1) == FAILURE
)
1834 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
1837 if (kind_value_check (put
, 1, gfc_default_integer_kind ()) == FAILURE
)
1844 if (size
!= NULL
|| put
!= NULL
)
1845 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
1848 if (array_check (get
, 2) == FAILURE
)
1851 if (rank_check (get
, 2, 1) == FAILURE
)
1854 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
1857 if (variable_check (get
, 2) == FAILURE
)
1860 if (kind_value_check (get
, 2, gfc_default_integer_kind ()) == FAILURE
)
1868 gfc_check_second_sub (gfc_expr
* time
)
1871 if (scalar_check (time
, 0) == FAILURE
)
1874 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
1877 if (kind_value_check(time
, 0, 4) == FAILURE
)
1884 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
1885 count, count_rate, and count_max are all optional arguments */
1888 gfc_check_system_clock (gfc_expr
* count
, gfc_expr
* count_rate
,
1889 gfc_expr
* count_max
)
1894 if (scalar_check (count
, 0) == FAILURE
)
1897 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
1900 if (variable_check (count
, 0) == FAILURE
)
1904 if (count_rate
!= NULL
)
1906 if (scalar_check (count_rate
, 1) == FAILURE
)
1909 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
1912 if (variable_check (count_rate
, 1) == FAILURE
)
1915 if (count
!= NULL
&& same_type_check(count
, 0, count_rate
, 1) == FAILURE
)
1920 if (count_max
!= NULL
)
1922 if (scalar_check (count_max
, 2) == FAILURE
)
1925 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
1928 if (variable_check (count_max
, 2) == FAILURE
)
1931 if (count
!= NULL
&& same_type_check(count
, 0, count_max
, 2) == FAILURE
)
1934 if (count_rate
!= NULL
1935 && same_type_check(count_rate
, 1, count_max
, 2) == FAILURE
)
1944 gfc_check_irand (gfc_expr
* x
)
1946 if (scalar_check (x
, 0) == FAILURE
)
1949 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
1952 if (kind_value_check(x
, 0, 4) == FAILURE
)
1959 gfc_check_rand (gfc_expr
* x
)
1961 if (scalar_check (x
, 0) == FAILURE
)
1964 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
1967 if (kind_value_check(x
, 0, 4) == FAILURE
)
1974 gfc_check_srand (gfc_expr
* x
)
1976 if (scalar_check (x
, 0) == FAILURE
)
1979 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
1982 if (kind_value_check(x
, 0, 4) == FAILURE
)
1989 gfc_check_etime (gfc_expr
* x
)
1991 if (array_check (x
, 0) == FAILURE
)
1994 if (rank_check (x
, 0, 1) == FAILURE
)
1997 if (variable_check (x
, 0) == FAILURE
)
2000 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2003 if (kind_value_check(x
, 0, 4) == FAILURE
)
2010 gfc_check_etime_sub (gfc_expr
* values
, gfc_expr
* time
)
2012 if (array_check (values
, 0) == FAILURE
)
2015 if (rank_check (values
, 0, 1) == FAILURE
)
2018 if (variable_check (values
, 0) == FAILURE
)
2021 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
2024 if (kind_value_check(values
, 0, 4) == FAILURE
)
2027 if (scalar_check (time
, 1) == FAILURE
)
2030 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
2033 if (kind_value_check(time
, 1, 4) == FAILURE
)