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_chdir (gfc_expr
* dir
)
580 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
588 gfc_check_chdir_sub (gfc_expr
* dir
, gfc_expr
* status
)
590 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
596 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
599 if (scalar_check (status
, 1) == FAILURE
)
607 gfc_check_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
609 if (numeric_check (x
, 0) == FAILURE
)
614 if (numeric_check (y
, 1) == FAILURE
)
617 if (x
->ts
.type
== BT_COMPLEX
)
619 must_be (y
, 1, "not be present if 'x' is COMPLEX");
624 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
632 gfc_check_count (gfc_expr
* mask
, gfc_expr
* dim
)
634 if (logical_array_check (mask
, 0) == FAILURE
)
636 if (dim_check (dim
, 1, 1) == FAILURE
)
644 gfc_check_cshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* dim
)
646 if (array_check (array
, 0) == FAILURE
)
649 if (array
->rank
== 1)
651 if (scalar_check (shift
, 1) == FAILURE
)
656 /* TODO: more requirements on shift parameter. */
659 if (dim_check (dim
, 2, 1) == FAILURE
)
667 gfc_check_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
669 if (numeric_check (x
, 0) == FAILURE
)
674 if (numeric_check (y
, 1) == FAILURE
)
677 if (x
->ts
.type
== BT_COMPLEX
)
679 must_be (y
, 1, "not be present if 'x' is COMPLEX");
689 gfc_check_dble (gfc_expr
* x
)
691 if (numeric_check (x
, 0) == FAILURE
)
699 gfc_check_digits (gfc_expr
* x
)
701 if (int_or_real_check (x
, 0) == FAILURE
)
709 gfc_check_dot_product (gfc_expr
* vector_a
, gfc_expr
* vector_b
)
711 switch (vector_a
->ts
.type
)
714 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
721 if (numeric_check (vector_b
, 1) == FAILURE
)
726 must_be (vector_a
, 0, "numeric or LOGICAL");
730 if (rank_check (vector_a
, 0, 1) == FAILURE
)
733 if (rank_check (vector_b
, 1, 1) == FAILURE
)
741 gfc_check_eoshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* boundary
,
744 if (array_check (array
, 0) == FAILURE
)
747 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
750 if (array
->rank
== 1)
752 if (scalar_check (shift
, 2) == FAILURE
)
757 /* TODO: more weird restrictions on shift. */
760 if (boundary
!= NULL
)
762 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
765 /* TODO: more restrictions on boundary. */
768 if (dim_check (dim
, 1, 1) == FAILURE
)
775 /* A single complex argument. */
778 gfc_check_fn_c (gfc_expr
* a
)
780 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
787 /* A single real argument. */
790 gfc_check_fn_r (gfc_expr
* a
)
792 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
799 /* A single real or complex argument. */
802 gfc_check_fn_rc (gfc_expr
* a
)
804 if (real_or_complex_check (a
, 0) == FAILURE
)
812 gfc_check_fnum (gfc_expr
* unit
)
814 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
817 if (scalar_check (unit
, 0) == FAILURE
)
824 /* This is used for the g77 one-argument Bessel functions, and the
828 gfc_check_g77_math1 (gfc_expr
* x
)
830 if (scalar_check (x
, 0) == FAILURE
)
833 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
841 gfc_check_huge (gfc_expr
* x
)
843 if (int_or_real_check (x
, 0) == FAILURE
)
850 /* Check that the single argument is an integer. */
853 gfc_check_i (gfc_expr
* i
)
855 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
863 gfc_check_iand (gfc_expr
* i
, gfc_expr
* j
)
865 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
868 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
871 if (i
->ts
.kind
!= j
->ts
.kind
)
873 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
874 &i
->where
) == FAILURE
)
883 gfc_check_ibclr (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_ibits (gfc_expr
* i
, gfc_expr
* pos
, gfc_expr
* len
)
898 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
901 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
904 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
912 gfc_check_ibset (gfc_expr
* i
, gfc_expr
* pos
)
914 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
917 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
925 gfc_check_ichar_iachar (gfc_expr
* c
)
929 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
932 /* Check that the argument is length one. Non-constant lengths
933 can't be checked here, so assume thay are ok. */
934 if (c
->ts
.cl
&& c
->ts
.cl
->length
)
936 /* If we already have a length for this expression then use it. */
937 if (c
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
939 i
= mpz_get_si (c
->ts
.cl
->length
->value
.integer
);
941 else if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
947 /* Substring references don't have the charlength set. */
949 while (ref
&& ref
->type
!= REF_SUBSTRING
)
952 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
957 start
= ref
->u
.ss
.start
;
961 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
962 || start
->expr_type
!= EXPR_CONSTANT
)
965 i
= mpz_get_si (end
->value
.integer
) + 1
966 - mpz_get_si (start
->value
.integer
);
973 gfc_error ("Argument of %s at %L must be of length one",
974 gfc_current_intrinsic
, &c
->where
);
983 gfc_check_idnint (gfc_expr
* a
)
985 if (double_check (a
, 0) == FAILURE
)
993 gfc_check_ieor (gfc_expr
* i
, gfc_expr
* j
)
995 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
998 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1001 if (i
->ts
.kind
!= j
->ts
.kind
)
1003 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1004 &i
->where
) == FAILURE
)
1013 gfc_check_index (gfc_expr
* string
, gfc_expr
* substring
, gfc_expr
* back
)
1015 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1016 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1020 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1023 if (string
->ts
.kind
!= substring
->ts
.kind
)
1025 must_be (substring
, 1, "the same kind as 'string'");
1034 gfc_check_int (gfc_expr
* x
, gfc_expr
* kind
)
1036 if (numeric_check (x
, 0) == FAILURE
)
1041 if (type_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1044 if (scalar_check (kind
, 1) == FAILURE
)
1053 gfc_check_ior (gfc_expr
* i
, gfc_expr
* j
)
1055 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1058 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1061 if (i
->ts
.kind
!= j
->ts
.kind
)
1063 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1064 &i
->where
) == FAILURE
)
1073 gfc_check_ishft (gfc_expr
* i
, gfc_expr
* shift
)
1075 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1076 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1084 gfc_check_ishftc (gfc_expr
* i
, gfc_expr
* shift
, gfc_expr
* size
)
1086 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1087 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1090 if (size
!= NULL
&& type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1098 gfc_check_kill (gfc_expr
* pid
, gfc_expr
* sig
)
1100 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1103 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1111 gfc_check_kill_sub (gfc_expr
* pid
, gfc_expr
* sig
, gfc_expr
* status
)
1113 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1116 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1122 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1125 if (scalar_check (status
, 2) == FAILURE
)
1133 gfc_check_kind (gfc_expr
* x
)
1135 if (x
->ts
.type
== BT_DERIVED
)
1137 must_be (x
, 0, "a non-derived type");
1146 gfc_check_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1148 if (array_check (array
, 0) == FAILURE
)
1153 if (dim_check (dim
, 1, 1) == FAILURE
)
1156 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
1164 gfc_check_link (gfc_expr
* path1
, gfc_expr
* path2
)
1166 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1169 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1177 gfc_check_link_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1179 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1182 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1188 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1191 if (scalar_check (status
, 2) == FAILURE
)
1199 gfc_check_symlnk (gfc_expr
* path1
, gfc_expr
* path2
)
1201 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1204 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1212 gfc_check_symlnk_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1214 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1217 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1223 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1226 if (scalar_check (status
, 2) == FAILURE
)
1234 gfc_check_logical (gfc_expr
* a
, gfc_expr
* kind
)
1236 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
1238 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
1245 /* Min/max family. */
1248 min_max_args (gfc_actual_arglist
* arg
)
1250 if (arg
== NULL
|| arg
->next
== NULL
)
1252 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1253 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1262 check_rest (bt type
, int kind
, gfc_actual_arglist
* arg
)
1267 if (min_max_args (arg
) == FAILURE
)
1272 for (; arg
; arg
= arg
->next
, n
++)
1275 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
1277 if (x
->ts
.type
== type
)
1279 if (gfc_notify_std (GFC_STD_GNU
,
1280 "Extension: Different type kinds at %L", &x
->where
)
1286 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1287 n
, gfc_current_intrinsic
, &x
->where
,
1288 gfc_basic_typename (type
), kind
);
1299 gfc_check_min_max (gfc_actual_arglist
* arg
)
1303 if (min_max_args (arg
) == FAILURE
)
1308 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
1311 ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1312 gfc_current_intrinsic
, &x
->where
);
1316 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
1321 gfc_check_min_max_integer (gfc_actual_arglist
* arg
)
1323 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
1328 gfc_check_min_max_real (gfc_actual_arglist
* arg
)
1330 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
1335 gfc_check_min_max_double (gfc_actual_arglist
* arg
)
1337 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
1340 /* End of min/max family. */
1344 gfc_check_matmul (gfc_expr
* matrix_a
, gfc_expr
* matrix_b
)
1346 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
1348 must_be (matrix_a
, 0, "numeric or LOGICAL");
1352 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
1354 must_be (matrix_b
, 0, "numeric or LOGICAL");
1358 switch (matrix_a
->rank
)
1361 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
1366 if (matrix_b
->rank
== 2)
1368 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
1373 must_be (matrix_a
, 0, "of rank 1 or 2");
1381 /* Whoever came up with this interface was probably on something.
1382 The possibilities for the occupation of the second and third
1389 NULL MASK minloc(array, mask=m)
1392 I.e. in the case of minloc(array,mask), mask will be in the second
1393 position of the argument list and we'll have to fix that up. */
1396 gfc_check_minloc_maxloc (gfc_actual_arglist
* ap
)
1398 gfc_expr
*a
, *m
, *d
;
1401 if (int_or_real_check (a
, 0) == FAILURE
1402 || array_check (a
, 0) == FAILURE
)
1406 m
= ap
->next
->next
->expr
;
1408 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1409 && ap
->next
->name
== NULL
)
1414 ap
->next
->expr
= NULL
;
1415 ap
->next
->next
->expr
= m
;
1419 && (scalar_check (d
, 1) == FAILURE
1420 || type_check (d
, 1, BT_INTEGER
) == FAILURE
))
1423 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1430 /* Similar to minloc/maxloc, the argument list might need to be
1431 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1432 difference is that MINLOC/MAXLOC take an additional KIND argument.
1433 The possibilities are:
1439 NULL MASK minval(array, mask=m)
1442 I.e. in the case of minval(array,mask), mask will be in the second
1443 position of the argument list and we'll have to fix that up. */
1446 check_reduction (gfc_actual_arglist
* ap
)
1451 m
= ap
->next
->next
->expr
;
1453 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1454 && ap
->next
->name
== NULL
)
1459 ap
->next
->expr
= NULL
;
1460 ap
->next
->next
->expr
= m
;
1464 && (scalar_check (d
, 1) == FAILURE
1465 || type_check (d
, 1, BT_INTEGER
) == FAILURE
))
1468 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1476 gfc_check_minval_maxval (gfc_actual_arglist
* ap
)
1478 if (int_or_real_check (ap
->expr
, 0) == FAILURE
1479 || array_check (ap
->expr
, 0) == FAILURE
)
1482 return check_reduction (ap
);
1487 gfc_check_product_sum (gfc_actual_arglist
* ap
)
1489 if (numeric_check (ap
->expr
, 0) == FAILURE
1490 || array_check (ap
->expr
, 0) == FAILURE
)
1493 return check_reduction (ap
);
1498 gfc_check_merge (gfc_expr
* tsource
, gfc_expr
* fsource
, gfc_expr
* mask
)
1500 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
1503 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
1511 gfc_check_nearest (gfc_expr
* x
, gfc_expr
* s
)
1513 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1516 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
1524 gfc_check_null (gfc_expr
* mold
)
1526 symbol_attribute attr
;
1531 if (variable_check (mold
, 0) == FAILURE
)
1534 attr
= gfc_variable_attr (mold
, NULL
);
1538 must_be (mold
, 0, "a POINTER");
1547 gfc_check_pack (gfc_expr
* array
, gfc_expr
* mask
, gfc_expr
* vector
)
1549 if (array_check (array
, 0) == FAILURE
)
1552 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
1555 if (mask
->rank
!= 0 && mask
->rank
!= array
->rank
)
1557 must_be (array
, 0, "conformable with 'mask' argument");
1563 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
1566 if (rank_check (vector
, 2, 1) == FAILURE
)
1569 /* TODO: More constraints here. */
1577 gfc_check_precision (gfc_expr
* x
)
1579 if (x
->ts
.type
!= BT_REAL
&& x
->ts
.type
!= BT_COMPLEX
)
1581 must_be (x
, 0, "of type REAL or COMPLEX");
1590 gfc_check_present (gfc_expr
* a
)
1594 if (variable_check (a
, 0) == FAILURE
)
1597 sym
= a
->symtree
->n
.sym
;
1598 if (!sym
->attr
.dummy
)
1600 must_be (a
, 0, "a dummy variable");
1604 if (!sym
->attr
.optional
)
1606 must_be (a
, 0, "an OPTIONAL dummy variable");
1615 gfc_check_radix (gfc_expr
* x
)
1617 if (int_or_real_check (x
, 0) == FAILURE
)
1625 gfc_check_range (gfc_expr
* x
)
1627 if (numeric_check (x
, 0) == FAILURE
)
1634 /* real, float, sngl. */
1636 gfc_check_real (gfc_expr
* a
, gfc_expr
* kind
)
1638 if (numeric_check (a
, 0) == FAILURE
)
1641 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
1649 gfc_check_rename (gfc_expr
* path1
, gfc_expr
* path2
)
1651 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1654 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1662 gfc_check_rename_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1664 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1667 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1673 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1676 if (scalar_check (status
, 2) == FAILURE
)
1684 gfc_check_repeat (gfc_expr
* x
, gfc_expr
* y
)
1686 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1689 if (scalar_check (x
, 0) == FAILURE
)
1692 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
1695 if (scalar_check (y
, 1) == FAILURE
)
1703 gfc_check_reshape (gfc_expr
* source
, gfc_expr
* shape
,
1704 gfc_expr
* pad
, gfc_expr
* order
)
1709 if (array_check (source
, 0) == FAILURE
)
1712 if (rank_check (shape
, 1, 1) == FAILURE
)
1715 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
1718 if (gfc_array_size (shape
, &size
) != SUCCESS
)
1720 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1721 "array of constant size", &shape
->where
);
1725 m
= mpz_cmp_ui (size
, GFC_MAX_DIMENSIONS
);
1731 ("'shape' argument of 'reshape' intrinsic at %L has more than "
1732 stringize (GFC_MAX_DIMENSIONS
) " elements", &shape
->where
);
1738 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
1740 if (array_check (pad
, 2) == FAILURE
)
1744 if (order
!= NULL
&& array_check (order
, 3) == FAILURE
)
1752 gfc_check_scale (gfc_expr
* x
, gfc_expr
* i
)
1754 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1757 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
1765 gfc_check_scan (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1767 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1770 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
1773 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
1776 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1784 gfc_check_selected_int_kind (gfc_expr
* r
)
1787 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
1790 if (scalar_check (r
, 0) == FAILURE
)
1798 gfc_check_selected_real_kind (gfc_expr
* p
, gfc_expr
* r
)
1800 if (p
== NULL
&& r
== NULL
)
1802 gfc_error ("Missing arguments to %s intrinsic at %L",
1803 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1808 if (p
!= NULL
&& type_check (p
, 0, BT_INTEGER
) == FAILURE
)
1811 if (r
!= NULL
&& type_check (r
, 1, BT_INTEGER
) == FAILURE
)
1819 gfc_check_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
1821 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1824 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
1832 gfc_check_shape (gfc_expr
* source
)
1836 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
1839 ar
= gfc_find_array_ref (source
);
1841 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
)
1843 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1844 "an assumed size array", &source
->where
);
1853 gfc_check_sign (gfc_expr
* a
, gfc_expr
* b
)
1855 if (int_or_real_check (a
, 0) == FAILURE
)
1858 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
1866 gfc_check_size (gfc_expr
* array
, gfc_expr
* dim
)
1868 if (array_check (array
, 0) == FAILURE
)
1873 if (type_check (dim
, 1, BT_INTEGER
) == FAILURE
)
1876 if (kind_value_check (dim
, 1, gfc_default_integer_kind
) == FAILURE
)
1879 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
1888 gfc_check_sleep_sub (gfc_expr
* seconds
)
1890 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
1893 if (scalar_check (seconds
, 0) == FAILURE
)
1901 gfc_check_spread (gfc_expr
* source
, gfc_expr
* dim
, gfc_expr
* ncopies
)
1903 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
1905 must_be (source
, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS
));
1909 if (dim_check (dim
, 1, 0) == FAILURE
)
1912 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
1915 if (scalar_check (ncopies
, 2) == FAILURE
)
1923 gfc_check_fstat (gfc_expr
* unit
, gfc_expr
* array
)
1925 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1928 if (scalar_check (unit
, 0) == FAILURE
)
1931 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
1932 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
1935 if (array_check (array
, 1) == FAILURE
)
1943 gfc_check_fstat_sub (gfc_expr
* unit
, gfc_expr
* array
, gfc_expr
* status
)
1945 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1948 if (scalar_check (unit
, 0) == FAILURE
)
1951 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
1952 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
1955 if (array_check (array
, 1) == FAILURE
)
1961 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
1962 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
1965 if (scalar_check (status
, 2) == FAILURE
)
1973 gfc_check_stat (gfc_expr
* name
, gfc_expr
* array
)
1975 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
1978 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
1979 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
1982 if (array_check (array
, 1) == FAILURE
)
1990 gfc_check_stat_sub (gfc_expr
* name
, gfc_expr
* array
, gfc_expr
* status
)
1992 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
1995 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
1996 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
1999 if (array_check (array
, 1) == FAILURE
)
2005 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2006 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2009 if (scalar_check (status
, 2) == FAILURE
)
2017 gfc_check_transfer (gfc_expr
* source ATTRIBUTE_UNUSED
,
2018 gfc_expr
* mold ATTRIBUTE_UNUSED
,
2023 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
2026 if (scalar_check (size
, 2) == FAILURE
)
2029 if (nonoptional_check (size
, 2) == FAILURE
)
2038 gfc_check_transpose (gfc_expr
* matrix
)
2040 if (rank_check (matrix
, 0, 2) == FAILURE
)
2048 gfc_check_ubound (gfc_expr
* array
, gfc_expr
* dim
)
2050 if (array_check (array
, 0) == FAILURE
)
2055 if (dim_check (dim
, 1, 1) == FAILURE
)
2058 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2067 gfc_check_unpack (gfc_expr
* vector
, gfc_expr
* mask
, gfc_expr
* field
)
2069 if (rank_check (vector
, 0, 1) == FAILURE
)
2072 if (array_check (mask
, 1) == FAILURE
)
2075 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2078 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
2086 gfc_check_verify (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
2088 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2091 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2094 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2102 gfc_check_trim (gfc_expr
* x
)
2104 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2107 if (scalar_check (x
, 0) == FAILURE
)
2114 /* Common check function for the half a dozen intrinsics that have a
2115 single real argument. */
2118 gfc_check_x (gfc_expr
* x
)
2120 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2127 /************* Check functions for intrinsic subroutines *************/
2130 gfc_check_cpu_time (gfc_expr
* time
)
2132 if (scalar_check (time
, 0) == FAILURE
)
2135 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2138 if (variable_check (time
, 0) == FAILURE
)
2146 gfc_check_date_and_time (gfc_expr
* date
, gfc_expr
* time
,
2147 gfc_expr
* zone
, gfc_expr
* values
)
2151 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
2153 if (scalar_check (date
, 0) == FAILURE
)
2155 if (variable_check (date
, 0) == FAILURE
)
2161 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
2163 if (scalar_check (time
, 1) == FAILURE
)
2165 if (variable_check (time
, 1) == FAILURE
)
2171 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
2173 if (scalar_check (zone
, 2) == FAILURE
)
2175 if (variable_check (zone
, 2) == FAILURE
)
2181 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
2183 if (array_check (values
, 3) == FAILURE
)
2185 if (rank_check (values
, 3, 1) == FAILURE
)
2187 if (variable_check (values
, 3) == FAILURE
)
2196 gfc_check_mvbits (gfc_expr
* from
, gfc_expr
* frompos
, gfc_expr
* len
,
2197 gfc_expr
* to
, gfc_expr
* topos
)
2199 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
2202 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
2205 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
2208 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
2211 if (variable_check (to
, 3) == FAILURE
)
2214 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
2222 gfc_check_random_number (gfc_expr
* harvest
)
2224 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
2227 if (variable_check (harvest
, 0) == FAILURE
)
2235 gfc_check_random_seed (gfc_expr
* size
, gfc_expr
* put
, gfc_expr
* get
)
2239 if (scalar_check (size
, 0) == FAILURE
)
2242 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
2245 if (variable_check (size
, 0) == FAILURE
)
2248 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
2256 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
2259 if (array_check (put
, 1) == FAILURE
)
2262 if (rank_check (put
, 1, 1) == FAILURE
)
2265 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
2268 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
2275 if (size
!= NULL
|| put
!= NULL
)
2276 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
2279 if (array_check (get
, 2) == FAILURE
)
2282 if (rank_check (get
, 2, 1) == FAILURE
)
2285 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
2288 if (variable_check (get
, 2) == FAILURE
)
2291 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
2299 gfc_check_second_sub (gfc_expr
* time
)
2301 if (scalar_check (time
, 0) == FAILURE
)
2304 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2307 if (kind_value_check(time
, 0, 4) == FAILURE
)
2314 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2315 count, count_rate, and count_max are all optional arguments */
2318 gfc_check_system_clock (gfc_expr
* count
, gfc_expr
* count_rate
,
2319 gfc_expr
* count_max
)
2323 if (scalar_check (count
, 0) == FAILURE
)
2326 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
2329 if (variable_check (count
, 0) == FAILURE
)
2333 if (count_rate
!= NULL
)
2335 if (scalar_check (count_rate
, 1) == FAILURE
)
2338 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
2341 if (variable_check (count_rate
, 1) == FAILURE
)
2345 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
2350 if (count_max
!= NULL
)
2352 if (scalar_check (count_max
, 2) == FAILURE
)
2355 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
2358 if (variable_check (count_max
, 2) == FAILURE
)
2362 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
2365 if (count_rate
!= NULL
2366 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
2374 gfc_check_irand (gfc_expr
* x
)
2379 if (scalar_check (x
, 0) == FAILURE
)
2382 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2385 if (kind_value_check(x
, 0, 4) == FAILURE
)
2392 gfc_check_rand (gfc_expr
* x
)
2397 if (scalar_check (x
, 0) == FAILURE
)
2400 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2403 if (kind_value_check(x
, 0, 4) == FAILURE
)
2410 gfc_check_srand (gfc_expr
* x
)
2412 if (scalar_check (x
, 0) == FAILURE
)
2415 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2418 if (kind_value_check(x
, 0, 4) == FAILURE
)
2425 gfc_check_etime (gfc_expr
* x
)
2427 if (array_check (x
, 0) == FAILURE
)
2430 if (rank_check (x
, 0, 1) == FAILURE
)
2433 if (variable_check (x
, 0) == FAILURE
)
2436 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2439 if (kind_value_check(x
, 0, 4) == FAILURE
)
2446 gfc_check_etime_sub (gfc_expr
* values
, gfc_expr
* time
)
2448 if (array_check (values
, 0) == FAILURE
)
2451 if (rank_check (values
, 0, 1) == FAILURE
)
2454 if (variable_check (values
, 0) == FAILURE
)
2457 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
2460 if (kind_value_check(values
, 0, 4) == FAILURE
)
2463 if (scalar_check (time
, 1) == FAILURE
)
2466 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
2469 if (kind_value_check(time
, 1, 4) == FAILURE
)
2477 gfc_check_gerror (gfc_expr
* msg
)
2479 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
2487 gfc_check_getcwd_sub (gfc_expr
* cwd
, gfc_expr
* status
)
2489 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
2495 if (scalar_check (status
, 1) == FAILURE
)
2498 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
2506 gfc_check_getlog (gfc_expr
* msg
)
2508 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
2516 gfc_check_exit (gfc_expr
* status
)
2521 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
2524 if (scalar_check (status
, 0) == FAILURE
)
2532 gfc_check_flush (gfc_expr
* unit
)
2537 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2540 if (scalar_check (unit
, 0) == FAILURE
)
2548 gfc_check_hostnm (gfc_expr
* name
)
2550 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2558 gfc_check_hostnm_sub (gfc_expr
* name
, gfc_expr
* status
)
2560 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2566 if (scalar_check (status
, 1) == FAILURE
)
2569 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
2577 gfc_check_perror (gfc_expr
* string
)
2579 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
2587 gfc_check_umask (gfc_expr
* mask
)
2589 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
2592 if (scalar_check (mask
, 0) == FAILURE
)
2600 gfc_check_umask_sub (gfc_expr
* mask
, gfc_expr
* old
)
2602 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
2605 if (scalar_check (mask
, 0) == FAILURE
)
2611 if (scalar_check (old
, 1) == FAILURE
)
2614 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
2622 gfc_check_unlink (gfc_expr
* name
)
2624 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2632 gfc_check_unlink_sub (gfc_expr
* name
, gfc_expr
* status
)
2634 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2640 if (scalar_check (status
, 1) == FAILURE
)
2643 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
2651 gfc_check_system_sub (gfc_expr
* cmd
, gfc_expr
* status
)
2653 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
2656 if (scalar_check (status
, 1) == FAILURE
)
2659 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
2662 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)