2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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
)
342 if (dim
->expr_type
!= EXPR_CONSTANT
|| array
->expr_type
!= EXPR_VARIABLE
)
345 ar
= gfc_find_array_ref (array
);
347 if (ar
->as
->type
== AS_ASSUMED_SIZE
349 && ar
->type
!= AR_ELEMENT
350 && ar
->type
!= AR_SECTION
)
353 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
354 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
356 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
357 "dimension index", gfc_current_intrinsic
, &dim
->where
);
366 /* Compare the size of a along dimension ai with the size of b along
367 dimension bi, returning 0 if they are known not to be identical,
368 and 1 if they are identical, or if this cannot be determined. */
371 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
373 mpz_t a_size
, b_size
;
376 gcc_assert (a
->rank
> ai
);
377 gcc_assert (b
->rank
> bi
);
381 if (gfc_array_dimen_size (a
, ai
, &a_size
) == SUCCESS
)
383 if (gfc_array_dimen_size (b
, bi
, &b_size
) == SUCCESS
)
385 if (mpz_cmp (a_size
, b_size
) != 0)
396 /* Check whether two character expressions have the same length;
397 returns SUCCESS if they have or if the length cannot be determined. */
400 check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
405 if (a
->ts
.cl
&& a
->ts
.cl
->length
406 && a
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
407 len_a
= mpz_get_si (a
->ts
.cl
->length
->value
.integer
);
408 else if (a
->expr_type
== EXPR_CONSTANT
409 && (a
->ts
.cl
== NULL
|| a
->ts
.cl
->length
== NULL
))
410 len_a
= a
->value
.character
.length
;
414 if (b
->ts
.cl
&& b
->ts
.cl
->length
415 && b
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
416 len_b
= mpz_get_si (b
->ts
.cl
->length
->value
.integer
);
417 else if (b
->expr_type
== EXPR_CONSTANT
418 && (b
->ts
.cl
== NULL
|| b
->ts
.cl
->length
== NULL
))
419 len_b
= b
->value
.character
.length
;
426 gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
427 "at %L", len_a
, len_b
, name
, &a
->where
);
432 /***** Check functions *****/
434 /* Check subroutine suitable for intrinsics taking a real argument and
435 a kind argument for the result. */
438 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
440 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
442 if (kind_check (kind
, 1, type
) == FAILURE
)
449 /* Check subroutine suitable for ceiling, floor and nint. */
452 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
454 return check_a_kind (a
, kind
, BT_INTEGER
);
458 /* Check subroutine suitable for aint, anint. */
461 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
463 return check_a_kind (a
, kind
, BT_REAL
);
468 gfc_check_abs (gfc_expr
*a
)
470 if (numeric_check (a
, 0) == FAILURE
)
478 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
480 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
482 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
490 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
492 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
493 || scalar_check (name
, 0) == FAILURE
)
496 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
497 || scalar_check (mode
, 1) == FAILURE
)
505 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
507 if (logical_array_check (mask
, 0) == FAILURE
)
510 if (dim_check (dim
, 1, false) == FAILURE
)
518 gfc_check_allocated (gfc_expr
*array
)
520 symbol_attribute attr
;
522 if (variable_check (array
, 0) == FAILURE
)
525 attr
= gfc_variable_attr (array
, NULL
);
526 if (!attr
.allocatable
)
528 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
529 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
534 if (array_check (array
, 0) == FAILURE
)
541 /* Common check function where the first argument must be real or
542 integer and the second argument must be the same as the first. */
545 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
547 if (int_or_real_check (a
, 0) == FAILURE
)
550 if (a
->ts
.type
!= p
->ts
.type
)
552 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
553 "have the same type", gfc_current_intrinsic_arg
[0],
554 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
559 if (a
->ts
.kind
!= p
->ts
.kind
)
561 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
562 &p
->where
) == FAILURE
)
571 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
573 if (double_check (x
, 0) == FAILURE
|| double_check (y
, 1) == FAILURE
)
581 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
583 symbol_attribute attr
;
588 where
= &pointer
->where
;
590 if (pointer
->expr_type
== EXPR_VARIABLE
)
591 attr
= gfc_variable_attr (pointer
, NULL
);
592 else if (pointer
->expr_type
== EXPR_FUNCTION
)
593 attr
= pointer
->symtree
->n
.sym
->attr
;
594 else if (pointer
->expr_type
== EXPR_NULL
)
597 gcc_assert (0); /* Pointer must be a variable or a function. */
601 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
602 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
607 /* Target argument is optional. */
611 where
= &target
->where
;
612 if (target
->expr_type
== EXPR_NULL
)
615 if (target
->expr_type
== EXPR_VARIABLE
)
616 attr
= gfc_variable_attr (target
, NULL
);
617 else if (target
->expr_type
== EXPR_FUNCTION
)
618 attr
= target
->symtree
->n
.sym
->attr
;
621 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
622 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg
[1],
623 gfc_current_intrinsic
, &target
->where
);
627 if (!attr
.pointer
&& !attr
.target
)
629 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
630 "or a TARGET", gfc_current_intrinsic_arg
[1],
631 gfc_current_intrinsic
, &target
->where
);
636 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
638 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
640 if (target
->rank
> 0)
642 for (i
= 0; i
< target
->rank
; i
++)
643 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
645 gfc_error ("Array section with a vector subscript at %L shall not "
646 "be the target of a pointer",
656 gfc_error ("NULL pointer at %L is not permitted as actual argument "
657 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
664 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
666 if (type_check (y
, 0, BT_REAL
) == FAILURE
)
668 if (same_type_check (y
, 0, x
, 1) == FAILURE
)
675 /* BESJN and BESYN functions. */
678 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
680 if (type_check (n
, 0, BT_INTEGER
) == FAILURE
)
683 if (type_check (x
, 1, BT_REAL
) == FAILURE
)
691 gfc_check_btest (gfc_expr
*i
, gfc_expr
*pos
)
693 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
695 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
703 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
705 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
707 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
715 gfc_check_chdir (gfc_expr
*dir
)
717 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
725 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
727 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
733 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
736 if (scalar_check (status
, 1) == FAILURE
)
744 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
746 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
749 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
757 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
759 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
762 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
768 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
771 if (scalar_check (status
, 2) == FAILURE
)
779 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
781 if (numeric_check (x
, 0) == FAILURE
)
786 if (numeric_check (y
, 1) == FAILURE
)
789 if (x
->ts
.type
== BT_COMPLEX
)
791 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
792 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
793 gfc_current_intrinsic
, &y
->where
);
798 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
806 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
808 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
810 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
811 "or REAL", gfc_current_intrinsic_arg
[0],
812 gfc_current_intrinsic
, &x
->where
);
815 if (scalar_check (x
, 0) == FAILURE
)
818 if (y
->ts
.type
!= BT_INTEGER
&& y
->ts
.type
!= BT_REAL
)
820 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
821 "or REAL", gfc_current_intrinsic_arg
[1],
822 gfc_current_intrinsic
, &y
->where
);
825 if (scalar_check (y
, 1) == FAILURE
)
833 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
835 if (logical_array_check (mask
, 0) == FAILURE
)
837 if (dim_check (dim
, 1, false) == FAILURE
)
839 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
841 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
842 "with KIND argument at %L",
843 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
851 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
853 if (array_check (array
, 0) == FAILURE
)
856 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
859 if (array
->rank
== 1)
861 if (scalar_check (shift
, 1) == FAILURE
)
866 /* TODO: more requirements on shift parameter. */
869 if (dim_check (dim
, 2, true) == FAILURE
)
877 gfc_check_ctime (gfc_expr
*time
)
879 if (scalar_check (time
, 0) == FAILURE
)
882 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
889 try gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
891 if (double_check (y
, 0) == FAILURE
|| double_check (x
, 1) == FAILURE
)
898 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
900 if (numeric_check (x
, 0) == FAILURE
)
905 if (numeric_check (y
, 1) == FAILURE
)
908 if (x
->ts
.type
== BT_COMPLEX
)
910 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
911 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
912 gfc_current_intrinsic
, &y
->where
);
922 gfc_check_dble (gfc_expr
*x
)
924 if (numeric_check (x
, 0) == FAILURE
)
932 gfc_check_digits (gfc_expr
*x
)
934 if (int_or_real_check (x
, 0) == FAILURE
)
942 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
944 switch (vector_a
->ts
.type
)
947 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
954 if (numeric_check (vector_b
, 1) == FAILURE
)
959 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
960 "or LOGICAL", gfc_current_intrinsic_arg
[0],
961 gfc_current_intrinsic
, &vector_a
->where
);
965 if (rank_check (vector_a
, 0, 1) == FAILURE
)
968 if (rank_check (vector_b
, 1, 1) == FAILURE
)
971 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
973 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
974 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0],
975 gfc_current_intrinsic_arg
[1], &vector_a
->where
);
984 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
986 if (type_check (x
, 0, BT_REAL
) == FAILURE
987 || type_check (y
, 1, BT_REAL
) == FAILURE
)
990 if (x
->ts
.kind
!= gfc_default_real_kind
)
992 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
993 "real", gfc_current_intrinsic_arg
[0],
994 gfc_current_intrinsic
, &x
->where
);
998 if (y
->ts
.kind
!= gfc_default_real_kind
)
1000 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1001 "real", gfc_current_intrinsic_arg
[1],
1002 gfc_current_intrinsic
, &y
->where
);
1011 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1014 if (array_check (array
, 0) == FAILURE
)
1017 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1020 if (array
->rank
== 1)
1022 if (scalar_check (shift
, 2) == FAILURE
)
1027 /* TODO: more weird restrictions on shift. */
1030 if (boundary
!= NULL
)
1032 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
1035 /* TODO: more restrictions on boundary. */
1038 if (dim_check (dim
, 4, true) == FAILURE
)
1045 /* A single complex argument. */
1048 gfc_check_fn_c (gfc_expr
*a
)
1050 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
1057 /* A single real argument. */
1060 gfc_check_fn_r (gfc_expr
*a
)
1062 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
1068 /* A single double argument. */
1071 gfc_check_fn_d (gfc_expr
*a
)
1073 if (double_check (a
, 0) == FAILURE
)
1079 /* A single real or complex argument. */
1082 gfc_check_fn_rc (gfc_expr
*a
)
1084 if (real_or_complex_check (a
, 0) == FAILURE
)
1092 gfc_check_fnum (gfc_expr
*unit
)
1094 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1097 if (scalar_check (unit
, 0) == FAILURE
)
1105 gfc_check_huge (gfc_expr
*x
)
1107 if (int_or_real_check (x
, 0) == FAILURE
)
1115 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
1117 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1119 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1126 /* Check that the single argument is an integer. */
1129 gfc_check_i (gfc_expr
*i
)
1131 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1139 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1141 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1144 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1147 if (i
->ts
.kind
!= j
->ts
.kind
)
1149 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1150 &i
->where
) == FAILURE
)
1159 gfc_check_ibclr (gfc_expr
*i
, gfc_expr
*pos
)
1161 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1164 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1172 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1174 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1177 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1180 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1188 gfc_check_ibset (gfc_expr
*i
, gfc_expr
*pos
)
1190 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1193 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1201 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1205 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
1208 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1211 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1212 "with KIND argument at %L",
1213 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1216 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1222 /* Substring references don't have the charlength set. */
1224 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1227 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1231 /* Check that the argument is length one. Non-constant lengths
1232 can't be checked here, so assume they are ok. */
1233 if (c
->ts
.cl
&& c
->ts
.cl
->length
)
1235 /* If we already have a length for this expression then use it. */
1236 if (c
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1238 i
= mpz_get_si (c
->ts
.cl
->length
->value
.integer
);
1245 start
= ref
->u
.ss
.start
;
1246 end
= ref
->u
.ss
.end
;
1249 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1250 || start
->expr_type
!= EXPR_CONSTANT
)
1253 i
= mpz_get_si (end
->value
.integer
) + 1
1254 - mpz_get_si (start
->value
.integer
);
1262 gfc_error ("Argument of %s at %L must be of length one",
1263 gfc_current_intrinsic
, &c
->where
);
1272 gfc_check_idnint (gfc_expr
*a
)
1274 if (double_check (a
, 0) == FAILURE
)
1282 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
1284 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1287 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1290 if (i
->ts
.kind
!= j
->ts
.kind
)
1292 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1293 &i
->where
) == FAILURE
)
1302 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
1305 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1306 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1309 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1312 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
1314 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1315 "with KIND argument at %L",
1316 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1319 if (string
->ts
.kind
!= substring
->ts
.kind
)
1321 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1322 "kind as '%s'", gfc_current_intrinsic_arg
[1],
1323 gfc_current_intrinsic
, &substring
->where
,
1324 gfc_current_intrinsic_arg
[0]);
1333 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
1335 if (numeric_check (x
, 0) == FAILURE
)
1338 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1346 gfc_check_intconv (gfc_expr
*x
)
1348 if (numeric_check (x
, 0) == FAILURE
)
1356 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
1358 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1361 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1364 if (i
->ts
.kind
!= j
->ts
.kind
)
1366 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1367 &i
->where
) == FAILURE
)
1376 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
1378 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1379 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1387 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1389 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1390 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1393 if (size
!= NULL
&& type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1401 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
1403 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1406 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1414 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
1416 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1419 if (scalar_check (pid
, 0) == FAILURE
)
1422 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1425 if (scalar_check (sig
, 1) == FAILURE
)
1431 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1434 if (scalar_check (status
, 2) == FAILURE
)
1442 gfc_check_kind (gfc_expr
*x
)
1444 if (x
->ts
.type
== BT_DERIVED
)
1446 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1447 "non-derived type", gfc_current_intrinsic_arg
[0],
1448 gfc_current_intrinsic
, &x
->where
);
1457 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1459 if (array_check (array
, 0) == FAILURE
)
1464 if (dim_check (dim
, 1, false) == FAILURE
)
1467 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
1471 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
1473 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1474 "with KIND argument at %L",
1475 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1483 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
1485 if (type_check (s
, 0, BT_CHARACTER
) == FAILURE
)
1488 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1490 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1491 "with KIND argument at %L",
1492 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1500 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
1502 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1505 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1513 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
1515 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1518 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1524 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1527 if (scalar_check (status
, 2) == FAILURE
)
1535 gfc_check_loc (gfc_expr
*expr
)
1537 return variable_check (expr
, 0);
1542 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
1544 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1547 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1555 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
1557 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1560 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1566 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1569 if (scalar_check (status
, 2) == FAILURE
)
1577 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
1579 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
1581 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
1588 /* Min/max family. */
1591 min_max_args (gfc_actual_arglist
*arg
)
1593 if (arg
== NULL
|| arg
->next
== NULL
)
1595 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1596 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1605 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
1607 gfc_actual_arglist
*arg
, *tmp
;
1612 if (min_max_args (arglist
) == FAILURE
)
1615 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
1618 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
1620 if (x
->ts
.type
== type
)
1622 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type "
1623 "kinds at %L", &x
->where
) == FAILURE
)
1628 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1629 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
1630 gfc_basic_typename (type
), kind
);
1635 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
1638 snprintf (buffer
, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
1639 m
, n
, gfc_current_intrinsic
);
1640 if (gfc_check_conformance (buffer
, tmp
->expr
, x
) == FAILURE
)
1650 gfc_check_min_max (gfc_actual_arglist
*arg
)
1654 if (min_max_args (arg
) == FAILURE
)
1659 if (x
->ts
.type
== BT_CHARACTER
)
1661 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1662 "with CHARACTER argument at %L",
1663 gfc_current_intrinsic
, &x
->where
) == FAILURE
)
1666 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
1668 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1669 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
1673 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
1678 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
1680 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
1685 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
1687 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
1692 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
1694 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
1698 /* End of min/max family. */
1701 gfc_check_malloc (gfc_expr
*size
)
1703 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
1706 if (scalar_check (size
, 0) == FAILURE
)
1714 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
1716 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
1718 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1719 "or LOGICAL", gfc_current_intrinsic_arg
[0],
1720 gfc_current_intrinsic
, &matrix_a
->where
);
1724 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
1726 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1727 "or LOGICAL", gfc_current_intrinsic_arg
[1],
1728 gfc_current_intrinsic
, &matrix_b
->where
);
1732 switch (matrix_a
->rank
)
1735 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
1737 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1738 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
1740 gfc_error ("Different shape on dimension 1 for arguments '%s' "
1741 "and '%s' at %L for intrinsic matmul",
1742 gfc_current_intrinsic_arg
[0],
1743 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1749 if (matrix_b
->rank
!= 2)
1751 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
1754 /* matrix_b has rank 1 or 2 here. Common check for the cases
1755 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1756 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1757 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
1759 gfc_error ("Different shape on dimension 2 for argument '%s' and "
1760 "dimension 1 for argument '%s' at %L for intrinsic "
1761 "matmul", gfc_current_intrinsic_arg
[0],
1762 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1768 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1769 "1 or 2", gfc_current_intrinsic_arg
[0],
1770 gfc_current_intrinsic
, &matrix_a
->where
);
1778 /* Whoever came up with this interface was probably on something.
1779 The possibilities for the occupation of the second and third
1786 NULL MASK minloc(array, mask=m)
1789 I.e. in the case of minloc(array,mask), mask will be in the second
1790 position of the argument list and we'll have to fix that up. */
1793 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
1795 gfc_expr
*a
, *m
, *d
;
1798 if (int_or_real_check (a
, 0) == FAILURE
|| array_check (a
, 0) == FAILURE
)
1802 m
= ap
->next
->next
->expr
;
1804 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1805 && ap
->next
->name
== NULL
)
1809 ap
->next
->expr
= NULL
;
1810 ap
->next
->next
->expr
= m
;
1813 if (d
&& dim_check (d
, 1, false) == FAILURE
)
1816 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1819 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1825 snprintf (buffer
, 80, "arguments '%s' and '%s' for intrinsic %s",
1826 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1827 gfc_current_intrinsic
);
1828 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1836 /* Similar to minloc/maxloc, the argument list might need to be
1837 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1838 difference is that MINLOC/MAXLOC take an additional KIND argument.
1839 The possibilities are:
1845 NULL MASK minval(array, mask=m)
1848 I.e. in the case of minval(array,mask), mask will be in the second
1849 position of the argument list and we'll have to fix that up. */
1852 check_reduction (gfc_actual_arglist
*ap
)
1854 gfc_expr
*a
, *m
, *d
;
1858 m
= ap
->next
->next
->expr
;
1860 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1861 && ap
->next
->name
== NULL
)
1865 ap
->next
->expr
= NULL
;
1866 ap
->next
->next
->expr
= m
;
1869 if (d
&& dim_check (d
, 1, false) == FAILURE
)
1872 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1875 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1881 snprintf (buffer
, 80, "arguments '%s' and '%s' for intrinsic %s",
1882 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1883 gfc_current_intrinsic
);
1884 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1893 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
1895 if (int_or_real_check (ap
->expr
, 0) == FAILURE
1896 || array_check (ap
->expr
, 0) == FAILURE
)
1899 return check_reduction (ap
);
1904 gfc_check_product_sum (gfc_actual_arglist
*ap
)
1906 if (numeric_check (ap
->expr
, 0) == FAILURE
1907 || array_check (ap
->expr
, 0) == FAILURE
)
1910 return check_reduction (ap
);
1915 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
1917 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
1920 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
1923 if (tsource
->ts
.type
== BT_CHARACTER
)
1924 return check_same_strlen (tsource
, fsource
, "MERGE");
1931 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
1933 symbol_attribute attr
;
1935 if (variable_check (from
, 0) == FAILURE
)
1938 if (array_check (from
, 0) == FAILURE
)
1941 attr
= gfc_variable_attr (from
, NULL
);
1942 if (!attr
.allocatable
)
1944 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1945 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
1950 if (variable_check (to
, 0) == FAILURE
)
1953 if (array_check (to
, 0) == FAILURE
)
1956 attr
= gfc_variable_attr (to
, NULL
);
1957 if (!attr
.allocatable
)
1959 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1960 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
1965 if (same_type_check (from
, 0, to
, 1) == FAILURE
)
1968 if (to
->rank
!= from
->rank
)
1970 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1971 "have the same rank %d/%d", gfc_current_intrinsic_arg
[0],
1972 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
1973 &to
->where
, from
->rank
, to
->rank
);
1977 if (to
->ts
.kind
!= from
->ts
.kind
)
1979 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1980 "be of the same kind %d/%d", gfc_current_intrinsic_arg
[0],
1981 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
1982 &to
->where
, from
->ts
.kind
, to
->ts
.kind
);
1991 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
1993 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1996 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
2004 gfc_check_new_line (gfc_expr
*a
)
2006 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
2014 gfc_check_null (gfc_expr
*mold
)
2016 symbol_attribute attr
;
2021 if (variable_check (mold
, 0) == FAILURE
)
2024 attr
= gfc_variable_attr (mold
, NULL
);
2028 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2029 gfc_current_intrinsic_arg
[0],
2030 gfc_current_intrinsic
, &mold
->where
);
2039 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
2043 if (array_check (array
, 0) == FAILURE
)
2046 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2049 snprintf (buffer
, 80, "arguments '%s' and '%s' for intrinsic '%s'",
2050 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[1],
2051 gfc_current_intrinsic
);
2052 if (gfc_check_conformance (buffer
, array
, mask
) == FAILURE
)
2057 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
2060 if (rank_check (vector
, 2, 1) == FAILURE
)
2063 /* TODO: More constraints here. */
2071 gfc_check_precision (gfc_expr
*x
)
2073 if (x
->ts
.type
!= BT_REAL
&& x
->ts
.type
!= BT_COMPLEX
)
2075 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2076 "REAL or COMPLEX", gfc_current_intrinsic_arg
[0],
2077 gfc_current_intrinsic
, &x
->where
);
2086 gfc_check_present (gfc_expr
*a
)
2090 if (variable_check (a
, 0) == FAILURE
)
2093 sym
= a
->symtree
->n
.sym
;
2094 if (!sym
->attr
.dummy
)
2096 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2097 "dummy variable", gfc_current_intrinsic_arg
[0],
2098 gfc_current_intrinsic
, &a
->where
);
2102 if (!sym
->attr
.optional
)
2104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2105 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg
[0],
2106 gfc_current_intrinsic
, &a
->where
);
2110 /* 13.14.82 PRESENT(A)
2112 Argument. A shall be the name of an optional dummy argument that is
2113 accessible in the subprogram in which the PRESENT function reference
2117 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
2118 && a
->ref
->u
.ar
.type
== AR_FULL
))
2120 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2121 "subobject of '%s'", gfc_current_intrinsic_arg
[0],
2122 gfc_current_intrinsic
, &a
->where
, sym
->name
);
2131 gfc_check_radix (gfc_expr
*x
)
2133 if (int_or_real_check (x
, 0) == FAILURE
)
2141 gfc_check_range (gfc_expr
*x
)
2143 if (numeric_check (x
, 0) == FAILURE
)
2150 /* real, float, sngl. */
2152 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
2154 if (numeric_check (a
, 0) == FAILURE
)
2157 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
2165 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
2167 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2170 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2178 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2180 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2183 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2189 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2192 if (scalar_check (status
, 2) == FAILURE
)
2200 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
2202 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2205 if (scalar_check (x
, 0) == FAILURE
)
2208 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
2211 if (scalar_check (y
, 1) == FAILURE
)
2219 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
2220 gfc_expr
*pad
, gfc_expr
*order
)
2226 if (array_check (source
, 0) == FAILURE
)
2229 if (rank_check (shape
, 1, 1) == FAILURE
)
2232 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
2235 if (gfc_array_size (shape
, &size
) != SUCCESS
)
2237 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2238 "array of constant size", &shape
->where
);
2242 m
= mpz_cmp_ui (size
, GFC_MAX_DIMENSIONS
);
2247 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2248 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
2254 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
2256 if (array_check (pad
, 2) == FAILURE
)
2260 if (order
!= NULL
&& array_check (order
, 3) == FAILURE
)
2263 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
2264 && gfc_is_constant_expr (shape
)
2265 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
2266 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
2268 /* Check the match in size between source and destination. */
2269 if (gfc_array_size (source
, &nelems
) == SUCCESS
)
2274 c
= shape
->value
.constructor
;
2275 mpz_init_set_ui (size
, 1);
2276 for (; c
; c
= c
->next
)
2277 mpz_mul (size
, size
, c
->expr
->value
.integer
);
2279 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
2285 gfc_error ("Without padding, there are not enough elements "
2286 "in the intrinsic RESHAPE source at %L to match "
2287 "the shape", &source
->where
);
2298 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
2300 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2303 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2311 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
2313 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2316 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
2319 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2322 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
2324 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2325 "with KIND argument at %L",
2326 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2329 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2337 gfc_check_secnds (gfc_expr
*r
)
2339 if (type_check (r
, 0, BT_REAL
) == FAILURE
)
2342 if (kind_value_check (r
, 0, 4) == FAILURE
)
2345 if (scalar_check (r
, 0) == FAILURE
)
2353 gfc_check_selected_char_kind (gfc_expr
*name
)
2355 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2358 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
2361 if (scalar_check (name
, 0) == FAILURE
)
2369 gfc_check_selected_int_kind (gfc_expr
*r
)
2371 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
2374 if (scalar_check (r
, 0) == FAILURE
)
2382 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
)
2384 if (p
== NULL
&& r
== NULL
)
2386 gfc_error ("Missing arguments to %s intrinsic at %L",
2387 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2392 if (p
!= NULL
&& type_check (p
, 0, BT_INTEGER
) == FAILURE
)
2395 if (r
!= NULL
&& type_check (r
, 1, BT_INTEGER
) == FAILURE
)
2403 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
2405 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2408 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2416 gfc_check_shape (gfc_expr
*source
)
2420 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
2423 ar
= gfc_find_array_ref (source
);
2425 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
2427 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2428 "an assumed size array", &source
->where
);
2437 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
2439 if (int_or_real_check (a
, 0) == FAILURE
)
2442 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
2450 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2452 if (array_check (array
, 0) == FAILURE
)
2457 if (dim_check (dim
, 1, true) == FAILURE
)
2460 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2464 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2466 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2467 "with KIND argument at %L",
2468 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2477 gfc_check_sizeof (gfc_expr
*arg ATTRIBUTE_UNUSED
)
2484 gfc_check_sleep_sub (gfc_expr
*seconds
)
2486 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
2489 if (scalar_check (seconds
, 0) == FAILURE
)
2497 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
2499 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
2501 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2502 "than rank %d", gfc_current_intrinsic_arg
[0],
2503 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
2511 if (dim_check (dim
, 1, false) == FAILURE
)
2514 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
2517 if (scalar_check (ncopies
, 2) == FAILURE
)
2524 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2528 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
2530 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2533 if (scalar_check (unit
, 0) == FAILURE
)
2536 if (type_check (c
, 1, BT_CHARACTER
) == FAILURE
)
2542 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2543 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
2544 || scalar_check (status
, 2) == FAILURE
)
2552 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
2554 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
2559 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
2561 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
2567 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
2568 || kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
2569 || scalar_check (status
, 1) == FAILURE
)
2577 gfc_check_fgetput (gfc_expr
*c
)
2579 return gfc_check_fgetput_sub (c
, NULL
);
2584 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
2586 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2589 if (scalar_check (unit
, 0) == FAILURE
)
2592 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
2595 if (scalar_check (offset
, 1) == FAILURE
)
2598 if (type_check (whence
, 2, BT_INTEGER
) == FAILURE
)
2601 if (scalar_check (whence
, 2) == FAILURE
)
2607 if (type_check (status
, 3, BT_INTEGER
) == FAILURE
)
2610 if (kind_value_check (status
, 3, 4) == FAILURE
)
2613 if (scalar_check (status
, 3) == FAILURE
)
2622 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
2624 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2627 if (scalar_check (unit
, 0) == FAILURE
)
2630 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2631 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
2634 if (array_check (array
, 1) == FAILURE
)
2642 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
2644 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2647 if (scalar_check (unit
, 0) == FAILURE
)
2650 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2651 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2654 if (array_check (array
, 1) == FAILURE
)
2660 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2661 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
2664 if (scalar_check (status
, 2) == FAILURE
)
2672 gfc_check_ftell (gfc_expr
*unit
)
2674 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2677 if (scalar_check (unit
, 0) == FAILURE
)
2685 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
2687 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2690 if (scalar_check (unit
, 0) == FAILURE
)
2693 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
2696 if (scalar_check (offset
, 1) == FAILURE
)
2704 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
2706 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2709 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2710 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2713 if (array_check (array
, 1) == FAILURE
)
2721 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
2723 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2726 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2727 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2730 if (array_check (array
, 1) == FAILURE
)
2736 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2737 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2740 if (scalar_check (status
, 2) == FAILURE
)
2748 gfc_check_transfer (gfc_expr
*source ATTRIBUTE_UNUSED
,
2749 gfc_expr
*mold ATTRIBUTE_UNUSED
, gfc_expr
*size
)
2751 if (mold
->ts
.type
== BT_HOLLERITH
)
2753 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
2754 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
2760 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
2763 if (scalar_check (size
, 2) == FAILURE
)
2766 if (nonoptional_check (size
, 2) == FAILURE
)
2775 gfc_check_transpose (gfc_expr
*matrix
)
2777 if (rank_check (matrix
, 0, 2) == FAILURE
)
2785 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2787 if (array_check (array
, 0) == FAILURE
)
2792 if (dim_check (dim
, 1, false) == FAILURE
)
2795 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2799 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2801 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2802 "with KIND argument at %L",
2803 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2811 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
2813 if (rank_check (vector
, 0, 1) == FAILURE
)
2816 if (array_check (mask
, 1) == FAILURE
)
2819 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2822 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
2830 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
2832 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2835 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2838 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2841 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
2843 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2844 "with KIND argument at %L",
2845 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2853 gfc_check_trim (gfc_expr
*x
)
2855 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2858 if (scalar_check (x
, 0) == FAILURE
)
2866 gfc_check_ttynam (gfc_expr
*unit
)
2868 if (scalar_check (unit
, 0) == FAILURE
)
2871 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2878 /* Common check function for the half a dozen intrinsics that have a
2879 single real argument. */
2882 gfc_check_x (gfc_expr
*x
)
2884 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2891 /************* Check functions for intrinsic subroutines *************/
2894 gfc_check_cpu_time (gfc_expr
*time
)
2896 if (scalar_check (time
, 0) == FAILURE
)
2899 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2902 if (variable_check (time
, 0) == FAILURE
)
2910 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
2911 gfc_expr
*zone
, gfc_expr
*values
)
2915 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
2917 if (scalar_check (date
, 0) == FAILURE
)
2919 if (variable_check (date
, 0) == FAILURE
)
2925 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
2927 if (scalar_check (time
, 1) == FAILURE
)
2929 if (variable_check (time
, 1) == FAILURE
)
2935 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
2937 if (scalar_check (zone
, 2) == FAILURE
)
2939 if (variable_check (zone
, 2) == FAILURE
)
2945 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
2947 if (array_check (values
, 3) == FAILURE
)
2949 if (rank_check (values
, 3, 1) == FAILURE
)
2951 if (variable_check (values
, 3) == FAILURE
)
2960 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
2961 gfc_expr
*to
, gfc_expr
*topos
)
2963 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
2966 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
2969 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
2972 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
2975 if (variable_check (to
, 3) == FAILURE
)
2978 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
2986 gfc_check_random_number (gfc_expr
*harvest
)
2988 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
2991 if (variable_check (harvest
, 0) == FAILURE
)
2999 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
3001 unsigned int nargs
= 0;
3002 locus
*where
= NULL
;
3006 if (size
->expr_type
!= EXPR_VARIABLE
3007 || !size
->symtree
->n
.sym
->attr
.optional
)
3010 if (scalar_check (size
, 0) == FAILURE
)
3013 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
3016 if (variable_check (size
, 0) == FAILURE
)
3019 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
3025 if (put
->expr_type
!= EXPR_VARIABLE
3026 || !put
->symtree
->n
.sym
->attr
.optional
)
3029 where
= &put
->where
;
3032 if (array_check (put
, 1) == FAILURE
)
3035 if (rank_check (put
, 1, 1) == FAILURE
)
3038 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
3041 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
3047 if (get
->expr_type
!= EXPR_VARIABLE
3048 || !get
->symtree
->n
.sym
->attr
.optional
)
3051 where
= &get
->where
;
3054 if (array_check (get
, 2) == FAILURE
)
3057 if (rank_check (get
, 2, 1) == FAILURE
)
3060 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
3063 if (variable_check (get
, 2) == FAILURE
)
3066 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
3070 /* RANDOM_SEED may not have more than one non-optional argument. */
3072 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
3079 gfc_check_second_sub (gfc_expr
*time
)
3081 if (scalar_check (time
, 0) == FAILURE
)
3084 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
3087 if (kind_value_check(time
, 0, 4) == FAILURE
)
3094 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3095 count, count_rate, and count_max are all optional arguments */
3098 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
3099 gfc_expr
*count_max
)
3103 if (scalar_check (count
, 0) == FAILURE
)
3106 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
3109 if (variable_check (count
, 0) == FAILURE
)
3113 if (count_rate
!= NULL
)
3115 if (scalar_check (count_rate
, 1) == FAILURE
)
3118 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
3121 if (variable_check (count_rate
, 1) == FAILURE
)
3125 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
3130 if (count_max
!= NULL
)
3132 if (scalar_check (count_max
, 2) == FAILURE
)
3135 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
3138 if (variable_check (count_max
, 2) == FAILURE
)
3142 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
3145 if (count_rate
!= NULL
3146 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
3155 gfc_check_irand (gfc_expr
*x
)
3160 if (scalar_check (x
, 0) == FAILURE
)
3163 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3166 if (kind_value_check(x
, 0, 4) == FAILURE
)
3174 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
3176 if (scalar_check (seconds
, 0) == FAILURE
)
3179 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
3182 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3184 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3185 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
3186 gfc_current_intrinsic
, &handler
->where
);
3190 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3196 if (scalar_check (status
, 2) == FAILURE
)
3199 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3202 if (kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
3210 gfc_check_rand (gfc_expr
*x
)
3215 if (scalar_check (x
, 0) == FAILURE
)
3218 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3221 if (kind_value_check(x
, 0, 4) == FAILURE
)
3229 gfc_check_srand (gfc_expr
*x
)
3231 if (scalar_check (x
, 0) == FAILURE
)
3234 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
3237 if (kind_value_check(x
, 0, 4) == FAILURE
)
3245 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
3247 if (scalar_check (time
, 0) == FAILURE
)
3250 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
3253 if (type_check (result
, 1, BT_CHARACTER
) == FAILURE
)
3261 gfc_check_dtime_etime (gfc_expr
*x
)
3263 if (array_check (x
, 0) == FAILURE
)
3266 if (rank_check (x
, 0, 1) == FAILURE
)
3269 if (variable_check (x
, 0) == FAILURE
)
3272 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3275 if (kind_value_check(x
, 0, 4) == FAILURE
)
3283 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
3285 if (array_check (values
, 0) == FAILURE
)
3288 if (rank_check (values
, 0, 1) == FAILURE
)
3291 if (variable_check (values
, 0) == FAILURE
)
3294 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
3297 if (kind_value_check(values
, 0, 4) == FAILURE
)
3300 if (scalar_check (time
, 1) == FAILURE
)
3303 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
3306 if (kind_value_check(time
, 1, 4) == FAILURE
)
3314 gfc_check_fdate_sub (gfc_expr
*date
)
3316 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
3324 gfc_check_gerror (gfc_expr
*msg
)
3326 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3334 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
3336 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
3342 if (scalar_check (status
, 1) == FAILURE
)
3345 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3353 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
3355 if (type_check (pos
, 0, BT_INTEGER
) == FAILURE
)
3358 if (pos
->ts
.kind
> gfc_default_integer_kind
)
3360 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3361 "not wider than the default kind (%d)",
3362 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
3363 &pos
->where
, gfc_default_integer_kind
);
3367 if (type_check (value
, 1, BT_CHARACTER
) == FAILURE
)
3375 gfc_check_getlog (gfc_expr
*msg
)
3377 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3385 gfc_check_exit (gfc_expr
*status
)
3390 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
3393 if (scalar_check (status
, 0) == FAILURE
)
3401 gfc_check_flush (gfc_expr
*unit
)
3406 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3409 if (scalar_check (unit
, 0) == FAILURE
)
3417 gfc_check_free (gfc_expr
*i
)
3419 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
3422 if (scalar_check (i
, 0) == FAILURE
)
3430 gfc_check_hostnm (gfc_expr
*name
)
3432 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3440 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
3442 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3448 if (scalar_check (status
, 1) == FAILURE
)
3451 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3459 gfc_check_itime_idate (gfc_expr
*values
)
3461 if (array_check (values
, 0) == FAILURE
)
3464 if (rank_check (values
, 0, 1) == FAILURE
)
3467 if (variable_check (values
, 0) == FAILURE
)
3470 if (type_check (values
, 0, BT_INTEGER
) == FAILURE
)
3473 if (kind_value_check(values
, 0, gfc_default_integer_kind
) == FAILURE
)
3481 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
3483 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
3486 if (kind_value_check(time
, 0, gfc_default_integer_kind
) == FAILURE
)
3489 if (scalar_check (time
, 0) == FAILURE
)
3492 if (array_check (values
, 1) == FAILURE
)
3495 if (rank_check (values
, 1, 1) == FAILURE
)
3498 if (variable_check (values
, 1) == FAILURE
)
3501 if (type_check (values
, 1, BT_INTEGER
) == FAILURE
)
3504 if (kind_value_check(values
, 1, gfc_default_integer_kind
) == FAILURE
)
3512 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
3514 if (scalar_check (unit
, 0) == FAILURE
)
3517 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3520 if (type_check (name
, 1, BT_CHARACTER
) == FAILURE
)
3528 gfc_check_isatty (gfc_expr
*unit
)
3533 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3536 if (scalar_check (unit
, 0) == FAILURE
)
3544 gfc_check_isnan (gfc_expr
*x
)
3546 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3554 gfc_check_perror (gfc_expr
*string
)
3556 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
3564 gfc_check_umask (gfc_expr
*mask
)
3566 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3569 if (scalar_check (mask
, 0) == FAILURE
)
3577 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
3579 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3582 if (scalar_check (mask
, 0) == FAILURE
)
3588 if (scalar_check (old
, 1) == FAILURE
)
3591 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
3599 gfc_check_unlink (gfc_expr
*name
)
3601 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3609 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
3611 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3617 if (scalar_check (status
, 1) == FAILURE
)
3620 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3628 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
3630 if (scalar_check (number
, 0) == FAILURE
)
3633 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3636 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3638 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3639 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
3640 gfc_current_intrinsic
, &handler
->where
);
3644 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3652 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
3654 if (scalar_check (number
, 0) == FAILURE
)
3657 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3660 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3662 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3663 "or PROCEDURE", gfc_current_intrinsic_arg
[1],
3664 gfc_current_intrinsic
, &handler
->where
);
3668 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3674 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3677 if (scalar_check (status
, 2) == FAILURE
)
3685 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
3687 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
3690 if (scalar_check (status
, 1) == FAILURE
)
3693 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3696 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)
3703 /* This is used for the GNU intrinsics AND, OR and XOR. */
3705 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
3707 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
3709 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3710 "or LOGICAL", gfc_current_intrinsic_arg
[0],
3711 gfc_current_intrinsic
, &i
->where
);
3715 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
3717 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3718 "or LOGICAL", gfc_current_intrinsic_arg
[1],
3719 gfc_current_intrinsic
, &j
->where
);
3723 if (i
->ts
.type
!= j
->ts
.type
)
3725 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3726 "have the same type", gfc_current_intrinsic_arg
[0],
3727 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
3732 if (scalar_check (i
, 0) == FAILURE
)
3735 if (scalar_check (j
, 1) == FAILURE
)