2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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
)
318 if (type_check (dim
, n
, BT_INTEGER
) == FAILURE
)
321 if (scalar_check (dim
, n
) == FAILURE
)
324 if (!optional
&& nonoptional_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
)
345 if (dim
->expr_type
!= EXPR_CONSTANT
346 || (array
->expr_type
!= EXPR_VARIABLE
347 && array
->expr_type
!= EXPR_ARRAY
))
351 if (array
->expr_type
== EXPR_VARIABLE
)
353 ar
= gfc_find_array_ref (array
);
354 if (ar
->as
->type
== AS_ASSUMED_SIZE
356 && ar
->type
!= AR_ELEMENT
357 && ar
->type
!= AR_SECTION
)
361 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
362 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
364 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
365 "dimension index", gfc_current_intrinsic
, &dim
->where
);
374 /* Compare the size of a along dimension ai with the size of b along
375 dimension bi, returning 0 if they are known not to be identical,
376 and 1 if they are identical, or if this cannot be determined. */
379 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
381 mpz_t a_size
, b_size
;
384 gcc_assert (a
->rank
> ai
);
385 gcc_assert (b
->rank
> bi
);
389 if (gfc_array_dimen_size (a
, ai
, &a_size
) == SUCCESS
)
391 if (gfc_array_dimen_size (b
, bi
, &b_size
) == SUCCESS
)
393 if (mpz_cmp (a_size
, b_size
) != 0)
404 /* Check whether two character expressions have the same length;
405 returns SUCCESS if they have or if the length cannot be determined. */
408 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
413 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
414 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
415 len_a
= mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
416 else if (a
->expr_type
== EXPR_CONSTANT
417 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
418 len_a
= a
->value
.character
.length
;
422 if (b
->ts
.u
.cl
&& b
->ts
.u
.cl
->length
423 && b
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
424 len_b
= mpz_get_si (b
->ts
.u
.cl
->length
->value
.integer
);
425 else if (b
->expr_type
== EXPR_CONSTANT
426 && (b
->ts
.u
.cl
== NULL
|| b
->ts
.u
.cl
->length
== NULL
))
427 len_b
= b
->value
.character
.length
;
434 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
435 len_a
, len_b
, name
, &a
->where
);
440 /***** Check functions *****/
442 /* Check subroutine suitable for intrinsics taking a real argument and
443 a kind argument for the result. */
446 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
448 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
450 if (kind_check (kind
, 1, type
) == FAILURE
)
457 /* Check subroutine suitable for ceiling, floor and nint. */
460 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
462 return check_a_kind (a
, kind
, BT_INTEGER
);
466 /* Check subroutine suitable for aint, anint. */
469 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
471 return check_a_kind (a
, kind
, BT_REAL
);
476 gfc_check_abs (gfc_expr
*a
)
478 if (numeric_check (a
, 0) == FAILURE
)
486 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
488 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
490 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
498 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
500 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
501 || scalar_check (name
, 0) == FAILURE
)
503 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
506 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
507 || scalar_check (mode
, 1) == FAILURE
)
509 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
517 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
519 if (logical_array_check (mask
, 0) == FAILURE
)
522 if (dim_check (dim
, 1, false) == FAILURE
)
525 if (dim_rank_check (dim
, mask
, 0) == FAILURE
)
533 gfc_check_allocated (gfc_expr
*array
)
535 symbol_attribute attr
;
537 if (variable_check (array
, 0) == FAILURE
)
540 attr
= gfc_variable_attr (array
, NULL
);
541 if (!attr
.allocatable
)
543 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
544 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
553 /* Common check function where the first argument must be real or
554 integer and the second argument must be the same as the first. */
557 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
559 if (int_or_real_check (a
, 0) == FAILURE
)
562 if (a
->ts
.type
!= p
->ts
.type
)
564 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
565 "have the same type", gfc_current_intrinsic_arg
[0],
566 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
571 if (a
->ts
.kind
!= p
->ts
.kind
)
573 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
574 &p
->where
) == FAILURE
)
583 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
585 if (double_check (x
, 0) == FAILURE
|| double_check (y
, 1) == FAILURE
)
593 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
595 symbol_attribute attr1
, attr2
;
600 where
= &pointer
->where
;
602 if (pointer
->expr_type
== EXPR_VARIABLE
|| pointer
->expr_type
== EXPR_FUNCTION
)
603 attr1
= gfc_expr_attr (pointer
);
604 else if (pointer
->expr_type
== EXPR_NULL
)
607 gcc_assert (0); /* Pointer must be a variable or a function. */
609 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
611 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
612 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
617 /* Target argument is optional. */
621 where
= &target
->where
;
622 if (target
->expr_type
== EXPR_NULL
)
625 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
626 attr2
= gfc_expr_attr (target
);
629 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
630 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg
[1],
631 gfc_current_intrinsic
, &target
->where
);
635 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
637 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
638 "or a TARGET", gfc_current_intrinsic_arg
[1],
639 gfc_current_intrinsic
, &target
->where
);
644 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
646 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
648 if (target
->rank
> 0)
650 for (i
= 0; i
< target
->rank
; i
++)
651 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
653 gfc_error ("Array section with a vector subscript at %L shall not "
654 "be the target of a pointer",
664 gfc_error ("NULL pointer at %L is not permitted as actual argument "
665 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
672 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
674 /* gfc_notify_std would be a wast of time as the return value
675 is seemingly used only for the generic resolution. The error
676 will be: Too many arguments. */
677 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
680 return gfc_check_atan2 (y
, x
);
685 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
687 if (type_check (y
, 0, BT_REAL
) == FAILURE
)
689 if (same_type_check (y
, 0, x
, 1) == FAILURE
)
696 /* BESJN and BESYN functions. */
699 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
701 if (type_check (n
, 0, BT_INTEGER
) == FAILURE
)
704 if (type_check (x
, 1, BT_REAL
) == FAILURE
)
712 gfc_check_btest (gfc_expr
*i
, gfc_expr
*pos
)
714 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
716 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
724 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
726 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
728 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
736 gfc_check_chdir (gfc_expr
*dir
)
738 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
740 if (kind_value_check (dir
, 0, gfc_default_character_kind
) == FAILURE
)
748 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
750 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
752 if (kind_value_check (dir
, 0, gfc_default_character_kind
) == FAILURE
)
758 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
760 if (scalar_check (status
, 1) == FAILURE
)
768 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
770 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
772 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
775 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
777 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
785 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
787 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
789 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
792 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
794 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
800 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
803 if (scalar_check (status
, 2) == FAILURE
)
811 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
813 if (numeric_check (x
, 0) == FAILURE
)
818 if (numeric_check (y
, 1) == FAILURE
)
821 if (x
->ts
.type
== BT_COMPLEX
)
823 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
824 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
825 gfc_current_intrinsic
, &y
->where
);
829 if (y
->ts
.type
== BT_COMPLEX
)
831 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
832 "of either REAL or INTEGER", gfc_current_intrinsic_arg
[1],
833 gfc_current_intrinsic
, &y
->where
);
839 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
847 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
849 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
851 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
852 "or REAL", gfc_current_intrinsic_arg
[0],
853 gfc_current_intrinsic
, &x
->where
);
856 if (scalar_check (x
, 0) == FAILURE
)
859 if (y
->ts
.type
!= BT_INTEGER
&& y
->ts
.type
!= BT_REAL
)
861 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
862 "or REAL", gfc_current_intrinsic_arg
[1],
863 gfc_current_intrinsic
, &y
->where
);
866 if (scalar_check (y
, 1) == FAILURE
)
874 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
876 if (logical_array_check (mask
, 0) == FAILURE
)
878 if (dim_check (dim
, 1, false) == FAILURE
)
880 if (dim_rank_check (dim
, mask
, 0) == FAILURE
)
882 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
884 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
885 "with KIND argument at %L",
886 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
894 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
896 if (array_check (array
, 0) == FAILURE
)
899 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
902 if (dim_check (dim
, 2, true) == FAILURE
)
905 if (dim_rank_check (dim
, array
, false) == FAILURE
)
908 if (array
->rank
== 1 || shift
->rank
== 0)
910 if (scalar_check (shift
, 1) == FAILURE
)
913 else if (shift
->rank
== array
->rank
- 1)
918 else if (dim
->expr_type
== EXPR_CONSTANT
)
919 gfc_extract_int (dim
, &d
);
926 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
929 if (!identical_dimen_shape (array
, i
, shift
, j
))
931 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
932 "invalid shape in dimension %d (%ld/%ld)",
933 gfc_current_intrinsic_arg
[1],
934 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
935 mpz_get_si (array
->shape
[i
]),
936 mpz_get_si (shift
->shape
[j
]));
946 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
947 "%d or be a scalar", gfc_current_intrinsic_arg
[1],
948 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
957 gfc_check_ctime (gfc_expr
*time
)
959 if (scalar_check (time
, 0) == FAILURE
)
962 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
969 gfc_try
gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
971 if (double_check (y
, 0) == FAILURE
|| double_check (x
, 1) == FAILURE
)
978 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
980 if (numeric_check (x
, 0) == FAILURE
)
985 if (numeric_check (y
, 1) == FAILURE
)
988 if (x
->ts
.type
== BT_COMPLEX
)
990 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
991 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
992 gfc_current_intrinsic
, &y
->where
);
996 if (y
->ts
.type
== BT_COMPLEX
)
998 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
999 "of either REAL or INTEGER", gfc_current_intrinsic_arg
[1],
1000 gfc_current_intrinsic
, &y
->where
);
1010 gfc_check_dble (gfc_expr
*x
)
1012 if (numeric_check (x
, 0) == FAILURE
)
1020 gfc_check_digits (gfc_expr
*x
)
1022 if (int_or_real_check (x
, 0) == FAILURE
)
1030 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1032 switch (vector_a
->ts
.type
)
1035 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
1042 if (numeric_check (vector_b
, 1) == FAILURE
)
1047 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1048 "or LOGICAL", gfc_current_intrinsic_arg
[0],
1049 gfc_current_intrinsic
, &vector_a
->where
);
1053 if (rank_check (vector_a
, 0, 1) == FAILURE
)
1056 if (rank_check (vector_b
, 1, 1) == FAILURE
)
1059 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1061 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1062 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0],
1063 gfc_current_intrinsic_arg
[1], &vector_a
->where
);
1072 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1074 if (type_check (x
, 0, BT_REAL
) == FAILURE
1075 || type_check (y
, 1, BT_REAL
) == FAILURE
)
1078 if (x
->ts
.kind
!= gfc_default_real_kind
)
1080 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1081 "real", gfc_current_intrinsic_arg
[0],
1082 gfc_current_intrinsic
, &x
->where
);
1086 if (y
->ts
.kind
!= gfc_default_real_kind
)
1088 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1089 "real", gfc_current_intrinsic_arg
[1],
1090 gfc_current_intrinsic
, &y
->where
);
1099 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1102 if (array_check (array
, 0) == FAILURE
)
1105 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1108 if (dim_check (dim
, 3, true) == FAILURE
)
1111 if (dim_rank_check (dim
, array
, false) == FAILURE
)
1114 if (array
->rank
== 1 || shift
->rank
== 0)
1116 if (scalar_check (shift
, 1) == FAILURE
)
1119 else if (shift
->rank
== array
->rank
- 1)
1124 else if (dim
->expr_type
== EXPR_CONSTANT
)
1125 gfc_extract_int (dim
, &d
);
1132 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1135 if (!identical_dimen_shape (array
, i
, shift
, j
))
1137 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1138 "invalid shape in dimension %d (%ld/%ld)",
1139 gfc_current_intrinsic_arg
[1],
1140 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1141 mpz_get_si (array
->shape
[i
]),
1142 mpz_get_si (shift
->shape
[j
]));
1152 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1153 "%d or be a scalar", gfc_current_intrinsic_arg
[1],
1154 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1158 if (boundary
!= NULL
)
1160 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
1163 if (array
->rank
== 1 || boundary
->rank
== 0)
1165 if (scalar_check (boundary
, 2) == FAILURE
)
1168 else if (boundary
->rank
== array
->rank
- 1)
1170 if (gfc_check_conformance (shift
, boundary
,
1171 "arguments '%s' and '%s' for "
1173 gfc_current_intrinsic_arg
[1],
1174 gfc_current_intrinsic_arg
[2],
1175 gfc_current_intrinsic
) == FAILURE
)
1180 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1181 "rank %d or be a scalar", gfc_current_intrinsic_arg
[1],
1182 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1191 /* A single complex argument. */
1194 gfc_check_fn_c (gfc_expr
*a
)
1196 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
1203 /* A single real argument. */
1206 gfc_check_fn_r (gfc_expr
*a
)
1208 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
1214 /* A single double argument. */
1217 gfc_check_fn_d (gfc_expr
*a
)
1219 if (double_check (a
, 0) == FAILURE
)
1225 /* A single real or complex argument. */
1228 gfc_check_fn_rc (gfc_expr
*a
)
1230 if (real_or_complex_check (a
, 0) == FAILURE
)
1238 gfc_check_fn_rc2008 (gfc_expr
*a
)
1240 if (real_or_complex_check (a
, 0) == FAILURE
)
1243 if (a
->ts
.type
== BT_COMPLEX
1244 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: COMPLEX argument '%s' "
1245 "argument of '%s' intrinsic at %L",
1246 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
1247 &a
->where
) == FAILURE
)
1255 gfc_check_fnum (gfc_expr
*unit
)
1257 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1260 if (scalar_check (unit
, 0) == FAILURE
)
1268 gfc_check_huge (gfc_expr
*x
)
1270 if (int_or_real_check (x
, 0) == FAILURE
)
1278 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
1280 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1282 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1289 /* Check that the single argument is an integer. */
1292 gfc_check_i (gfc_expr
*i
)
1294 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1302 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1304 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1307 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1310 if (i
->ts
.kind
!= j
->ts
.kind
)
1312 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1313 &i
->where
) == FAILURE
)
1322 gfc_check_ibclr (gfc_expr
*i
, gfc_expr
*pos
)
1324 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1327 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1335 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1337 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1340 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1343 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1351 gfc_check_ibset (gfc_expr
*i
, gfc_expr
*pos
)
1353 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1356 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1364 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1368 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
1371 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1374 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1375 "with KIND argument at %L",
1376 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1379 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1385 /* Substring references don't have the charlength set. */
1387 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1390 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1394 /* Check that the argument is length one. Non-constant lengths
1395 can't be checked here, so assume they are ok. */
1396 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
1398 /* If we already have a length for this expression then use it. */
1399 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1401 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1408 start
= ref
->u
.ss
.start
;
1409 end
= ref
->u
.ss
.end
;
1412 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1413 || start
->expr_type
!= EXPR_CONSTANT
)
1416 i
= mpz_get_si (end
->value
.integer
) + 1
1417 - mpz_get_si (start
->value
.integer
);
1425 gfc_error ("Argument of %s at %L must be of length one",
1426 gfc_current_intrinsic
, &c
->where
);
1435 gfc_check_idnint (gfc_expr
*a
)
1437 if (double_check (a
, 0) == FAILURE
)
1445 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
1447 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1450 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1453 if (i
->ts
.kind
!= j
->ts
.kind
)
1455 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1456 &i
->where
) == FAILURE
)
1465 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
1468 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1469 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1472 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1475 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
1477 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1478 "with KIND argument at %L",
1479 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1482 if (string
->ts
.kind
!= substring
->ts
.kind
)
1484 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1485 "kind as '%s'", gfc_current_intrinsic_arg
[1],
1486 gfc_current_intrinsic
, &substring
->where
,
1487 gfc_current_intrinsic_arg
[0]);
1496 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
1498 if (numeric_check (x
, 0) == FAILURE
)
1501 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1509 gfc_check_intconv (gfc_expr
*x
)
1511 if (numeric_check (x
, 0) == FAILURE
)
1519 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
1521 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1524 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1527 if (i
->ts
.kind
!= j
->ts
.kind
)
1529 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1530 &i
->where
) == FAILURE
)
1539 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
1541 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1542 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1550 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1552 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1553 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1556 if (size
!= NULL
&& type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1564 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
1566 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1569 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1577 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
1579 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1582 if (scalar_check (pid
, 0) == FAILURE
)
1585 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1588 if (scalar_check (sig
, 1) == FAILURE
)
1594 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1597 if (scalar_check (status
, 2) == FAILURE
)
1605 gfc_check_kind (gfc_expr
*x
)
1607 if (x
->ts
.type
== BT_DERIVED
)
1609 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1610 "non-derived type", gfc_current_intrinsic_arg
[0],
1611 gfc_current_intrinsic
, &x
->where
);
1620 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1622 if (array_check (array
, 0) == FAILURE
)
1625 if (dim_check (dim
, 1, false) == FAILURE
)
1628 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
1631 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
1633 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1634 "with KIND argument at %L",
1635 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1643 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
1645 if (type_check (s
, 0, BT_CHARACTER
) == FAILURE
)
1648 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1650 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1651 "with KIND argument at %L",
1652 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1660 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
1662 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
1664 if (kind_value_check (a
, 0, gfc_default_character_kind
) == FAILURE
)
1667 if (type_check (b
, 1, BT_CHARACTER
) == FAILURE
)
1669 if (kind_value_check (b
, 1, gfc_default_character_kind
) == FAILURE
)
1677 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
1679 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1681 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
1684 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1686 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
1694 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
1696 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1698 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
1701 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1703 if (kind_value_check (path2
, 0, gfc_default_character_kind
) == FAILURE
)
1709 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1712 if (scalar_check (status
, 2) == FAILURE
)
1720 gfc_check_loc (gfc_expr
*expr
)
1722 return variable_check (expr
, 0);
1727 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
1729 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1731 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
1734 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1736 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
1744 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
1746 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1748 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
1751 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1753 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
1759 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1762 if (scalar_check (status
, 2) == FAILURE
)
1770 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
1772 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
1774 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
1781 /* Min/max family. */
1784 min_max_args (gfc_actual_arglist
*arg
)
1786 if (arg
== NULL
|| arg
->next
== NULL
)
1788 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1789 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1798 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
1800 gfc_actual_arglist
*arg
, *tmp
;
1805 if (min_max_args (arglist
) == FAILURE
)
1808 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
1811 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
1813 if (x
->ts
.type
== type
)
1815 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type "
1816 "kinds at %L", &x
->where
) == FAILURE
)
1821 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1822 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
1823 gfc_basic_typename (type
), kind
);
1828 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
1829 if (gfc_check_conformance (tmp
->expr
, x
,
1830 "arguments 'a%d' and 'a%d' for "
1831 "intrinsic '%s'", m
, n
,
1832 gfc_current_intrinsic
) == FAILURE
)
1841 gfc_check_min_max (gfc_actual_arglist
*arg
)
1845 if (min_max_args (arg
) == FAILURE
)
1850 if (x
->ts
.type
== BT_CHARACTER
)
1852 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1853 "with CHARACTER argument at %L",
1854 gfc_current_intrinsic
, &x
->where
) == FAILURE
)
1857 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
1859 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1860 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
1864 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
1869 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
1871 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
1876 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
1878 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
1883 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
1885 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
1889 /* End of min/max family. */
1892 gfc_check_malloc (gfc_expr
*size
)
1894 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
1897 if (scalar_check (size
, 0) == FAILURE
)
1905 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
1907 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
1909 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1910 "or LOGICAL", gfc_current_intrinsic_arg
[0],
1911 gfc_current_intrinsic
, &matrix_a
->where
);
1915 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
1917 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1918 "or LOGICAL", gfc_current_intrinsic_arg
[1],
1919 gfc_current_intrinsic
, &matrix_b
->where
);
1923 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
1924 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
1926 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
1927 gfc_current_intrinsic
, &matrix_a
->where
,
1928 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
1932 switch (matrix_a
->rank
)
1935 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
1937 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1938 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
1940 gfc_error ("Different shape on dimension 1 for arguments '%s' "
1941 "and '%s' at %L for intrinsic matmul",
1942 gfc_current_intrinsic_arg
[0],
1943 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1949 if (matrix_b
->rank
!= 2)
1951 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
1954 /* matrix_b has rank 1 or 2 here. Common check for the cases
1955 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1956 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1957 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
1959 gfc_error ("Different shape on dimension 2 for argument '%s' and "
1960 "dimension 1 for argument '%s' at %L for intrinsic "
1961 "matmul", gfc_current_intrinsic_arg
[0],
1962 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1968 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1969 "1 or 2", gfc_current_intrinsic_arg
[0],
1970 gfc_current_intrinsic
, &matrix_a
->where
);
1978 /* Whoever came up with this interface was probably on something.
1979 The possibilities for the occupation of the second and third
1986 NULL MASK minloc(array, mask=m)
1989 I.e. in the case of minloc(array,mask), mask will be in the second
1990 position of the argument list and we'll have to fix that up. */
1993 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
1995 gfc_expr
*a
, *m
, *d
;
1998 if (int_or_real_check (a
, 0) == FAILURE
|| array_check (a
, 0) == FAILURE
)
2002 m
= ap
->next
->next
->expr
;
2004 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2005 && ap
->next
->name
== NULL
)
2009 ap
->next
->expr
= NULL
;
2010 ap
->next
->next
->expr
= m
;
2013 if (dim_check (d
, 1, false) == FAILURE
)
2016 if (dim_rank_check (d
, a
, 0) == FAILURE
)
2019 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
2023 && gfc_check_conformance (a
, m
,
2024 "arguments '%s' and '%s' for intrinsic %s",
2025 gfc_current_intrinsic_arg
[0],
2026 gfc_current_intrinsic_arg
[2],
2027 gfc_current_intrinsic
) == FAILURE
)
2034 /* Similar to minloc/maxloc, the argument list might need to be
2035 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2036 difference is that MINLOC/MAXLOC take an additional KIND argument.
2037 The possibilities are:
2043 NULL MASK minval(array, mask=m)
2046 I.e. in the case of minval(array,mask), mask will be in the second
2047 position of the argument list and we'll have to fix that up. */
2050 check_reduction (gfc_actual_arglist
*ap
)
2052 gfc_expr
*a
, *m
, *d
;
2056 m
= ap
->next
->next
->expr
;
2058 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2059 && ap
->next
->name
== NULL
)
2063 ap
->next
->expr
= NULL
;
2064 ap
->next
->next
->expr
= m
;
2067 if (dim_check (d
, 1, false) == FAILURE
)
2070 if (dim_rank_check (d
, a
, 0) == FAILURE
)
2073 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
2077 && gfc_check_conformance (a
, m
,
2078 "arguments '%s' and '%s' for intrinsic %s",
2079 gfc_current_intrinsic_arg
[0],
2080 gfc_current_intrinsic_arg
[2],
2081 gfc_current_intrinsic
) == FAILURE
)
2089 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
2091 if (int_or_real_check (ap
->expr
, 0) == FAILURE
2092 || array_check (ap
->expr
, 0) == FAILURE
)
2095 return check_reduction (ap
);
2100 gfc_check_product_sum (gfc_actual_arglist
*ap
)
2102 if (numeric_check (ap
->expr
, 0) == FAILURE
2103 || array_check (ap
->expr
, 0) == FAILURE
)
2106 return check_reduction (ap
);
2111 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
2113 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
2116 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
2119 if (tsource
->ts
.type
== BT_CHARACTER
)
2120 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
2127 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
2129 symbol_attribute attr
;
2131 if (variable_check (from
, 0) == FAILURE
)
2134 attr
= gfc_variable_attr (from
, NULL
);
2135 if (!attr
.allocatable
)
2137 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2138 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
2143 if (variable_check (to
, 0) == FAILURE
)
2146 attr
= gfc_variable_attr (to
, NULL
);
2147 if (!attr
.allocatable
)
2149 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2150 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
2155 if (same_type_check (to
, 1, from
, 0) == FAILURE
)
2158 if (to
->rank
!= from
->rank
)
2160 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2161 "have the same rank %d/%d", gfc_current_intrinsic_arg
[0],
2162 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
2163 &to
->where
, from
->rank
, to
->rank
);
2167 if (to
->ts
.kind
!= from
->ts
.kind
)
2169 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2170 "be of the same kind %d/%d", gfc_current_intrinsic_arg
[0],
2171 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
2172 &to
->where
, from
->ts
.kind
, to
->ts
.kind
);
2181 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
2183 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2186 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
2194 gfc_check_new_line (gfc_expr
*a
)
2196 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
2204 gfc_check_null (gfc_expr
*mold
)
2206 symbol_attribute attr
;
2211 if (variable_check (mold
, 0) == FAILURE
)
2214 attr
= gfc_variable_attr (mold
, NULL
);
2216 if (!attr
.pointer
&& !attr
.proc_pointer
)
2218 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2219 gfc_current_intrinsic_arg
[0],
2220 gfc_current_intrinsic
, &mold
->where
);
2229 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
2231 if (array_check (array
, 0) == FAILURE
)
2234 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2237 if (gfc_check_conformance (array
, mask
,
2238 "arguments '%s' and '%s' for intrinsic '%s'",
2239 gfc_current_intrinsic_arg
[0],
2240 gfc_current_intrinsic_arg
[1],
2241 gfc_current_intrinsic
) == FAILURE
)
2246 mpz_t array_size
, vector_size
;
2247 bool have_array_size
, have_vector_size
;
2249 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
2252 if (rank_check (vector
, 2, 1) == FAILURE
)
2255 /* VECTOR requires at least as many elements as MASK
2256 has .TRUE. values. */
2257 have_array_size
= gfc_array_size (array
, &array_size
) == SUCCESS
;
2258 have_vector_size
= gfc_array_size (vector
, &vector_size
) == SUCCESS
;
2260 if (have_vector_size
2261 && (mask
->expr_type
== EXPR_ARRAY
2262 || (mask
->expr_type
== EXPR_CONSTANT
2263 && have_array_size
)))
2265 int mask_true_values
= 0;
2267 if (mask
->expr_type
== EXPR_ARRAY
)
2269 gfc_constructor
*mask_ctor
= mask
->value
.constructor
;
2272 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
2274 mask_true_values
= 0;
2278 if (mask_ctor
->expr
->value
.logical
)
2281 mask_ctor
= mask_ctor
->next
;
2284 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
2285 mask_true_values
= mpz_get_si (array_size
);
2287 if (mpz_get_si (vector_size
) < mask_true_values
)
2289 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2290 "provide at least as many elements as there "
2291 "are .TRUE. values in '%s' (%ld/%d)",
2292 gfc_current_intrinsic_arg
[2],gfc_current_intrinsic
,
2293 &vector
->where
, gfc_current_intrinsic_arg
[1],
2294 mpz_get_si (vector_size
), mask_true_values
);
2299 if (have_array_size
)
2300 mpz_clear (array_size
);
2301 if (have_vector_size
)
2302 mpz_clear (vector_size
);
2310 gfc_check_precision (gfc_expr
*x
)
2312 if (x
->ts
.type
!= BT_REAL
&& x
->ts
.type
!= BT_COMPLEX
)
2314 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2315 "REAL or COMPLEX", gfc_current_intrinsic_arg
[0],
2316 gfc_current_intrinsic
, &x
->where
);
2325 gfc_check_present (gfc_expr
*a
)
2329 if (variable_check (a
, 0) == FAILURE
)
2332 sym
= a
->symtree
->n
.sym
;
2333 if (!sym
->attr
.dummy
)
2335 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2336 "dummy variable", gfc_current_intrinsic_arg
[0],
2337 gfc_current_intrinsic
, &a
->where
);
2341 if (!sym
->attr
.optional
)
2343 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2344 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg
[0],
2345 gfc_current_intrinsic
, &a
->where
);
2349 /* 13.14.82 PRESENT(A)
2351 Argument. A shall be the name of an optional dummy argument that is
2352 accessible in the subprogram in which the PRESENT function reference
2356 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
2357 && a
->ref
->u
.ar
.type
== AR_FULL
))
2359 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2360 "subobject of '%s'", gfc_current_intrinsic_arg
[0],
2361 gfc_current_intrinsic
, &a
->where
, sym
->name
);
2370 gfc_check_radix (gfc_expr
*x
)
2372 if (int_or_real_check (x
, 0) == FAILURE
)
2380 gfc_check_range (gfc_expr
*x
)
2382 if (numeric_check (x
, 0) == FAILURE
)
2389 /* real, float, sngl. */
2391 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
2393 if (numeric_check (a
, 0) == FAILURE
)
2396 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
2404 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
2406 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2408 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2411 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2413 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2421 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2423 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2425 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2428 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2430 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2436 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2439 if (scalar_check (status
, 2) == FAILURE
)
2447 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
2449 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2452 if (scalar_check (x
, 0) == FAILURE
)
2455 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
2458 if (scalar_check (y
, 1) == FAILURE
)
2466 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
2467 gfc_expr
*pad
, gfc_expr
*order
)
2473 if (array_check (source
, 0) == FAILURE
)
2476 if (rank_check (shape
, 1, 1) == FAILURE
)
2479 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
2482 if (gfc_array_size (shape
, &size
) != SUCCESS
)
2484 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2485 "array of constant size", &shape
->where
);
2489 shape_size
= mpz_get_ui (size
);
2492 if (shape_size
<= 0)
2494 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
2495 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
2499 else if (shape_size
> GFC_MAX_DIMENSIONS
)
2501 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2502 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
2505 else if (shape
->expr_type
== EXPR_ARRAY
)
2509 for (i
= 0; i
< shape_size
; ++i
)
2511 e
= gfc_get_array_element (shape
, i
);
2512 if (e
->expr_type
!= EXPR_CONSTANT
)
2518 gfc_extract_int (e
, &extent
);
2521 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2522 "negative element (%d)", gfc_current_intrinsic_arg
[1],
2523 gfc_current_intrinsic
, &e
->where
, extent
);
2533 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
2536 if (array_check (pad
, 2) == FAILURE
)
2542 if (array_check (order
, 3) == FAILURE
)
2545 if (type_check (order
, 3, BT_INTEGER
) == FAILURE
)
2548 if (order
->expr_type
== EXPR_ARRAY
)
2550 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
2553 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
2556 gfc_array_size (order
, &size
);
2557 order_size
= mpz_get_ui (size
);
2560 if (order_size
!= shape_size
)
2562 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2563 "has wrong number of elements (%d/%d)",
2564 gfc_current_intrinsic_arg
[3],
2565 gfc_current_intrinsic
, &order
->where
,
2566 order_size
, shape_size
);
2570 for (i
= 1; i
<= order_size
; ++i
)
2572 e
= gfc_get_array_element (order
, i
-1);
2573 if (e
->expr_type
!= EXPR_CONSTANT
)
2579 gfc_extract_int (e
, &dim
);
2581 if (dim
< 1 || dim
> order_size
)
2583 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2584 "has out-of-range dimension (%d)",
2585 gfc_current_intrinsic_arg
[3],
2586 gfc_current_intrinsic
, &e
->where
, dim
);
2590 if (perm
[dim
-1] != 0)
2592 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2593 "invalid permutation of dimensions (dimension "
2594 "'%d' duplicated)", gfc_current_intrinsic_arg
[3],
2595 gfc_current_intrinsic
, &e
->where
, dim
);
2605 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
2606 && gfc_is_constant_expr (shape
)
2607 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
2608 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
2610 /* Check the match in size between source and destination. */
2611 if (gfc_array_size (source
, &nelems
) == SUCCESS
)
2616 c
= shape
->value
.constructor
;
2617 mpz_init_set_ui (size
, 1);
2618 for (; c
; c
= c
->next
)
2619 mpz_mul (size
, size
, c
->expr
->value
.integer
);
2621 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
2627 gfc_error ("Without padding, there are not enough elements "
2628 "in the intrinsic RESHAPE source at %L to match "
2629 "the shape", &source
->where
);
2640 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2643 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
2645 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2646 "must be of a derived type", gfc_current_intrinsic_arg
[0],
2647 gfc_current_intrinsic
, &a
->where
);
2651 if (!gfc_type_is_extensible (a
->ts
.u
.derived
))
2653 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2654 "must be of an extensible type", gfc_current_intrinsic_arg
[0],
2655 gfc_current_intrinsic
, &a
->where
);
2659 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
2661 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2662 "must be of a derived type", gfc_current_intrinsic_arg
[1],
2663 gfc_current_intrinsic
, &b
->where
);
2667 if (!gfc_type_is_extensible (b
->ts
.u
.derived
))
2669 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2670 "must be of an extensible type", gfc_current_intrinsic_arg
[1],
2671 gfc_current_intrinsic
, &b
->where
);
2680 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
2682 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2685 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2693 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
2695 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2698 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
2701 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2704 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
2706 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2707 "with KIND argument at %L",
2708 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2711 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2719 gfc_check_secnds (gfc_expr
*r
)
2721 if (type_check (r
, 0, BT_REAL
) == FAILURE
)
2724 if (kind_value_check (r
, 0, 4) == FAILURE
)
2727 if (scalar_check (r
, 0) == FAILURE
)
2735 gfc_check_selected_char_kind (gfc_expr
*name
)
2737 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2740 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
2743 if (scalar_check (name
, 0) == FAILURE
)
2751 gfc_check_selected_int_kind (gfc_expr
*r
)
2753 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
2756 if (scalar_check (r
, 0) == FAILURE
)
2764 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
)
2766 if (p
== NULL
&& r
== NULL
)
2768 gfc_error ("Missing arguments to %s intrinsic at %L",
2769 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2774 if (p
!= NULL
&& type_check (p
, 0, BT_INTEGER
) == FAILURE
)
2777 if (r
!= NULL
&& type_check (r
, 1, BT_INTEGER
) == FAILURE
)
2785 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
2787 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2790 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2798 gfc_check_shape (gfc_expr
*source
)
2802 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
2805 ar
= gfc_find_array_ref (source
);
2807 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
2809 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2810 "an assumed size array", &source
->where
);
2819 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
2821 if (int_or_real_check (a
, 0) == FAILURE
)
2824 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
2832 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2834 if (array_check (array
, 0) == FAILURE
)
2837 if (dim_check (dim
, 1, true) == FAILURE
)
2840 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2843 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2845 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2846 "with KIND argument at %L",
2847 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2856 gfc_check_sizeof (gfc_expr
*arg ATTRIBUTE_UNUSED
)
2863 gfc_check_sleep_sub (gfc_expr
*seconds
)
2865 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
2868 if (scalar_check (seconds
, 0) == FAILURE
)
2876 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
2878 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
2880 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2881 "than rank %d", gfc_current_intrinsic_arg
[0],
2882 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
2890 if (dim_check (dim
, 1, false) == FAILURE
)
2893 /* dim_rank_check() does not apply here. */
2895 && dim
->expr_type
== EXPR_CONSTANT
2896 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
2897 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
2899 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
2900 "dimension index", gfc_current_intrinsic_arg
[1],
2901 gfc_current_intrinsic
, &dim
->where
);
2905 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
2908 if (scalar_check (ncopies
, 2) == FAILURE
)
2915 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2919 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
2921 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2924 if (scalar_check (unit
, 0) == FAILURE
)
2927 if (type_check (c
, 1, BT_CHARACTER
) == FAILURE
)
2929 if (kind_value_check (c
, 1, gfc_default_character_kind
) == FAILURE
)
2935 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2936 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
2937 || scalar_check (status
, 2) == FAILURE
)
2945 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
2947 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
2952 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
2954 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
2956 if (kind_value_check (c
, 0, gfc_default_character_kind
) == FAILURE
)
2962 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
2963 || kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
2964 || scalar_check (status
, 1) == FAILURE
)
2972 gfc_check_fgetput (gfc_expr
*c
)
2974 return gfc_check_fgetput_sub (c
, NULL
);
2979 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
2981 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2984 if (scalar_check (unit
, 0) == FAILURE
)
2987 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
2990 if (scalar_check (offset
, 1) == FAILURE
)
2993 if (type_check (whence
, 2, BT_INTEGER
) == FAILURE
)
2996 if (scalar_check (whence
, 2) == FAILURE
)
3002 if (type_check (status
, 3, BT_INTEGER
) == FAILURE
)
3005 if (kind_value_check (status
, 3, 4) == FAILURE
)
3008 if (scalar_check (status
, 3) == FAILURE
)
3017 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
3019 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3022 if (scalar_check (unit
, 0) == FAILURE
)
3025 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3026 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
3029 if (array_check (array
, 1) == FAILURE
)
3037 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
3039 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3042 if (scalar_check (unit
, 0) == FAILURE
)
3045 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3046 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3049 if (array_check (array
, 1) == FAILURE
)
3055 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3056 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
3059 if (scalar_check (status
, 2) == FAILURE
)
3067 gfc_check_ftell (gfc_expr
*unit
)
3069 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3072 if (scalar_check (unit
, 0) == FAILURE
)
3080 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
3082 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3085 if (scalar_check (unit
, 0) == FAILURE
)
3088 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
3091 if (scalar_check (offset
, 1) == FAILURE
)
3099 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
3101 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3103 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3106 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3107 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3110 if (array_check (array
, 1) == FAILURE
)
3118 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
3120 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3122 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3125 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3126 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3129 if (array_check (array
, 1) == FAILURE
)
3135 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3136 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3139 if (scalar_check (status
, 2) == FAILURE
)
3147 gfc_check_transfer (gfc_expr
*source ATTRIBUTE_UNUSED
,
3148 gfc_expr
*mold ATTRIBUTE_UNUSED
, gfc_expr
*size
)
3150 if (mold
->ts
.type
== BT_HOLLERITH
)
3152 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3153 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
3159 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
3162 if (scalar_check (size
, 2) == FAILURE
)
3165 if (nonoptional_check (size
, 2) == FAILURE
)
3174 gfc_check_transpose (gfc_expr
*matrix
)
3176 if (rank_check (matrix
, 0, 2) == FAILURE
)
3184 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3186 if (array_check (array
, 0) == FAILURE
)
3189 if (dim_check (dim
, 1, false) == FAILURE
)
3192 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
3195 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
3197 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
3198 "with KIND argument at %L",
3199 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3207 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
3211 if (rank_check (vector
, 0, 1) == FAILURE
)
3214 if (array_check (mask
, 1) == FAILURE
)
3217 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
3220 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
3223 if (mask
->expr_type
== EXPR_ARRAY
3224 && gfc_array_size (vector
, &vector_size
) == SUCCESS
)
3226 int mask_true_count
= 0;
3227 gfc_constructor
*mask_ctor
= mask
->value
.constructor
;
3230 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3232 mask_true_count
= 0;
3236 if (mask_ctor
->expr
->value
.logical
)
3239 mask_ctor
= mask_ctor
->next
;
3242 if (mpz_get_si (vector_size
) < mask_true_count
)
3244 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3245 "provide at least as many elements as there "
3246 "are .TRUE. values in '%s' (%ld/%d)",
3247 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
3248 &vector
->where
, gfc_current_intrinsic_arg
[1],
3249 mpz_get_si (vector_size
), mask_true_count
);
3253 mpz_clear (vector_size
);
3256 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
3258 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
3259 "the same rank as '%s' or be a scalar",
3260 gfc_current_intrinsic_arg
[2], gfc_current_intrinsic
,
3261 &field
->where
, gfc_current_intrinsic_arg
[1]);
3265 if (mask
->rank
== field
->rank
)
3268 for (i
= 0; i
< field
->rank
; i
++)
3269 if (! identical_dimen_shape (mask
, i
, field
, i
))
3271 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
3272 "must have identical shape.",
3273 gfc_current_intrinsic_arg
[2],
3274 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
3284 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3286 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
3289 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
3292 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
3295 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
3297 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
3298 "with KIND argument at %L",
3299 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3307 gfc_check_trim (gfc_expr
*x
)
3309 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
3312 if (scalar_check (x
, 0) == FAILURE
)
3320 gfc_check_ttynam (gfc_expr
*unit
)
3322 if (scalar_check (unit
, 0) == FAILURE
)
3325 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3332 /* Common check function for the half a dozen intrinsics that have a
3333 single real argument. */
3336 gfc_check_x (gfc_expr
*x
)
3338 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3345 /************* Check functions for intrinsic subroutines *************/
3348 gfc_check_cpu_time (gfc_expr
*time
)
3350 if (scalar_check (time
, 0) == FAILURE
)
3353 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
3356 if (variable_check (time
, 0) == FAILURE
)
3364 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
3365 gfc_expr
*zone
, gfc_expr
*values
)
3369 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
3371 if (kind_value_check (date
, 0, gfc_default_character_kind
) == FAILURE
)
3373 if (scalar_check (date
, 0) == FAILURE
)
3375 if (variable_check (date
, 0) == FAILURE
)
3381 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
3383 if (kind_value_check (time
, 1, gfc_default_character_kind
) == FAILURE
)
3385 if (scalar_check (time
, 1) == FAILURE
)
3387 if (variable_check (time
, 1) == FAILURE
)
3393 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
3395 if (kind_value_check (zone
, 2, gfc_default_character_kind
) == FAILURE
)
3397 if (scalar_check (zone
, 2) == FAILURE
)
3399 if (variable_check (zone
, 2) == FAILURE
)
3405 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
3407 if (array_check (values
, 3) == FAILURE
)
3409 if (rank_check (values
, 3, 1) == FAILURE
)
3411 if (variable_check (values
, 3) == FAILURE
)
3420 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
3421 gfc_expr
*to
, gfc_expr
*topos
)
3423 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
3426 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
3429 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
3432 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
3435 if (variable_check (to
, 3) == FAILURE
)
3438 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
3446 gfc_check_random_number (gfc_expr
*harvest
)
3448 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
3451 if (variable_check (harvest
, 0) == FAILURE
)
3459 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
3461 unsigned int nargs
= 0, kiss_size
;
3462 locus
*where
= NULL
;
3463 mpz_t put_size
, get_size
;
3464 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
3466 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
3468 /* Keep the number of bytes in sync with kiss_size in
3469 libgfortran/intrinsics/random.c. */
3470 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
3474 if (size
->expr_type
!= EXPR_VARIABLE
3475 || !size
->symtree
->n
.sym
->attr
.optional
)
3478 if (scalar_check (size
, 0) == FAILURE
)
3481 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
3484 if (variable_check (size
, 0) == FAILURE
)
3487 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
3493 if (put
->expr_type
!= EXPR_VARIABLE
3494 || !put
->symtree
->n
.sym
->attr
.optional
)
3497 where
= &put
->where
;
3500 if (array_check (put
, 1) == FAILURE
)
3503 if (rank_check (put
, 1, 1) == FAILURE
)
3506 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
3509 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
3512 if (gfc_array_size (put
, &put_size
) == SUCCESS
3513 && mpz_get_ui (put_size
) < kiss_size
)
3514 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3515 "too small (%i/%i)",
3516 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, where
,
3517 (int) mpz_get_ui (put_size
), kiss_size
);
3522 if (get
->expr_type
!= EXPR_VARIABLE
3523 || !get
->symtree
->n
.sym
->attr
.optional
)
3526 where
= &get
->where
;
3529 if (array_check (get
, 2) == FAILURE
)
3532 if (rank_check (get
, 2, 1) == FAILURE
)
3535 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
3538 if (variable_check (get
, 2) == FAILURE
)
3541 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
3544 if (gfc_array_size (get
, &get_size
) == SUCCESS
3545 && mpz_get_ui (get_size
) < kiss_size
)
3546 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3547 "too small (%i/%i)",
3548 gfc_current_intrinsic_arg
[2], gfc_current_intrinsic
, where
,
3549 (int) mpz_get_ui (get_size
), kiss_size
);
3552 /* RANDOM_SEED may not have more than one non-optional argument. */
3554 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
3561 gfc_check_second_sub (gfc_expr
*time
)
3563 if (scalar_check (time
, 0) == FAILURE
)
3566 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
3569 if (kind_value_check(time
, 0, 4) == FAILURE
)
3576 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3577 count, count_rate, and count_max are all optional arguments */
3580 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
3581 gfc_expr
*count_max
)
3585 if (scalar_check (count
, 0) == FAILURE
)
3588 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
3591 if (variable_check (count
, 0) == FAILURE
)
3595 if (count_rate
!= NULL
)
3597 if (scalar_check (count_rate
, 1) == FAILURE
)
3600 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
3603 if (variable_check (count_rate
, 1) == FAILURE
)
3607 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
3612 if (count_max
!= NULL
)
3614 if (scalar_check (count_max
, 2) == FAILURE
)
3617 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
3620 if (variable_check (count_max
, 2) == FAILURE
)
3624 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
3627 if (count_rate
!= NULL
3628 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
3637 gfc_check_irand (gfc_expr
*x
)
3642 if (scalar_check (x
, 0) == FAILURE
)
3645 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3648 if (kind_value_check(x
, 0, 4) == FAILURE
)
3656 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
3658 if (scalar_check (seconds
, 0) == FAILURE
)
3661 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
3664 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3666 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3667 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
3668 gfc_current_intrinsic
, &handler
->where
);
3672 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3678 if (scalar_check (status
, 2) == FAILURE
)
3681 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3684 if (kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
3692 gfc_check_rand (gfc_expr
*x
)
3697 if (scalar_check (x
, 0) == FAILURE
)
3700 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3703 if (kind_value_check(x
, 0, 4) == FAILURE
)
3711 gfc_check_srand (gfc_expr
*x
)
3713 if (scalar_check (x
, 0) == FAILURE
)
3716 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3719 if (kind_value_check(x
, 0, 4) == FAILURE
)
3727 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
3729 if (scalar_check (time
, 0) == FAILURE
)
3731 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
3734 if (type_check (result
, 1, BT_CHARACTER
) == FAILURE
)
3736 if (kind_value_check (result
, 1, gfc_default_character_kind
) == FAILURE
)
3744 gfc_check_dtime_etime (gfc_expr
*x
)
3746 if (array_check (x
, 0) == FAILURE
)
3749 if (rank_check (x
, 0, 1) == FAILURE
)
3752 if (variable_check (x
, 0) == FAILURE
)
3755 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3758 if (kind_value_check(x
, 0, 4) == FAILURE
)
3766 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
3768 if (array_check (values
, 0) == FAILURE
)
3771 if (rank_check (values
, 0, 1) == FAILURE
)
3774 if (variable_check (values
, 0) == FAILURE
)
3777 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
3780 if (kind_value_check(values
, 0, 4) == FAILURE
)
3783 if (scalar_check (time
, 1) == FAILURE
)
3786 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
3789 if (kind_value_check(time
, 1, 4) == FAILURE
)
3797 gfc_check_fdate_sub (gfc_expr
*date
)
3799 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
3801 if (kind_value_check (date
, 0, gfc_default_character_kind
) == FAILURE
)
3809 gfc_check_gerror (gfc_expr
*msg
)
3811 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3813 if (kind_value_check (msg
, 0, gfc_default_character_kind
) == FAILURE
)
3821 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
3823 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
3825 if (kind_value_check (cwd
, 0, gfc_default_character_kind
) == FAILURE
)
3831 if (scalar_check (status
, 1) == FAILURE
)
3834 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3842 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
3844 if (type_check (pos
, 0, BT_INTEGER
) == FAILURE
)
3847 if (pos
->ts
.kind
> gfc_default_integer_kind
)
3849 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3850 "not wider than the default kind (%d)",
3851 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
3852 &pos
->where
, gfc_default_integer_kind
);
3856 if (type_check (value
, 1, BT_CHARACTER
) == FAILURE
)
3858 if (kind_value_check (value
, 1, gfc_default_character_kind
) == FAILURE
)
3866 gfc_check_getlog (gfc_expr
*msg
)
3868 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3870 if (kind_value_check (msg
, 0, gfc_default_character_kind
) == FAILURE
)
3878 gfc_check_exit (gfc_expr
*status
)
3883 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
3886 if (scalar_check (status
, 0) == FAILURE
)
3894 gfc_check_flush (gfc_expr
*unit
)
3899 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3902 if (scalar_check (unit
, 0) == FAILURE
)
3910 gfc_check_free (gfc_expr
*i
)
3912 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
3915 if (scalar_check (i
, 0) == FAILURE
)
3923 gfc_check_hostnm (gfc_expr
*name
)
3925 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3927 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3935 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
3937 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3939 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3945 if (scalar_check (status
, 1) == FAILURE
)
3948 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3956 gfc_check_itime_idate (gfc_expr
*values
)
3958 if (array_check (values
, 0) == FAILURE
)
3961 if (rank_check (values
, 0, 1) == FAILURE
)
3964 if (variable_check (values
, 0) == FAILURE
)
3967 if (type_check (values
, 0, BT_INTEGER
) == FAILURE
)
3970 if (kind_value_check(values
, 0, gfc_default_integer_kind
) == FAILURE
)
3978 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
3980 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
3983 if (kind_value_check(time
, 0, gfc_default_integer_kind
) == FAILURE
)
3986 if (scalar_check (time
, 0) == FAILURE
)
3989 if (array_check (values
, 1) == FAILURE
)
3992 if (rank_check (values
, 1, 1) == FAILURE
)
3995 if (variable_check (values
, 1) == FAILURE
)
3998 if (type_check (values
, 1, BT_INTEGER
) == FAILURE
)
4001 if (kind_value_check(values
, 1, gfc_default_integer_kind
) == FAILURE
)
4009 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
4011 if (scalar_check (unit
, 0) == FAILURE
)
4014 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4017 if (type_check (name
, 1, BT_CHARACTER
) == FAILURE
)
4019 if (kind_value_check (name
, 1, gfc_default_character_kind
) == FAILURE
)
4027 gfc_check_isatty (gfc_expr
*unit
)
4032 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4035 if (scalar_check (unit
, 0) == FAILURE
)
4043 gfc_check_isnan (gfc_expr
*x
)
4045 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
4053 gfc_check_perror (gfc_expr
*string
)
4055 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
4057 if (kind_value_check (string
, 0, gfc_default_character_kind
) == FAILURE
)
4065 gfc_check_umask (gfc_expr
*mask
)
4067 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
4070 if (scalar_check (mask
, 0) == FAILURE
)
4078 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
4080 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
4083 if (scalar_check (mask
, 0) == FAILURE
)
4089 if (scalar_check (old
, 1) == FAILURE
)
4092 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
4100 gfc_check_unlink (gfc_expr
*name
)
4102 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4104 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4112 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
4114 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4116 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4122 if (scalar_check (status
, 1) == FAILURE
)
4125 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
4133 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
4135 if (scalar_check (number
, 0) == FAILURE
)
4138 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
4141 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
4143 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4144 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
4145 gfc_current_intrinsic
, &handler
->where
);
4149 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
4157 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
4159 if (scalar_check (number
, 0) == FAILURE
)
4162 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
4165 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
4167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4168 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
4169 gfc_current_intrinsic
, &handler
->where
);
4173 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
4179 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
4182 if (scalar_check (status
, 2) == FAILURE
)
4190 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
4192 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
4194 if (kind_value_check (cmd
, 0, gfc_default_character_kind
) == FAILURE
)
4197 if (scalar_check (status
, 1) == FAILURE
)
4200 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
4203 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)
4210 /* This is used for the GNU intrinsics AND, OR and XOR. */
4212 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
4214 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
4216 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4217 "or LOGICAL", gfc_current_intrinsic_arg
[0],
4218 gfc_current_intrinsic
, &i
->where
);
4222 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
4224 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4225 "or LOGICAL", gfc_current_intrinsic_arg
[1],
4226 gfc_current_intrinsic
, &j
->where
);
4230 if (i
->ts
.type
!= j
->ts
.type
)
4232 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
4233 "have the same type", gfc_current_intrinsic_arg
[0],
4234 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
4239 if (scalar_check (i
, 0) == FAILURE
)
4242 if (scalar_check (j
, 1) == FAILURE
)