2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
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 /* Make sure an expression is a scalar. */
39 scalar_check (gfc_expr
*e
, int n
)
44 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
45 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
51 /* Check the type of an expression. */
54 type_check (gfc_expr
*e
, int n
, bt type
)
56 if (e
->ts
.type
== type
)
59 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
60 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
,
61 gfc_basic_typename (type
));
67 /* Check that the expression is a numeric type. */
70 numeric_check (gfc_expr
*e
, int n
)
72 if (gfc_numeric_ts (&e
->ts
))
75 /* If the expression has not got a type, check if its namespace can
76 offer a default type. */
77 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_VARIABLE
)
78 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
79 && gfc_set_default_type (e
->symtree
->n
.sym
, 0,
80 e
->symtree
->n
.sym
->ns
) == SUCCESS
81 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
83 e
->ts
= e
->symtree
->n
.sym
->ts
;
87 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
88 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
94 /* Check that an expression is integer or real. */
97 int_or_real_check (gfc_expr
*e
, int n
)
99 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
101 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
102 "or REAL", gfc_current_intrinsic_arg
[n
],
103 gfc_current_intrinsic
, &e
->where
);
111 /* Check that an expression is real or complex. */
114 real_or_complex_check (gfc_expr
*e
, int n
)
116 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
118 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
119 "or COMPLEX", gfc_current_intrinsic_arg
[n
],
120 gfc_current_intrinsic
, &e
->where
);
128 /* Check that the expression is an optional constant integer
129 and that it specifies a valid kind for that type. */
132 kind_check (gfc_expr
*k
, int n
, bt type
)
139 if (type_check (k
, n
, BT_INTEGER
) == FAILURE
)
142 if (scalar_check (k
, n
) == FAILURE
)
145 if (k
->expr_type
!= EXPR_CONSTANT
)
147 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
148 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
153 if (gfc_extract_int (k
, &kind
) != NULL
154 || gfc_validate_kind (type
, kind
, true) < 0)
156 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
165 /* Make sure the expression is a double precision real. */
168 double_check (gfc_expr
*d
, int n
)
170 if (type_check (d
, n
, BT_REAL
) == FAILURE
)
173 if (d
->ts
.kind
!= gfc_default_double_kind
)
175 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
176 "precision", gfc_current_intrinsic_arg
[n
],
177 gfc_current_intrinsic
, &d
->where
);
185 /* Make sure the expression is a logical array. */
188 logical_array_check (gfc_expr
*array
, int n
)
190 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
192 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
193 "array", gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
202 /* Make sure an expression is an array. */
205 array_check (gfc_expr
*e
, int n
)
210 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
211 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
217 /* Make sure two expressions have the same type. */
220 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
222 if (gfc_compare_types (&e
->ts
, &f
->ts
))
225 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
226 "and kind as '%s'", gfc_current_intrinsic_arg
[m
],
227 gfc_current_intrinsic
, &f
->where
, gfc_current_intrinsic_arg
[n
]);
233 /* Make sure that an expression has a certain (nonzero) rank. */
236 rank_check (gfc_expr
*e
, int n
, int rank
)
241 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
242 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
249 /* Make sure a variable expression is not an optional dummy argument. */
252 nonoptional_check (gfc_expr
*e
, int n
)
254 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
256 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
257 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
261 /* TODO: Recursive check on nonoptional variables? */
267 /* Check that an expression has a particular kind. */
270 kind_value_check (gfc_expr
*e
, int n
, int k
)
275 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
276 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
283 /* Make sure an expression is a variable. */
286 variable_check (gfc_expr
*e
, int n
)
288 if ((e
->expr_type
== EXPR_VARIABLE
289 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
)
290 || (e
->expr_type
== EXPR_FUNCTION
291 && e
->symtree
->n
.sym
->result
== e
->symtree
->n
.sym
))
294 if (e
->expr_type
== EXPR_VARIABLE
295 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
297 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
298 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
303 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
304 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
310 /* Check the common DIM parameter for correctness. */
313 dim_check (gfc_expr
*dim
, int n
, bool optional
)
320 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
321 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
325 if (type_check (dim
, n
, BT_INTEGER
) == FAILURE
)
328 if (scalar_check (dim
, n
) == FAILURE
)
331 if (!optional
&& nonoptional_check (dim
, n
) == FAILURE
)
338 /* If a DIM parameter is a constant, make sure that it is greater than
339 zero and less than or equal to the rank of the given array. If
340 allow_assumed is zero then dim must be less than the rank of the array
341 for assumed size arrays. */
344 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
349 if (dim
->expr_type
!= EXPR_CONSTANT
|| array
->expr_type
!= EXPR_VARIABLE
)
352 ar
= gfc_find_array_ref (array
);
354 if (ar
->as
->type
== AS_ASSUMED_SIZE
356 && ar
->type
!= AR_ELEMENT
357 && ar
->type
!= AR_SECTION
)
360 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
361 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
363 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
364 "dimension index", gfc_current_intrinsic
, &dim
->where
);
373 /* Compare the size of a along dimension ai with the size of b along
374 dimension bi, returning 0 if they are known not to be identical,
375 and 1 if they are identical, or if this cannot be determined. */
378 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
380 mpz_t a_size
, b_size
;
383 gcc_assert (a
->rank
> ai
);
384 gcc_assert (b
->rank
> bi
);
388 if (gfc_array_dimen_size (a
, ai
, &a_size
) == SUCCESS
)
390 if (gfc_array_dimen_size (b
, bi
, &b_size
) == SUCCESS
)
392 if (mpz_cmp (a_size
, b_size
) != 0)
403 /* Check whether two character expressions have the same length;
404 returns SUCCESS if they have or if the length cannot be determined. */
407 check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
412 if (a
->ts
.cl
&& a
->ts
.cl
->length
413 && a
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
414 len_a
= mpz_get_si (a
->ts
.cl
->length
->value
.integer
);
415 else if (a
->expr_type
== EXPR_CONSTANT
416 && (a
->ts
.cl
== NULL
|| a
->ts
.cl
->length
== NULL
))
417 len_a
= a
->value
.character
.length
;
421 if (b
->ts
.cl
&& b
->ts
.cl
->length
422 && b
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
423 len_b
= mpz_get_si (b
->ts
.cl
->length
->value
.integer
);
424 else if (b
->expr_type
== EXPR_CONSTANT
425 && (b
->ts
.cl
== NULL
|| b
->ts
.cl
->length
== NULL
))
426 len_b
= b
->value
.character
.length
;
433 gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
434 "at %L", len_a
, len_b
, name
, &a
->where
);
439 /***** Check functions *****/
441 /* Check subroutine suitable for intrinsics taking a real argument and
442 a kind argument for the result. */
445 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
447 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
449 if (kind_check (kind
, 1, type
) == FAILURE
)
456 /* Check subroutine suitable for ceiling, floor and nint. */
459 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
461 return check_a_kind (a
, kind
, BT_INTEGER
);
465 /* Check subroutine suitable for aint, anint. */
468 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
470 return check_a_kind (a
, kind
, BT_REAL
);
475 gfc_check_abs (gfc_expr
*a
)
477 if (numeric_check (a
, 0) == FAILURE
)
485 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
487 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
489 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
497 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
499 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
500 || scalar_check (name
, 0) == FAILURE
)
503 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
504 || scalar_check (mode
, 1) == FAILURE
)
512 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
514 if (logical_array_check (mask
, 0) == FAILURE
)
517 if (dim_check (dim
, 1, false) == FAILURE
)
525 gfc_check_allocated (gfc_expr
*array
)
527 symbol_attribute attr
;
529 if (variable_check (array
, 0) == FAILURE
)
532 attr
= gfc_variable_attr (array
, NULL
);
533 if (!attr
.allocatable
)
535 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
536 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
541 if (array_check (array
, 0) == FAILURE
)
548 /* Common check function where the first argument must be real or
549 integer and the second argument must be the same as the first. */
552 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
554 if (int_or_real_check (a
, 0) == FAILURE
)
557 if (a
->ts
.type
!= p
->ts
.type
)
559 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
560 "have the same type", gfc_current_intrinsic_arg
[0],
561 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
566 if (a
->ts
.kind
!= p
->ts
.kind
)
568 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
569 &p
->where
) == FAILURE
)
578 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
580 symbol_attribute attr
;
585 where
= &pointer
->where
;
587 if (pointer
->expr_type
== EXPR_VARIABLE
)
588 attr
= gfc_variable_attr (pointer
, NULL
);
589 else if (pointer
->expr_type
== EXPR_FUNCTION
)
590 attr
= pointer
->symtree
->n
.sym
->attr
;
591 else if (pointer
->expr_type
== EXPR_NULL
)
594 gcc_assert (0); /* Pointer must be a variable or a function. */
598 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
599 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
604 /* Target argument is optional. */
608 where
= &target
->where
;
609 if (target
->expr_type
== EXPR_NULL
)
612 if (target
->expr_type
== EXPR_VARIABLE
)
613 attr
= gfc_variable_attr (target
, NULL
);
614 else if (target
->expr_type
== EXPR_FUNCTION
)
615 attr
= target
->symtree
->n
.sym
->attr
;
618 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
619 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg
[1],
620 gfc_current_intrinsic
, &target
->where
);
624 if (!attr
.pointer
&& !attr
.target
)
626 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
627 "or a TARGET", gfc_current_intrinsic_arg
[1],
628 gfc_current_intrinsic
, &target
->where
);
633 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
635 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
637 if (target
->rank
> 0)
639 for (i
= 0; i
< target
->rank
; i
++)
640 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
642 gfc_error ("Array section with a vector subscript at %L shall not "
643 "be the target of a pointer",
653 gfc_error ("NULL pointer at %L is not permitted as actual argument "
654 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
661 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
663 if (type_check (y
, 0, BT_REAL
) == FAILURE
)
665 if (same_type_check (y
, 0, x
, 1) == FAILURE
)
672 /* BESJN and BESYN functions. */
675 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
677 if (type_check (n
, 0, BT_INTEGER
) == FAILURE
)
680 if (type_check (x
, 1, BT_REAL
) == FAILURE
)
688 gfc_check_btest (gfc_expr
*i
, gfc_expr
*pos
)
690 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
692 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
700 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
702 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
704 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
712 gfc_check_chdir (gfc_expr
*dir
)
714 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
722 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
724 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
730 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
733 if (scalar_check (status
, 1) == FAILURE
)
741 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
743 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
746 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
754 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
756 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
759 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
765 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
768 if (scalar_check (status
, 2) == FAILURE
)
776 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
778 if (numeric_check (x
, 0) == FAILURE
)
783 if (numeric_check (y
, 1) == FAILURE
)
786 if (x
->ts
.type
== BT_COMPLEX
)
788 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
789 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
790 gfc_current_intrinsic
, &y
->where
);
795 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
803 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
805 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
807 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
808 "or REAL", gfc_current_intrinsic_arg
[0],
809 gfc_current_intrinsic
, &x
->where
);
812 if (scalar_check (x
, 0) == FAILURE
)
815 if (y
->ts
.type
!= BT_INTEGER
&& y
->ts
.type
!= BT_REAL
)
817 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
818 "or REAL", gfc_current_intrinsic_arg
[1],
819 gfc_current_intrinsic
, &y
->where
);
822 if (scalar_check (y
, 1) == FAILURE
)
830 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
832 if (logical_array_check (mask
, 0) == FAILURE
)
834 if (dim_check (dim
, 1, false) == FAILURE
)
836 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
838 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
839 "with KIND argument at %L",
840 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
848 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
850 if (array_check (array
, 0) == FAILURE
)
853 if (array
->rank
== 1)
855 if (scalar_check (shift
, 1) == FAILURE
)
860 /* TODO: more requirements on shift parameter. */
863 /* FIXME (PR33317): Allow optional DIM=. */
864 if (dim_check (dim
, 2, false) == FAILURE
)
872 gfc_check_ctime (gfc_expr
*time
)
874 if (scalar_check (time
, 0) == FAILURE
)
877 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
885 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
887 if (numeric_check (x
, 0) == FAILURE
)
892 if (numeric_check (y
, 1) == FAILURE
)
895 if (x
->ts
.type
== BT_COMPLEX
)
897 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
898 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
899 gfc_current_intrinsic
, &y
->where
);
909 gfc_check_dble (gfc_expr
*x
)
911 if (numeric_check (x
, 0) == FAILURE
)
919 gfc_check_digits (gfc_expr
*x
)
921 if (int_or_real_check (x
, 0) == FAILURE
)
929 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
931 switch (vector_a
->ts
.type
)
934 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
941 if (numeric_check (vector_b
, 1) == FAILURE
)
946 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
947 "or LOGICAL", gfc_current_intrinsic_arg
[0],
948 gfc_current_intrinsic
, &vector_a
->where
);
952 if (rank_check (vector_a
, 0, 1) == FAILURE
)
955 if (rank_check (vector_b
, 1, 1) == FAILURE
)
958 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
960 gfc_error ("different shape for arguments '%s' and '%s' at %L for "
961 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0],
962 gfc_current_intrinsic_arg
[1], &vector_a
->where
);
971 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
974 if (array_check (array
, 0) == FAILURE
)
977 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
980 if (array
->rank
== 1)
982 if (scalar_check (shift
, 2) == FAILURE
)
987 /* TODO: more weird restrictions on shift. */
990 if (boundary
!= NULL
)
992 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
995 /* TODO: more restrictions on boundary. */
998 /* FIXME (PR33317): Allow optional DIM=. */
999 if (dim_check (dim
, 4, false) == FAILURE
)
1006 /* A single complex argument. */
1009 gfc_check_fn_c (gfc_expr
*a
)
1011 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
1018 /* A single real argument. */
1021 gfc_check_fn_r (gfc_expr
*a
)
1023 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
1030 /* A single real or complex argument. */
1033 gfc_check_fn_rc (gfc_expr
*a
)
1035 if (real_or_complex_check (a
, 0) == FAILURE
)
1043 gfc_check_fnum (gfc_expr
*unit
)
1045 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1048 if (scalar_check (unit
, 0) == FAILURE
)
1056 gfc_check_huge (gfc_expr
*x
)
1058 if (int_or_real_check (x
, 0) == FAILURE
)
1065 /* Check that the single argument is an integer. */
1068 gfc_check_i (gfc_expr
*i
)
1070 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1078 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1080 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1083 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1086 if (i
->ts
.kind
!= j
->ts
.kind
)
1088 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1089 &i
->where
) == FAILURE
)
1098 gfc_check_ibclr (gfc_expr
*i
, gfc_expr
*pos
)
1100 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1103 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1111 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1113 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1116 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1119 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1127 gfc_check_ibset (gfc_expr
*i
, gfc_expr
*pos
)
1129 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1132 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1140 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1144 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
1147 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1150 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1151 "with KIND argument at %L",
1152 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1155 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1161 /* Substring references don't have the charlength set. */
1163 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1166 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1170 /* Check that the argument is length one. Non-constant lengths
1171 can't be checked here, so assume they are ok. */
1172 if (c
->ts
.cl
&& c
->ts
.cl
->length
)
1174 /* If we already have a length for this expression then use it. */
1175 if (c
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1177 i
= mpz_get_si (c
->ts
.cl
->length
->value
.integer
);
1184 start
= ref
->u
.ss
.start
;
1185 end
= ref
->u
.ss
.end
;
1188 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1189 || start
->expr_type
!= EXPR_CONSTANT
)
1192 i
= mpz_get_si (end
->value
.integer
) + 1
1193 - mpz_get_si (start
->value
.integer
);
1201 gfc_error ("Argument of %s at %L must be of length one",
1202 gfc_current_intrinsic
, &c
->where
);
1211 gfc_check_idnint (gfc_expr
*a
)
1213 if (double_check (a
, 0) == FAILURE
)
1221 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
1223 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1226 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1229 if (i
->ts
.kind
!= j
->ts
.kind
)
1231 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1232 &i
->where
) == FAILURE
)
1241 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
1244 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1245 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1248 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1251 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
1253 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1254 "with KIND argument at %L",
1255 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1258 if (string
->ts
.kind
!= substring
->ts
.kind
)
1260 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1261 "kind as '%s'", gfc_current_intrinsic_arg
[1],
1262 gfc_current_intrinsic
, &substring
->where
,
1263 gfc_current_intrinsic_arg
[0]);
1272 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
1274 if (numeric_check (x
, 0) == FAILURE
)
1277 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1285 gfc_check_intconv (gfc_expr
*x
)
1287 if (numeric_check (x
, 0) == FAILURE
)
1295 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
1297 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1300 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1303 if (i
->ts
.kind
!= j
->ts
.kind
)
1305 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1306 &i
->where
) == FAILURE
)
1315 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
1317 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1318 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1326 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1328 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1329 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1332 if (size
!= NULL
&& type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1340 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
1342 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1345 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1353 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
1355 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1358 if (scalar_check (pid
, 0) == FAILURE
)
1361 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1364 if (scalar_check (sig
, 1) == FAILURE
)
1370 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1373 if (scalar_check (status
, 2) == FAILURE
)
1381 gfc_check_kind (gfc_expr
*x
)
1383 if (x
->ts
.type
== BT_DERIVED
)
1385 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1386 "non-derived type", gfc_current_intrinsic_arg
[0],
1387 gfc_current_intrinsic
, &x
->where
);
1396 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1398 if (array_check (array
, 0) == FAILURE
)
1403 if (dim_check (dim
, 1, false) == FAILURE
)
1406 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
1410 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
1412 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1413 "with KIND argument at %L",
1414 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1422 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
1424 if (type_check (s
, 0, BT_CHARACTER
) == FAILURE
)
1427 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1429 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1430 "with KIND argument at %L",
1431 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1439 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
1441 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1444 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1452 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
1454 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1457 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1463 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1466 if (scalar_check (status
, 2) == FAILURE
)
1474 gfc_check_loc (gfc_expr
*expr
)
1476 return variable_check (expr
, 0);
1481 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
1483 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1486 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1494 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
1496 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1499 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1505 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1508 if (scalar_check (status
, 2) == FAILURE
)
1516 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
1518 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
1520 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
1527 /* Min/max family. */
1530 min_max_args (gfc_actual_arglist
*arg
)
1532 if (arg
== NULL
|| arg
->next
== NULL
)
1534 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1535 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1544 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
1546 gfc_actual_arglist
*arg
, *tmp
;
1551 if (min_max_args (arglist
) == FAILURE
)
1554 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
1557 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
1559 if (x
->ts
.type
== type
)
1561 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type "
1562 "kinds at %L", &x
->where
) == FAILURE
)
1567 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1568 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
1569 gfc_basic_typename (type
), kind
);
1574 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
1577 snprintf (buffer
, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
1578 m
, n
, gfc_current_intrinsic
);
1579 if (gfc_check_conformance (buffer
, tmp
->expr
, x
) == FAILURE
)
1589 gfc_check_min_max (gfc_actual_arglist
*arg
)
1593 if (min_max_args (arg
) == FAILURE
)
1598 if (x
->ts
.type
== BT_CHARACTER
)
1600 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1601 "with CHARACTER argument at %L",
1602 gfc_current_intrinsic
, &x
->where
) == FAILURE
)
1605 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
1607 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1608 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
1612 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
1617 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
1619 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
1624 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
1626 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
1631 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
1633 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
1637 /* End of min/max family. */
1640 gfc_check_malloc (gfc_expr
*size
)
1642 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
1645 if (scalar_check (size
, 0) == FAILURE
)
1653 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
1655 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
1657 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1658 "or LOGICAL", gfc_current_intrinsic_arg
[0],
1659 gfc_current_intrinsic
, &matrix_a
->where
);
1663 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
1665 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1666 "or LOGICAL", gfc_current_intrinsic_arg
[1],
1667 gfc_current_intrinsic
, &matrix_b
->where
);
1671 switch (matrix_a
->rank
)
1674 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
1676 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1677 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
1679 gfc_error ("different shape on dimension 1 for arguments '%s' "
1680 "and '%s' at %L for intrinsic matmul",
1681 gfc_current_intrinsic_arg
[0],
1682 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1688 if (matrix_b
->rank
!= 2)
1690 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
1693 /* matrix_b has rank 1 or 2 here. Common check for the cases
1694 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1695 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1696 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
1698 gfc_error ("different shape on dimension 2 for argument '%s' and "
1699 "dimension 1 for argument '%s' at %L for intrinsic "
1700 "matmul", gfc_current_intrinsic_arg
[0],
1701 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1707 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1708 "1 or 2", gfc_current_intrinsic_arg
[0],
1709 gfc_current_intrinsic
, &matrix_a
->where
);
1717 /* Whoever came up with this interface was probably on something.
1718 The possibilities for the occupation of the second and third
1725 NULL MASK minloc(array, mask=m)
1728 I.e. in the case of minloc(array,mask), mask will be in the second
1729 position of the argument list and we'll have to fix that up. */
1732 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
1734 gfc_expr
*a
, *m
, *d
;
1737 if (int_or_real_check (a
, 0) == FAILURE
|| array_check (a
, 0) == FAILURE
)
1741 m
= ap
->next
->next
->expr
;
1743 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1744 && ap
->next
->name
== NULL
)
1748 ap
->next
->expr
= NULL
;
1749 ap
->next
->next
->expr
= m
;
1752 if (d
&& dim_check (d
, 1, false) == FAILURE
)
1755 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1758 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1764 snprintf (buffer
, 80, "arguments '%s' and '%s' for intrinsic %s",
1765 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1766 gfc_current_intrinsic
);
1767 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1775 /* Similar to minloc/maxloc, the argument list might need to be
1776 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1777 difference is that MINLOC/MAXLOC take an additional KIND argument.
1778 The possibilities are:
1784 NULL MASK minval(array, mask=m)
1787 I.e. in the case of minval(array,mask), mask will be in the second
1788 position of the argument list and we'll have to fix that up. */
1791 check_reduction (gfc_actual_arglist
*ap
)
1793 gfc_expr
*a
, *m
, *d
;
1797 m
= ap
->next
->next
->expr
;
1799 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1800 && ap
->next
->name
== NULL
)
1804 ap
->next
->expr
= NULL
;
1805 ap
->next
->next
->expr
= m
;
1808 if (d
&& dim_check (d
, 1, false) == FAILURE
)
1811 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1814 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1820 snprintf (buffer
, 80, "arguments '%s' and '%s' for intrinsic %s",
1821 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1822 gfc_current_intrinsic
);
1823 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1832 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
1834 if (int_or_real_check (ap
->expr
, 0) == FAILURE
1835 || array_check (ap
->expr
, 0) == FAILURE
)
1838 return check_reduction (ap
);
1843 gfc_check_product_sum (gfc_actual_arglist
*ap
)
1845 if (numeric_check (ap
->expr
, 0) == FAILURE
1846 || array_check (ap
->expr
, 0) == FAILURE
)
1849 return check_reduction (ap
);
1854 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
1856 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
1859 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
1862 if (tsource
->ts
.type
== BT_CHARACTER
)
1863 return check_same_strlen (tsource
, fsource
, "MERGE");
1870 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
1872 symbol_attribute attr
;
1874 if (variable_check (from
, 0) == FAILURE
)
1877 if (array_check (from
, 0) == FAILURE
)
1880 attr
= gfc_variable_attr (from
, NULL
);
1881 if (!attr
.allocatable
)
1883 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1884 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
1889 if (variable_check (to
, 0) == FAILURE
)
1892 if (array_check (to
, 0) == FAILURE
)
1895 attr
= gfc_variable_attr (to
, NULL
);
1896 if (!attr
.allocatable
)
1898 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1899 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
1904 if (same_type_check (from
, 0, to
, 1) == FAILURE
)
1907 if (to
->rank
!= from
->rank
)
1909 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1910 "have the same rank %d/%d", gfc_current_intrinsic_arg
[0],
1911 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
1912 &to
->where
, from
->rank
, to
->rank
);
1916 if (to
->ts
.kind
!= from
->ts
.kind
)
1918 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1919 "be of the same kind %d/%d", gfc_current_intrinsic_arg
[0],
1920 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
1921 &to
->where
, from
->ts
.kind
, to
->ts
.kind
);
1930 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
1932 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1935 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
1943 gfc_check_new_line (gfc_expr
*a
)
1945 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
1953 gfc_check_null (gfc_expr
*mold
)
1955 symbol_attribute attr
;
1960 if (variable_check (mold
, 0) == FAILURE
)
1963 attr
= gfc_variable_attr (mold
, NULL
);
1967 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1968 gfc_current_intrinsic_arg
[0],
1969 gfc_current_intrinsic
, &mold
->where
);
1978 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
1982 if (array_check (array
, 0) == FAILURE
)
1985 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
1988 snprintf (buffer
, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1989 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[1],
1990 gfc_current_intrinsic
);
1991 if (gfc_check_conformance (buffer
, array
, mask
) == FAILURE
)
1996 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
1999 if (rank_check (vector
, 2, 1) == FAILURE
)
2002 /* TODO: More constraints here. */
2010 gfc_check_precision (gfc_expr
*x
)
2012 if (x
->ts
.type
!= BT_REAL
&& x
->ts
.type
!= BT_COMPLEX
)
2014 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2015 "REAL or COMPLEX", gfc_current_intrinsic_arg
[0],
2016 gfc_current_intrinsic
, &x
->where
);
2025 gfc_check_present (gfc_expr
*a
)
2029 if (variable_check (a
, 0) == FAILURE
)
2032 sym
= a
->symtree
->n
.sym
;
2033 if (!sym
->attr
.dummy
)
2035 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2036 "dummy variable", gfc_current_intrinsic_arg
[0],
2037 gfc_current_intrinsic
, &a
->where
);
2041 if (!sym
->attr
.optional
)
2043 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2044 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg
[0],
2045 gfc_current_intrinsic
, &a
->where
);
2049 /* 13.14.82 PRESENT(A)
2051 Argument. A shall be the name of an optional dummy argument that is
2052 accessible in the subprogram in which the PRESENT function reference
2056 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
2057 && a
->ref
->u
.ar
.type
== AR_FULL
))
2059 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2060 "subobject of '%s'", gfc_current_intrinsic_arg
[0],
2061 gfc_current_intrinsic
, &a
->where
, sym
->name
);
2070 gfc_check_radix (gfc_expr
*x
)
2072 if (int_or_real_check (x
, 0) == FAILURE
)
2080 gfc_check_range (gfc_expr
*x
)
2082 if (numeric_check (x
, 0) == FAILURE
)
2089 /* real, float, sngl. */
2091 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
2093 if (numeric_check (a
, 0) == FAILURE
)
2096 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
2104 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
2106 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2109 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2117 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2119 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2122 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2128 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2131 if (scalar_check (status
, 2) == FAILURE
)
2139 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
2141 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2144 if (scalar_check (x
, 0) == FAILURE
)
2147 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
2150 if (scalar_check (y
, 1) == FAILURE
)
2158 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
2159 gfc_expr
*pad
, gfc_expr
*order
)
2165 if (array_check (source
, 0) == FAILURE
)
2168 if (rank_check (shape
, 1, 1) == FAILURE
)
2171 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
2174 if (gfc_array_size (shape
, &size
) != SUCCESS
)
2176 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2177 "array of constant size", &shape
->where
);
2181 m
= mpz_cmp_ui (size
, GFC_MAX_DIMENSIONS
);
2186 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2187 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
2193 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
2195 if (array_check (pad
, 2) == FAILURE
)
2199 if (order
!= NULL
&& array_check (order
, 3) == FAILURE
)
2202 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
2203 && gfc_is_constant_expr (shape
)
2204 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
2205 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
2207 /* Check the match in size between source and destination. */
2208 if (gfc_array_size (source
, &nelems
) == SUCCESS
)
2213 c
= shape
->value
.constructor
;
2214 mpz_init_set_ui (size
, 1);
2215 for (; c
; c
= c
->next
)
2216 mpz_mul (size
, size
, c
->expr
->value
.integer
);
2218 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
2224 gfc_error ("Without padding, there are not enough elements "
2225 "in the intrinsic RESHAPE source at %L to match "
2226 "the shape", &source
->where
);
2237 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
2239 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2242 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2250 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
2252 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2255 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
2258 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2261 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
2263 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2264 "with KIND argument at %L",
2265 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2268 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2276 gfc_check_secnds (gfc_expr
*r
)
2278 if (type_check (r
, 0, BT_REAL
) == FAILURE
)
2281 if (kind_value_check (r
, 0, 4) == FAILURE
)
2284 if (scalar_check (r
, 0) == FAILURE
)
2292 gfc_check_selected_int_kind (gfc_expr
*r
)
2294 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
2297 if (scalar_check (r
, 0) == FAILURE
)
2305 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
)
2307 if (p
== NULL
&& r
== NULL
)
2309 gfc_error ("Missing arguments to %s intrinsic at %L",
2310 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2315 if (p
!= NULL
&& type_check (p
, 0, BT_INTEGER
) == FAILURE
)
2318 if (r
!= NULL
&& type_check (r
, 1, BT_INTEGER
) == FAILURE
)
2326 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
2328 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2331 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2339 gfc_check_shape (gfc_expr
*source
)
2343 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
2346 ar
= gfc_find_array_ref (source
);
2348 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
)
2350 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2351 "an assumed size array", &source
->where
);
2360 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
2362 if (int_or_real_check (a
, 0) == FAILURE
)
2365 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
2373 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2375 if (array_check (array
, 0) == FAILURE
)
2380 if (dim_check (dim
, 1, true) == FAILURE
)
2383 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2387 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2389 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2390 "with KIND argument at %L",
2391 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2400 gfc_check_sizeof (gfc_expr
*arg
__attribute__((unused
)))
2407 gfc_check_sleep_sub (gfc_expr
*seconds
)
2409 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
2412 if (scalar_check (seconds
, 0) == FAILURE
)
2420 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
2422 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
2424 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2425 "than rank %d", gfc_current_intrinsic_arg
[0],
2426 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
2434 if (dim_check (dim
, 1, false) == FAILURE
)
2437 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
2440 if (scalar_check (ncopies
, 2) == FAILURE
)
2447 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2451 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
2453 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2456 if (scalar_check (unit
, 0) == FAILURE
)
2459 if (type_check (c
, 1, BT_CHARACTER
) == FAILURE
)
2465 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2466 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
2467 || scalar_check (status
, 2) == FAILURE
)
2475 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
2477 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
2482 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
2484 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
2490 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
2491 || kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
2492 || scalar_check (status
, 1) == FAILURE
)
2500 gfc_check_fgetput (gfc_expr
*c
)
2502 return gfc_check_fgetput_sub (c
, NULL
);
2507 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
2509 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2512 if (scalar_check (unit
, 0) == FAILURE
)
2515 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
2518 if (scalar_check (offset
, 1) == FAILURE
)
2521 if (type_check (whence
, 2, BT_INTEGER
) == FAILURE
)
2524 if (scalar_check (whence
, 2) == FAILURE
)
2530 if (type_check (status
, 3, BT_INTEGER
) == FAILURE
)
2533 if (kind_value_check (status
, 3, 4) == FAILURE
)
2536 if (scalar_check (status
, 3) == FAILURE
)
2545 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
2547 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2550 if (scalar_check (unit
, 0) == FAILURE
)
2553 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2554 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
2557 if (array_check (array
, 1) == FAILURE
)
2565 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
2567 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2570 if (scalar_check (unit
, 0) == FAILURE
)
2573 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2574 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2577 if (array_check (array
, 1) == FAILURE
)
2583 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2584 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
2587 if (scalar_check (status
, 2) == FAILURE
)
2595 gfc_check_ftell (gfc_expr
*unit
)
2597 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2600 if (scalar_check (unit
, 0) == FAILURE
)
2608 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
2610 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2613 if (scalar_check (unit
, 0) == FAILURE
)
2616 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
2619 if (scalar_check (offset
, 1) == FAILURE
)
2627 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
2629 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2632 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2633 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2636 if (array_check (array
, 1) == FAILURE
)
2644 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
2646 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2649 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2650 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2653 if (array_check (array
, 1) == FAILURE
)
2659 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2660 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2663 if (scalar_check (status
, 2) == FAILURE
)
2671 gfc_check_transfer (gfc_expr
*source ATTRIBUTE_UNUSED
,
2672 gfc_expr
*mold ATTRIBUTE_UNUSED
, gfc_expr
*size
)
2674 if (mold
->ts
.type
== BT_HOLLERITH
)
2676 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
2677 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
2683 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
2686 if (scalar_check (size
, 2) == FAILURE
)
2689 if (nonoptional_check (size
, 2) == FAILURE
)
2698 gfc_check_transpose (gfc_expr
*matrix
)
2700 if (rank_check (matrix
, 0, 2) == FAILURE
)
2708 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2710 if (array_check (array
, 0) == FAILURE
)
2715 if (dim_check (dim
, 1, false) == FAILURE
)
2718 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2722 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2724 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2725 "with KIND argument at %L",
2726 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2734 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
2736 if (rank_check (vector
, 0, 1) == FAILURE
)
2739 if (array_check (mask
, 1) == FAILURE
)
2742 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2745 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
2753 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
2755 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2758 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2761 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2764 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
2766 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2767 "with KIND argument at %L",
2768 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2776 gfc_check_trim (gfc_expr
*x
)
2778 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2781 if (scalar_check (x
, 0) == FAILURE
)
2789 gfc_check_ttynam (gfc_expr
*unit
)
2791 if (scalar_check (unit
, 0) == FAILURE
)
2794 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2801 /* Common check function for the half a dozen intrinsics that have a
2802 single real argument. */
2805 gfc_check_x (gfc_expr
*x
)
2807 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2814 /************* Check functions for intrinsic subroutines *************/
2817 gfc_check_cpu_time (gfc_expr
*time
)
2819 if (scalar_check (time
, 0) == FAILURE
)
2822 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2825 if (variable_check (time
, 0) == FAILURE
)
2833 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
2834 gfc_expr
*zone
, gfc_expr
*values
)
2838 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
2840 if (scalar_check (date
, 0) == FAILURE
)
2842 if (variable_check (date
, 0) == FAILURE
)
2848 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
2850 if (scalar_check (time
, 1) == FAILURE
)
2852 if (variable_check (time
, 1) == FAILURE
)
2858 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
2860 if (scalar_check (zone
, 2) == FAILURE
)
2862 if (variable_check (zone
, 2) == FAILURE
)
2868 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
2870 if (array_check (values
, 3) == FAILURE
)
2872 if (rank_check (values
, 3, 1) == FAILURE
)
2874 if (variable_check (values
, 3) == FAILURE
)
2883 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
2884 gfc_expr
*to
, gfc_expr
*topos
)
2886 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
2889 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
2892 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
2895 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
2898 if (variable_check (to
, 3) == FAILURE
)
2901 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
2909 gfc_check_random_number (gfc_expr
*harvest
)
2911 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
2914 if (variable_check (harvest
, 0) == FAILURE
)
2922 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
2924 unsigned int nargs
= 0;
2925 locus
*where
= NULL
;
2929 if (size
->expr_type
!= EXPR_VARIABLE
2930 || !size
->symtree
->n
.sym
->attr
.optional
)
2933 if (scalar_check (size
, 0) == FAILURE
)
2936 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
2939 if (variable_check (size
, 0) == FAILURE
)
2942 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
2948 if (put
->expr_type
!= EXPR_VARIABLE
2949 || !put
->symtree
->n
.sym
->attr
.optional
)
2952 where
= &put
->where
;
2955 if (array_check (put
, 1) == FAILURE
)
2958 if (rank_check (put
, 1, 1) == FAILURE
)
2961 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
2964 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
2970 if (get
->expr_type
!= EXPR_VARIABLE
2971 || !get
->symtree
->n
.sym
->attr
.optional
)
2974 where
= &get
->where
;
2977 if (array_check (get
, 2) == FAILURE
)
2980 if (rank_check (get
, 2, 1) == FAILURE
)
2983 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
2986 if (variable_check (get
, 2) == FAILURE
)
2989 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
2993 /* RANDOM_SEED may not have more than one non-optional argument. */
2995 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
3002 gfc_check_second_sub (gfc_expr
*time
)
3004 if (scalar_check (time
, 0) == FAILURE
)
3007 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
3010 if (kind_value_check(time
, 0, 4) == FAILURE
)
3017 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3018 count, count_rate, and count_max are all optional arguments */
3021 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
3022 gfc_expr
*count_max
)
3026 if (scalar_check (count
, 0) == FAILURE
)
3029 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
3032 if (variable_check (count
, 0) == FAILURE
)
3036 if (count_rate
!= NULL
)
3038 if (scalar_check (count_rate
, 1) == FAILURE
)
3041 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
3044 if (variable_check (count_rate
, 1) == FAILURE
)
3048 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
3053 if (count_max
!= NULL
)
3055 if (scalar_check (count_max
, 2) == FAILURE
)
3058 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
3061 if (variable_check (count_max
, 2) == FAILURE
)
3065 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
3068 if (count_rate
!= NULL
3069 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
3078 gfc_check_irand (gfc_expr
*x
)
3083 if (scalar_check (x
, 0) == FAILURE
)
3086 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3089 if (kind_value_check(x
, 0, 4) == FAILURE
)
3097 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
3099 if (scalar_check (seconds
, 0) == FAILURE
)
3102 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
3105 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3107 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3108 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
3109 gfc_current_intrinsic
, &handler
->where
);
3113 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3119 if (scalar_check (status
, 2) == FAILURE
)
3122 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3125 if (kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
3133 gfc_check_rand (gfc_expr
*x
)
3138 if (scalar_check (x
, 0) == FAILURE
)
3141 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3144 if (kind_value_check(x
, 0, 4) == FAILURE
)
3152 gfc_check_srand (gfc_expr
*x
)
3154 if (scalar_check (x
, 0) == FAILURE
)
3157 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3160 if (kind_value_check(x
, 0, 4) == FAILURE
)
3168 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
3170 if (scalar_check (time
, 0) == FAILURE
)
3173 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
3176 if (type_check (result
, 1, BT_CHARACTER
) == FAILURE
)
3184 gfc_check_etime (gfc_expr
*x
)
3186 if (array_check (x
, 0) == FAILURE
)
3189 if (rank_check (x
, 0, 1) == FAILURE
)
3192 if (variable_check (x
, 0) == FAILURE
)
3195 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3198 if (kind_value_check(x
, 0, 4) == FAILURE
)
3206 gfc_check_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
3208 if (array_check (values
, 0) == FAILURE
)
3211 if (rank_check (values
, 0, 1) == FAILURE
)
3214 if (variable_check (values
, 0) == FAILURE
)
3217 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
3220 if (kind_value_check(values
, 0, 4) == FAILURE
)
3223 if (scalar_check (time
, 1) == FAILURE
)
3226 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
3229 if (kind_value_check(time
, 1, 4) == FAILURE
)
3237 gfc_check_fdate_sub (gfc_expr
*date
)
3239 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
3247 gfc_check_gerror (gfc_expr
*msg
)
3249 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3257 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
3259 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
3265 if (scalar_check (status
, 1) == FAILURE
)
3268 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3276 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
3278 if (type_check (pos
, 0, BT_INTEGER
) == FAILURE
)
3281 if (pos
->ts
.kind
> gfc_default_integer_kind
)
3283 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3284 "not wider than the default kind (%d)",
3285 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
3286 &pos
->where
, gfc_default_integer_kind
);
3290 if (type_check (value
, 1, BT_CHARACTER
) == FAILURE
)
3298 gfc_check_getlog (gfc_expr
*msg
)
3300 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3308 gfc_check_exit (gfc_expr
*status
)
3313 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
3316 if (scalar_check (status
, 0) == FAILURE
)
3324 gfc_check_flush (gfc_expr
*unit
)
3329 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3332 if (scalar_check (unit
, 0) == FAILURE
)
3340 gfc_check_free (gfc_expr
*i
)
3342 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
3345 if (scalar_check (i
, 0) == FAILURE
)
3353 gfc_check_hostnm (gfc_expr
*name
)
3355 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3363 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
3365 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3371 if (scalar_check (status
, 1) == FAILURE
)
3374 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3382 gfc_check_itime_idate (gfc_expr
*values
)
3384 if (array_check (values
, 0) == FAILURE
)
3387 if (rank_check (values
, 0, 1) == FAILURE
)
3390 if (variable_check (values
, 0) == FAILURE
)
3393 if (type_check (values
, 0, BT_INTEGER
) == FAILURE
)
3396 if (kind_value_check(values
, 0, gfc_default_integer_kind
) == FAILURE
)
3404 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
3406 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
3409 if (kind_value_check(time
, 0, gfc_default_integer_kind
) == FAILURE
)
3412 if (scalar_check (time
, 0) == FAILURE
)
3415 if (array_check (values
, 1) == FAILURE
)
3418 if (rank_check (values
, 1, 1) == FAILURE
)
3421 if (variable_check (values
, 1) == FAILURE
)
3424 if (type_check (values
, 1, BT_INTEGER
) == FAILURE
)
3427 if (kind_value_check(values
, 1, gfc_default_integer_kind
) == FAILURE
)
3435 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
3437 if (scalar_check (unit
, 0) == FAILURE
)
3440 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3443 if (type_check (name
, 1, BT_CHARACTER
) == FAILURE
)
3451 gfc_check_isatty (gfc_expr
*unit
)
3456 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3459 if (scalar_check (unit
, 0) == FAILURE
)
3467 gfc_check_isnan (gfc_expr
*x
)
3469 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3477 gfc_check_perror (gfc_expr
*string
)
3479 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
3487 gfc_check_umask (gfc_expr
*mask
)
3489 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3492 if (scalar_check (mask
, 0) == FAILURE
)
3500 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
3502 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3505 if (scalar_check (mask
, 0) == FAILURE
)
3511 if (scalar_check (old
, 1) == FAILURE
)
3514 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
3522 gfc_check_unlink (gfc_expr
*name
)
3524 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3532 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
3534 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3540 if (scalar_check (status
, 1) == FAILURE
)
3543 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3551 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
3553 if (scalar_check (number
, 0) == FAILURE
)
3556 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3559 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3561 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3562 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
3563 gfc_current_intrinsic
, &handler
->where
);
3567 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3575 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
3577 if (scalar_check (number
, 0) == FAILURE
)
3580 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3583 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3585 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3586 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
3587 gfc_current_intrinsic
, &handler
->where
);
3591 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3597 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3600 if (scalar_check (status
, 2) == FAILURE
)
3608 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
3610 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
3613 if (scalar_check (status
, 1) == FAILURE
)
3616 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3619 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)
3626 /* This is used for the GNU intrinsics AND, OR and XOR. */
3628 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
3630 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
3632 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3633 "or LOGICAL", gfc_current_intrinsic_arg
[0],
3634 gfc_current_intrinsic
, &i
->where
);
3638 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
3640 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3641 "or LOGICAL", gfc_current_intrinsic_arg
[1],
3642 gfc_current_intrinsic
, &j
->where
);
3646 if (i
->ts
.type
!= j
->ts
.type
)
3648 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3649 "have the same type", gfc_current_intrinsic_arg
[0],
3650 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
3655 if (scalar_check (i
, 0) == FAILURE
)
3658 if (scalar_check (j
, 1) == FAILURE
)