2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* These functions check to see if an argument list is compatible with
24 a particular intrinsic function or subroutine. Presence of
25 required arguments has already been established, the argument list
26 has been sorted into the right order and has NULL arguments in the
27 correct places for missing optional arguments. */
33 #include "intrinsic.h"
36 /* Check the type of an expression. */
39 type_check (gfc_expr
* e
, int n
, bt type
)
41 if (e
->ts
.type
== type
)
44 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
45 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
,
46 gfc_basic_typename (type
));
52 /* Check that the expression is a numeric type. */
55 numeric_check (gfc_expr
* e
, int n
)
57 if (gfc_numeric_ts (&e
->ts
))
60 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
61 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
67 /* Check that an expression is integer or real. */
70 int_or_real_check (gfc_expr
* e
, int n
)
72 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
75 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
76 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
84 /* Check that an expression is real or complex. */
87 real_or_complex_check (gfc_expr
* e
, int n
)
89 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
92 "'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
93 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
101 /* Check that the expression is an optional constant integer
102 and that it specifies a valid kind for that type. */
105 kind_check (gfc_expr
* k
, int n
, bt type
)
112 if (type_check (k
, n
, BT_INTEGER
) == FAILURE
)
115 if (k
->expr_type
!= EXPR_CONSTANT
)
118 "'%s' argument of '%s' intrinsic at %L must be a constant",
119 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &k
->where
);
123 if (gfc_extract_int (k
, &kind
) != NULL
124 || gfc_validate_kind (type
, kind
, true) < 0)
126 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
135 /* Make sure the expression is a double precision real. */
138 double_check (gfc_expr
* d
, int n
)
140 if (type_check (d
, n
, BT_REAL
) == FAILURE
)
143 if (d
->ts
.kind
!= gfc_default_double_kind
)
146 "'%s' argument of '%s' intrinsic at %L must be double precision",
147 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &d
->where
);
155 /* Make sure the expression is a logical array. */
158 logical_array_check (gfc_expr
* array
, int n
)
160 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
163 "'%s' argument of '%s' intrinsic at %L must be a logical array",
164 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &array
->where
);
172 /* Make sure an expression is an array. */
175 array_check (gfc_expr
* e
, int n
)
180 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
181 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
187 /* Make sure an expression is a scalar. */
190 scalar_check (gfc_expr
* e
, int n
)
195 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
196 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
202 /* Make sure two expression have the same type. */
205 same_type_check (gfc_expr
* e
, int n
, gfc_expr
* f
, int m
)
207 if (gfc_compare_types (&e
->ts
, &f
->ts
))
210 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
211 "and kind as '%s'", gfc_current_intrinsic_arg
[m
],
212 gfc_current_intrinsic
, &f
->where
, gfc_current_intrinsic_arg
[n
]);
217 /* Make sure that an expression has a certain (nonzero) rank. */
220 rank_check (gfc_expr
* e
, int n
, int rank
)
225 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
226 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
232 /* Make sure a variable expression is not an optional dummy argument. */
235 nonoptional_check (gfc_expr
* e
, int n
)
237 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
239 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
240 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
245 /* TODO: Recursive check on nonoptional variables? */
251 /* Check that an expression has a particular kind. */
254 kind_value_check (gfc_expr
* e
, int n
, int k
)
259 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
260 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
266 /* Make sure an expression is a variable. */
269 variable_check (gfc_expr
* e
, int n
)
271 if ((e
->expr_type
== EXPR_VARIABLE
272 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
)
273 || (e
->expr_type
== EXPR_FUNCTION
274 && e
->symtree
->n
.sym
->result
== e
->symtree
->n
.sym
))
277 if (e
->expr_type
== EXPR_VARIABLE
278 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
280 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
281 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
,
286 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
287 gfc_current_intrinsic_arg
[n
], gfc_current_intrinsic
, &e
->where
);
293 /* Check the common DIM parameter for correctness. */
296 dim_check (gfc_expr
* dim
, int n
, int optional
)
298 if (optional
&& dim
== NULL
)
303 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
304 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
308 if (type_check (dim
, n
, BT_INTEGER
) == FAILURE
)
311 if (scalar_check (dim
, n
) == FAILURE
)
314 if (nonoptional_check (dim
, n
) == FAILURE
)
321 /* If a DIM parameter is a constant, make sure that it is greater than
322 zero and less than or equal to the rank of the given array. If
323 allow_assumed is zero then dim must be less than the rank of the array
324 for assumed size arrays. */
327 dim_rank_check (gfc_expr
* dim
, gfc_expr
* array
, int allow_assumed
)
332 if (dim
->expr_type
!= EXPR_CONSTANT
|| array
->expr_type
!= EXPR_VARIABLE
)
335 ar
= gfc_find_array_ref (array
);
337 if (ar
->as
->type
== AS_ASSUMED_SIZE
&& !allow_assumed
)
340 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
341 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
343 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
344 "dimension index", gfc_current_intrinsic
, &dim
->where
);
352 /* Compare the size of a along dimension ai with the size of b along
353 dimension bi, returning 0 if they are known not to be identical,
354 and 1 if they are identical, or if this cannot be determined. */
357 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
359 mpz_t a_size
, b_size
;
362 gcc_assert (a
->rank
> ai
);
363 gcc_assert (b
->rank
> bi
);
367 if (gfc_array_dimen_size (a
, ai
, &a_size
) == SUCCESS
)
369 if (gfc_array_dimen_size (b
, bi
, &b_size
) == SUCCESS
)
371 if (mpz_cmp (a_size
, b_size
) != 0)
381 /* Error return for transformational intrinsics not allowed in
382 initialization expressions. */
385 non_init_transformational (void)
387 gfc_error ("transformational intrinsic '%s' at %L is not permitted "
388 "in an initialization expression", gfc_current_intrinsic
,
389 gfc_current_intrinsic_where
);
393 /***** Check functions *****/
395 /* Check subroutine suitable for intrinsics taking a real argument and
396 a kind argument for the result. */
399 check_a_kind (gfc_expr
* a
, gfc_expr
* kind
, bt type
)
401 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
403 if (kind_check (kind
, 1, type
) == FAILURE
)
409 /* Check subroutine suitable for ceiling, floor and nint. */
412 gfc_check_a_ikind (gfc_expr
* a
, gfc_expr
* kind
)
414 return check_a_kind (a
, kind
, BT_INTEGER
);
417 /* Check subroutine suitable for aint, anint. */
420 gfc_check_a_xkind (gfc_expr
* a
, gfc_expr
* kind
)
422 return check_a_kind (a
, kind
, BT_REAL
);
426 gfc_check_abs (gfc_expr
* a
)
428 if (numeric_check (a
, 0) == FAILURE
)
435 gfc_check_achar (gfc_expr
* a
)
438 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
446 gfc_check_access_func (gfc_expr
* name
, gfc_expr
* mode
)
448 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
449 || scalar_check (name
, 0) == FAILURE
)
453 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
454 || scalar_check (mode
, 1) == FAILURE
)
462 gfc_check_all_any (gfc_expr
* mask
, gfc_expr
* dim
)
464 if (logical_array_check (mask
, 0) == FAILURE
)
467 if (dim_check (dim
, 1, 1) == FAILURE
)
471 return non_init_transformational ();
478 gfc_check_allocated (gfc_expr
* array
)
480 if (variable_check (array
, 0) == FAILURE
)
483 if (array_check (array
, 0) == FAILURE
)
486 if (!array
->symtree
->n
.sym
->attr
.allocatable
)
488 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
489 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
498 /* Common check function where the first argument must be real or
499 integer and the second argument must be the same as the first. */
502 gfc_check_a_p (gfc_expr
* a
, gfc_expr
* p
)
504 if (int_or_real_check (a
, 0) == FAILURE
)
507 if (a
->ts
.type
!= p
->ts
.type
)
509 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
510 "have the same type", gfc_current_intrinsic_arg
[0],
511 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
516 if (a
->ts
.kind
!= p
->ts
.kind
)
518 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
519 &p
->where
) == FAILURE
)
528 gfc_check_associated (gfc_expr
* pointer
, gfc_expr
* target
)
530 symbol_attribute attr
;
535 where
= &pointer
->where
;
537 if (pointer
->expr_type
== EXPR_VARIABLE
)
538 attr
= gfc_variable_attr (pointer
, NULL
);
539 else if (pointer
->expr_type
== EXPR_FUNCTION
)
540 attr
= pointer
->symtree
->n
.sym
->attr
;
541 else if (pointer
->expr_type
== EXPR_NULL
)
544 gcc_assert (0); /* Pointer must be a variable or a function. */
548 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
549 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
554 /* Target argument is optional. */
558 where
= &target
->where
;
559 if (target
->expr_type
== EXPR_NULL
)
562 if (target
->expr_type
== EXPR_VARIABLE
)
563 attr
= gfc_variable_attr (target
, NULL
);
564 else if (target
->expr_type
== EXPR_FUNCTION
)
565 attr
= target
->symtree
->n
.sym
->attr
;
568 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
569 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg
[1],
570 gfc_current_intrinsic
, &target
->where
);
574 if (!attr
.pointer
&& !attr
.target
)
576 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
577 "or a TARGET", gfc_current_intrinsic_arg
[1],
578 gfc_current_intrinsic
, &target
->where
);
583 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
585 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
587 if (target
->rank
> 0)
589 for (i
= 0; i
< target
->rank
; i
++)
590 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
592 gfc_error ("Array section with a vector subscript at %L shall not "
593 "be the target of a pointer",
603 gfc_error ("NULL pointer at %L is not permitted as actual argument "
604 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
611 gfc_check_atan2 (gfc_expr
* y
, gfc_expr
* x
)
613 if (type_check (y
, 0, BT_REAL
) == FAILURE
)
615 if (same_type_check (y
, 0, x
, 1) == FAILURE
)
622 /* BESJN and BESYN functions. */
625 gfc_check_besn (gfc_expr
* n
, gfc_expr
* x
)
627 if (scalar_check (n
, 0) == FAILURE
)
630 if (type_check (n
, 0, BT_INTEGER
) == FAILURE
)
633 if (scalar_check (x
, 1) == FAILURE
)
636 if (type_check (x
, 1, BT_REAL
) == FAILURE
)
644 gfc_check_btest (gfc_expr
* i
, gfc_expr
* pos
)
646 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
648 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
656 gfc_check_char (gfc_expr
* i
, gfc_expr
* kind
)
658 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
660 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
668 gfc_check_chdir (gfc_expr
* dir
)
670 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
678 gfc_check_chdir_sub (gfc_expr
* dir
, gfc_expr
* status
)
680 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
686 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
689 if (scalar_check (status
, 1) == FAILURE
)
697 gfc_check_chmod (gfc_expr
* name
, gfc_expr
* mode
)
699 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
702 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
710 gfc_check_chmod_sub (gfc_expr
* name
, gfc_expr
* mode
, gfc_expr
* status
)
712 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
715 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
721 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
724 if (scalar_check (status
, 2) == FAILURE
)
732 gfc_check_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
734 if (numeric_check (x
, 0) == FAILURE
)
739 if (numeric_check (y
, 1) == FAILURE
)
742 if (x
->ts
.type
== BT_COMPLEX
)
744 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
745 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
746 gfc_current_intrinsic
, &y
->where
);
751 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
759 gfc_check_complex (gfc_expr
* x
, gfc_expr
* y
)
761 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
764 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
765 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
, &x
->where
);
768 if (scalar_check (x
, 0) == FAILURE
)
771 if (y
->ts
.type
!= BT_INTEGER
&& y
->ts
.type
!= BT_REAL
)
774 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
775 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &y
->where
);
778 if (scalar_check (y
, 1) == FAILURE
)
786 gfc_check_count (gfc_expr
* mask
, gfc_expr
* dim
)
788 if (logical_array_check (mask
, 0) == FAILURE
)
790 if (dim_check (dim
, 1, 1) == FAILURE
)
794 return non_init_transformational ();
801 gfc_check_cshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* dim
)
803 if (array_check (array
, 0) == FAILURE
)
806 if (array
->rank
== 1)
808 if (scalar_check (shift
, 1) == FAILURE
)
813 /* TODO: more requirements on shift parameter. */
816 if (dim_check (dim
, 2, 1) == FAILURE
)
820 return non_init_transformational ();
827 gfc_check_ctime (gfc_expr
* time
)
829 if (scalar_check (time
, 0) == FAILURE
)
832 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
840 gfc_check_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
842 if (numeric_check (x
, 0) == FAILURE
)
847 if (numeric_check (y
, 1) == FAILURE
)
850 if (x
->ts
.type
== BT_COMPLEX
)
852 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
853 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
854 gfc_current_intrinsic
, &y
->where
);
864 gfc_check_dble (gfc_expr
* x
)
866 if (numeric_check (x
, 0) == FAILURE
)
874 gfc_check_digits (gfc_expr
* x
)
876 if (int_or_real_check (x
, 0) == FAILURE
)
884 gfc_check_dot_product (gfc_expr
* vector_a
, gfc_expr
* vector_b
)
886 switch (vector_a
->ts
.type
)
889 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
896 if (numeric_check (vector_b
, 1) == FAILURE
)
901 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
902 "or LOGICAL", gfc_current_intrinsic_arg
[0],
903 gfc_current_intrinsic
, &vector_a
->where
);
907 if (rank_check (vector_a
, 0, 1) == FAILURE
)
910 if (rank_check (vector_b
, 1, 1) == FAILURE
)
913 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
915 gfc_error ("different shape for arguments '%s' and '%s' "
916 "at %L for intrinsic 'dot_product'",
917 gfc_current_intrinsic_arg
[0],
918 gfc_current_intrinsic_arg
[1],
924 return non_init_transformational ();
931 gfc_check_eoshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* boundary
,
934 if (array_check (array
, 0) == FAILURE
)
937 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
940 if (array
->rank
== 1)
942 if (scalar_check (shift
, 2) == FAILURE
)
947 /* TODO: more weird restrictions on shift. */
950 if (boundary
!= NULL
)
952 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
955 /* TODO: more restrictions on boundary. */
958 if (dim_check (dim
, 1, 1) == FAILURE
)
962 return non_init_transformational ();
968 /* A single complex argument. */
971 gfc_check_fn_c (gfc_expr
* a
)
973 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
980 /* A single real argument. */
983 gfc_check_fn_r (gfc_expr
* a
)
985 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
992 /* A single real or complex argument. */
995 gfc_check_fn_rc (gfc_expr
* a
)
997 if (real_or_complex_check (a
, 0) == FAILURE
)
1005 gfc_check_fnum (gfc_expr
* unit
)
1007 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1010 if (scalar_check (unit
, 0) == FAILURE
)
1017 /* This is used for the g77 one-argument Bessel functions, and the
1021 gfc_check_g77_math1 (gfc_expr
* x
)
1023 if (scalar_check (x
, 0) == FAILURE
)
1026 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1034 gfc_check_huge (gfc_expr
* x
)
1036 if (int_or_real_check (x
, 0) == FAILURE
)
1043 /* Check that the single argument is an integer. */
1046 gfc_check_i (gfc_expr
* i
)
1048 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1056 gfc_check_iand (gfc_expr
* i
, gfc_expr
* j
)
1058 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1061 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1064 if (i
->ts
.kind
!= j
->ts
.kind
)
1066 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1067 &i
->where
) == FAILURE
)
1076 gfc_check_ibclr (gfc_expr
* i
, gfc_expr
* pos
)
1078 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1081 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1089 gfc_check_ibits (gfc_expr
* i
, gfc_expr
* pos
, gfc_expr
* len
)
1091 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1094 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1097 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1105 gfc_check_ibset (gfc_expr
* i
, gfc_expr
* pos
)
1107 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1110 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1118 gfc_check_ichar_iachar (gfc_expr
* c
)
1122 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
1125 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1131 /* Substring references don't have the charlength set. */
1133 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1136 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1140 /* Check that the argument is length one. Non-constant lengths
1141 can't be checked here, so assume they are ok. */
1142 if (c
->ts
.cl
&& c
->ts
.cl
->length
)
1144 /* If we already have a length for this expression then use it. */
1145 if (c
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1147 i
= mpz_get_si (c
->ts
.cl
->length
->value
.integer
);
1154 start
= ref
->u
.ss
.start
;
1155 end
= ref
->u
.ss
.end
;
1158 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1159 || start
->expr_type
!= EXPR_CONSTANT
)
1162 i
= mpz_get_si (end
->value
.integer
) + 1
1163 - mpz_get_si (start
->value
.integer
);
1171 gfc_error ("Argument of %s at %L must be of length one",
1172 gfc_current_intrinsic
, &c
->where
);
1181 gfc_check_idnint (gfc_expr
* a
)
1183 if (double_check (a
, 0) == FAILURE
)
1191 gfc_check_ieor (gfc_expr
* i
, gfc_expr
* j
)
1193 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1196 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1199 if (i
->ts
.kind
!= j
->ts
.kind
)
1201 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1202 &i
->where
) == FAILURE
)
1211 gfc_check_index (gfc_expr
* string
, gfc_expr
* substring
, gfc_expr
* back
)
1213 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1214 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1218 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1221 if (string
->ts
.kind
!= substring
->ts
.kind
)
1223 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1224 "kind as '%s'", gfc_current_intrinsic_arg
[1],
1225 gfc_current_intrinsic
, &substring
->where
,
1226 gfc_current_intrinsic_arg
[0]);
1235 gfc_check_int (gfc_expr
* x
, gfc_expr
* kind
)
1237 if (numeric_check (x
, 0) == FAILURE
)
1242 if (type_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1245 if (scalar_check (kind
, 1) == FAILURE
)
1254 gfc_check_intconv (gfc_expr
* x
)
1256 if (numeric_check (x
, 0) == FAILURE
)
1264 gfc_check_ior (gfc_expr
* i
, gfc_expr
* j
)
1266 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1269 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1272 if (i
->ts
.kind
!= j
->ts
.kind
)
1274 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1275 &i
->where
) == FAILURE
)
1284 gfc_check_ishft (gfc_expr
* i
, gfc_expr
* shift
)
1286 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1287 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1295 gfc_check_ishftc (gfc_expr
* i
, gfc_expr
* shift
, gfc_expr
* size
)
1297 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1298 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1301 if (size
!= NULL
&& type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1309 gfc_check_kill (gfc_expr
* pid
, gfc_expr
* sig
)
1311 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1314 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1322 gfc_check_kill_sub (gfc_expr
* pid
, gfc_expr
* sig
, gfc_expr
* status
)
1324 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1327 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1333 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1336 if (scalar_check (status
, 2) == FAILURE
)
1344 gfc_check_kind (gfc_expr
* x
)
1346 if (x
->ts
.type
== BT_DERIVED
)
1348 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1349 "non-derived type", gfc_current_intrinsic_arg
[0],
1350 gfc_current_intrinsic
, &x
->where
);
1359 gfc_check_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1361 if (array_check (array
, 0) == FAILURE
)
1366 if (dim_check (dim
, 1, 1) == FAILURE
)
1369 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
1377 gfc_check_link (gfc_expr
* path1
, gfc_expr
* path2
)
1379 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1382 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1390 gfc_check_link_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1392 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1395 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1401 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1404 if (scalar_check (status
, 2) == FAILURE
)
1411 gfc_check_loc (gfc_expr
*expr
)
1413 return variable_check (expr
, 0);
1418 gfc_check_symlnk (gfc_expr
* path1
, gfc_expr
* path2
)
1420 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1423 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1431 gfc_check_symlnk_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1433 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1436 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1442 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1445 if (scalar_check (status
, 2) == FAILURE
)
1453 gfc_check_logical (gfc_expr
* a
, gfc_expr
* kind
)
1455 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
1457 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
1464 /* Min/max family. */
1467 min_max_args (gfc_actual_arglist
* arg
)
1469 if (arg
== NULL
|| arg
->next
== NULL
)
1471 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1472 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1481 check_rest (bt type
, int kind
, gfc_actual_arglist
* arg
)
1486 if (min_max_args (arg
) == FAILURE
)
1491 for (; arg
; arg
= arg
->next
, n
++)
1494 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
1496 if (x
->ts
.type
== type
)
1498 if (gfc_notify_std (GFC_STD_GNU
,
1499 "Extension: Different type kinds at %L", &x
->where
)
1505 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1506 n
, gfc_current_intrinsic
, &x
->where
,
1507 gfc_basic_typename (type
), kind
);
1518 gfc_check_min_max (gfc_actual_arglist
* arg
)
1522 if (min_max_args (arg
) == FAILURE
)
1527 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
1530 ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1531 gfc_current_intrinsic
, &x
->where
);
1535 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
1540 gfc_check_min_max_integer (gfc_actual_arglist
* arg
)
1542 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
1547 gfc_check_min_max_real (gfc_actual_arglist
* arg
)
1549 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
1554 gfc_check_min_max_double (gfc_actual_arglist
* arg
)
1556 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
1559 /* End of min/max family. */
1562 gfc_check_malloc (gfc_expr
* size
)
1564 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
1567 if (scalar_check (size
, 0) == FAILURE
)
1575 gfc_check_matmul (gfc_expr
* matrix_a
, gfc_expr
* matrix_b
)
1577 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
1579 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1580 "or LOGICAL", gfc_current_intrinsic_arg
[0],
1581 gfc_current_intrinsic
, &matrix_a
->where
);
1585 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
1587 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1588 "or LOGICAL", gfc_current_intrinsic_arg
[1],
1589 gfc_current_intrinsic
, &matrix_b
->where
);
1593 switch (matrix_a
->rank
)
1596 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
1598 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1599 if (! identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
1601 gfc_error ("different shape on dimension 1 for arguments '%s' "
1602 "and '%s' at %L for intrinsic matmul",
1603 gfc_current_intrinsic_arg
[0],
1604 gfc_current_intrinsic_arg
[1],
1611 if (matrix_b
->rank
!= 2)
1613 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
1616 /* matrix_b has rank 1 or 2 here. Common check for the cases
1617 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1618 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1619 if (! identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
1621 gfc_error ("different shape on dimension 2 for argument '%s' and "
1622 "dimension 1 for argument '%s' at %L for intrinsic "
1623 "matmul", gfc_current_intrinsic_arg
[0],
1624 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1630 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1631 "1 or 2", gfc_current_intrinsic_arg
[0],
1632 gfc_current_intrinsic
, &matrix_a
->where
);
1637 return non_init_transformational ();
1643 /* Whoever came up with this interface was probably on something.
1644 The possibilities for the occupation of the second and third
1651 NULL MASK minloc(array, mask=m)
1654 I.e. in the case of minloc(array,mask), mask will be in the second
1655 position of the argument list and we'll have to fix that up. */
1658 gfc_check_minloc_maxloc (gfc_actual_arglist
* ap
)
1660 gfc_expr
*a
, *m
, *d
;
1663 if (int_or_real_check (a
, 0) == FAILURE
1664 || array_check (a
, 0) == FAILURE
)
1668 m
= ap
->next
->next
->expr
;
1670 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1671 && ap
->next
->name
== NULL
)
1676 ap
->next
->expr
= NULL
;
1677 ap
->next
->next
->expr
= m
;
1680 if (dim_check (d
, 1, 1) == FAILURE
)
1683 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1686 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1692 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic %s",
1693 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1694 gfc_current_intrinsic
);
1695 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1700 return non_init_transformational ();
1706 /* Similar to minloc/maxloc, the argument list might need to be
1707 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1708 difference is that MINLOC/MAXLOC take an additional KIND argument.
1709 The possibilities are:
1715 NULL MASK minval(array, mask=m)
1718 I.e. in the case of minval(array,mask), mask will be in the second
1719 position of the argument list and we'll have to fix that up. */
1722 check_reduction (gfc_actual_arglist
* ap
)
1724 gfc_expr
*a
, *m
, *d
;
1728 m
= ap
->next
->next
->expr
;
1730 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1731 && ap
->next
->name
== NULL
)
1736 ap
->next
->expr
= NULL
;
1737 ap
->next
->next
->expr
= m
;
1740 if (dim_check (d
, 1, 1) == FAILURE
)
1743 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1746 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1752 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic %s",
1753 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1754 gfc_current_intrinsic
);
1755 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1764 gfc_check_minval_maxval (gfc_actual_arglist
* ap
)
1766 if (int_or_real_check (ap
->expr
, 0) == FAILURE
1767 || array_check (ap
->expr
, 0) == FAILURE
)
1771 return non_init_transformational ();
1773 return check_reduction (ap
);
1778 gfc_check_product_sum (gfc_actual_arglist
* ap
)
1780 if (numeric_check (ap
->expr
, 0) == FAILURE
1781 || array_check (ap
->expr
, 0) == FAILURE
)
1785 return non_init_transformational ();
1787 return check_reduction (ap
);
1792 gfc_check_merge (gfc_expr
* tsource
, gfc_expr
* fsource
, gfc_expr
* mask
)
1796 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
1799 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
1802 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic '%s'",
1803 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[1],
1804 gfc_current_intrinsic
);
1805 if (gfc_check_conformance (buffer
, tsource
, fsource
) == FAILURE
)
1808 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic '%s'",
1809 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1810 gfc_current_intrinsic
);
1811 if (gfc_check_conformance (buffer
, tsource
, mask
) == FAILURE
)
1819 gfc_check_nearest (gfc_expr
* x
, gfc_expr
* s
)
1821 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1824 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
1831 gfc_check_new_line (gfc_expr
* a
)
1833 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
1840 gfc_check_null (gfc_expr
* mold
)
1842 symbol_attribute attr
;
1847 if (variable_check (mold
, 0) == FAILURE
)
1850 attr
= gfc_variable_attr (mold
, NULL
);
1854 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1855 gfc_current_intrinsic_arg
[0],
1856 gfc_current_intrinsic
, &mold
->where
);
1865 gfc_check_pack (gfc_expr
* array
, gfc_expr
* mask
, gfc_expr
* vector
)
1869 if (array_check (array
, 0) == FAILURE
)
1872 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
1875 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic '%s'",
1876 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[1],
1877 gfc_current_intrinsic
);
1878 if (gfc_check_conformance (buffer
, array
, mask
) == FAILURE
)
1883 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
1886 if (rank_check (vector
, 2, 1) == FAILURE
)
1889 /* TODO: More constraints here. */
1893 return non_init_transformational ();
1900 gfc_check_precision (gfc_expr
* x
)
1902 if (x
->ts
.type
!= BT_REAL
&& x
->ts
.type
!= BT_COMPLEX
)
1904 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1905 "REAL or COMPLEX", gfc_current_intrinsic_arg
[0],
1906 gfc_current_intrinsic
, &x
->where
);
1915 gfc_check_present (gfc_expr
* a
)
1919 if (variable_check (a
, 0) == FAILURE
)
1922 sym
= a
->symtree
->n
.sym
;
1923 if (!sym
->attr
.dummy
)
1925 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1926 "dummy variable", gfc_current_intrinsic_arg
[0],
1927 gfc_current_intrinsic
, &a
->where
);
1931 if (!sym
->attr
.optional
)
1933 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1934 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg
[0],
1935 gfc_current_intrinsic
, &a
->where
);
1939 /* 13.14.82 PRESENT(A)
1941 Argument. A shall be the name of an optional dummy argument that is accessible
1942 in the subprogram in which the PRESENT function reference appears... */
1945 && !(a
->ref
->next
== NULL
1946 && a
->ref
->type
== REF_ARRAY
1947 && a
->ref
->u
.ar
.type
== AR_FULL
))
1949 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-"
1950 "object of '%s'", gfc_current_intrinsic_arg
[0],
1951 gfc_current_intrinsic
, &a
->where
, sym
->name
);
1960 gfc_check_radix (gfc_expr
* x
)
1962 if (int_or_real_check (x
, 0) == FAILURE
)
1970 gfc_check_range (gfc_expr
* x
)
1972 if (numeric_check (x
, 0) == FAILURE
)
1979 /* real, float, sngl. */
1981 gfc_check_real (gfc_expr
* a
, gfc_expr
* kind
)
1983 if (numeric_check (a
, 0) == FAILURE
)
1986 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
1994 gfc_check_rename (gfc_expr
* path1
, gfc_expr
* path2
)
1996 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1999 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2007 gfc_check_rename_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
2009 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2012 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2018 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2021 if (scalar_check (status
, 2) == FAILURE
)
2029 gfc_check_repeat (gfc_expr
* x
, gfc_expr
* y
)
2031 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2034 if (scalar_check (x
, 0) == FAILURE
)
2037 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
2040 if (scalar_check (y
, 1) == FAILURE
)
2048 gfc_check_reshape (gfc_expr
* source
, gfc_expr
* shape
,
2049 gfc_expr
* pad
, gfc_expr
* order
)
2054 if (array_check (source
, 0) == FAILURE
)
2057 if (rank_check (shape
, 1, 1) == FAILURE
)
2060 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
2063 if (gfc_array_size (shape
, &size
) != SUCCESS
)
2065 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2066 "array of constant size", &shape
->where
);
2070 m
= mpz_cmp_ui (size
, GFC_MAX_DIMENSIONS
);
2075 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2076 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
2082 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
2084 if (array_check (pad
, 2) == FAILURE
)
2088 if (order
!= NULL
&& array_check (order
, 3) == FAILURE
)
2096 gfc_check_scale (gfc_expr
* x
, gfc_expr
* i
)
2098 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2101 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2109 gfc_check_scan (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
2111 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2114 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
2117 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2120 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2128 gfc_check_secnds (gfc_expr
* r
)
2131 if (type_check (r
, 0, BT_REAL
) == FAILURE
)
2134 if (kind_value_check (r
, 0, 4) == FAILURE
)
2137 if (scalar_check (r
, 0) == FAILURE
)
2145 gfc_check_selected_int_kind (gfc_expr
* r
)
2148 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
2151 if (scalar_check (r
, 0) == FAILURE
)
2159 gfc_check_selected_real_kind (gfc_expr
* p
, gfc_expr
* r
)
2161 if (p
== NULL
&& r
== NULL
)
2163 gfc_error ("Missing arguments to %s intrinsic at %L",
2164 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2169 if (p
!= NULL
&& type_check (p
, 0, BT_INTEGER
) == FAILURE
)
2172 if (r
!= NULL
&& type_check (r
, 1, BT_INTEGER
) == FAILURE
)
2180 gfc_check_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
2182 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2185 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2193 gfc_check_shape (gfc_expr
* source
)
2197 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
2200 ar
= gfc_find_array_ref (source
);
2202 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
)
2204 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2205 "an assumed size array", &source
->where
);
2214 gfc_check_sign (gfc_expr
* a
, gfc_expr
* b
)
2216 if (int_or_real_check (a
, 0) == FAILURE
)
2219 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
2227 gfc_check_size (gfc_expr
* array
, gfc_expr
* dim
)
2229 if (array_check (array
, 0) == FAILURE
)
2234 if (type_check (dim
, 1, BT_INTEGER
) == FAILURE
)
2237 if (kind_value_check (dim
, 1, gfc_default_integer_kind
) == FAILURE
)
2240 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2249 gfc_check_sleep_sub (gfc_expr
* seconds
)
2251 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
2254 if (scalar_check (seconds
, 0) == FAILURE
)
2262 gfc_check_spread (gfc_expr
* source
, gfc_expr
* dim
, gfc_expr
* ncopies
)
2264 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
2266 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2267 "than rank %d", gfc_current_intrinsic_arg
[0],
2268 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
2273 if (dim_check (dim
, 1, 0) == FAILURE
)
2276 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
2279 if (scalar_check (ncopies
, 2) == FAILURE
)
2283 return non_init_transformational ();
2289 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2292 gfc_check_fgetputc_sub (gfc_expr
* unit
, gfc_expr
* c
, gfc_expr
* status
)
2294 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2297 if (scalar_check (unit
, 0) == FAILURE
)
2300 if (type_check (c
, 1, BT_CHARACTER
) == FAILURE
)
2306 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2307 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
2308 || scalar_check (status
, 2) == FAILURE
)
2316 gfc_check_fgetputc (gfc_expr
* unit
, gfc_expr
* c
)
2318 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
2323 gfc_check_fgetput_sub (gfc_expr
* c
, gfc_expr
* status
)
2325 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
2331 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
2332 || kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
2333 || scalar_check (status
, 1) == FAILURE
)
2341 gfc_check_fgetput (gfc_expr
* c
)
2343 return gfc_check_fgetput_sub (c
, NULL
);
2348 gfc_check_fstat (gfc_expr
* unit
, gfc_expr
* array
)
2350 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2353 if (scalar_check (unit
, 0) == FAILURE
)
2356 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2357 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
2360 if (array_check (array
, 1) == FAILURE
)
2368 gfc_check_fstat_sub (gfc_expr
* unit
, gfc_expr
* array
, gfc_expr
* status
)
2370 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2373 if (scalar_check (unit
, 0) == FAILURE
)
2376 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2377 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2380 if (array_check (array
, 1) == FAILURE
)
2386 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2387 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
2390 if (scalar_check (status
, 2) == FAILURE
)
2398 gfc_check_ftell (gfc_expr
* unit
)
2400 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2403 if (scalar_check (unit
, 0) == FAILURE
)
2411 gfc_check_ftell_sub (gfc_expr
* unit
, gfc_expr
* offset
)
2413 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2416 if (scalar_check (unit
, 0) == FAILURE
)
2419 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
2422 if (scalar_check (offset
, 1) == FAILURE
)
2430 gfc_check_stat (gfc_expr
* name
, gfc_expr
* array
)
2432 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2435 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2436 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2439 if (array_check (array
, 1) == FAILURE
)
2447 gfc_check_stat_sub (gfc_expr
* name
, gfc_expr
* array
, gfc_expr
* status
)
2449 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2452 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2453 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2456 if (array_check (array
, 1) == FAILURE
)
2462 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2463 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2466 if (scalar_check (status
, 2) == FAILURE
)
2474 gfc_check_transfer (gfc_expr
* source ATTRIBUTE_UNUSED
,
2475 gfc_expr
* mold ATTRIBUTE_UNUSED
,
2480 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
2483 if (scalar_check (size
, 2) == FAILURE
)
2486 if (nonoptional_check (size
, 2) == FAILURE
)
2495 gfc_check_transpose (gfc_expr
* matrix
)
2497 if (rank_check (matrix
, 0, 2) == FAILURE
)
2501 return non_init_transformational ();
2508 gfc_check_ubound (gfc_expr
* array
, gfc_expr
* dim
)
2510 if (array_check (array
, 0) == FAILURE
)
2515 if (dim_check (dim
, 1, 1) == FAILURE
)
2518 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2527 gfc_check_unpack (gfc_expr
* vector
, gfc_expr
* mask
, gfc_expr
* field
)
2529 if (rank_check (vector
, 0, 1) == FAILURE
)
2532 if (array_check (mask
, 1) == FAILURE
)
2535 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2538 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
2542 return non_init_transformational ();
2549 gfc_check_verify (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
2551 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2554 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2557 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2565 gfc_check_trim (gfc_expr
* x
)
2567 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2570 if (scalar_check (x
, 0) == FAILURE
)
2578 gfc_check_ttynam (gfc_expr
* unit
)
2580 if (scalar_check (unit
, 0) == FAILURE
)
2583 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2590 /* Common check function for the half a dozen intrinsics that have a
2591 single real argument. */
2594 gfc_check_x (gfc_expr
* x
)
2596 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2603 /************* Check functions for intrinsic subroutines *************/
2606 gfc_check_cpu_time (gfc_expr
* time
)
2608 if (scalar_check (time
, 0) == FAILURE
)
2611 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2614 if (variable_check (time
, 0) == FAILURE
)
2622 gfc_check_date_and_time (gfc_expr
* date
, gfc_expr
* time
,
2623 gfc_expr
* zone
, gfc_expr
* values
)
2627 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
2629 if (scalar_check (date
, 0) == FAILURE
)
2631 if (variable_check (date
, 0) == FAILURE
)
2637 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
2639 if (scalar_check (time
, 1) == FAILURE
)
2641 if (variable_check (time
, 1) == FAILURE
)
2647 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
2649 if (scalar_check (zone
, 2) == FAILURE
)
2651 if (variable_check (zone
, 2) == FAILURE
)
2657 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
2659 if (array_check (values
, 3) == FAILURE
)
2661 if (rank_check (values
, 3, 1) == FAILURE
)
2663 if (variable_check (values
, 3) == FAILURE
)
2672 gfc_check_mvbits (gfc_expr
* from
, gfc_expr
* frompos
, gfc_expr
* len
,
2673 gfc_expr
* to
, gfc_expr
* topos
)
2675 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
2678 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
2681 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
2684 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
2687 if (variable_check (to
, 3) == FAILURE
)
2690 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
2698 gfc_check_random_number (gfc_expr
* harvest
)
2700 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
2703 if (variable_check (harvest
, 0) == FAILURE
)
2711 gfc_check_random_seed (gfc_expr
* size
, gfc_expr
* put
, gfc_expr
* get
)
2715 if (scalar_check (size
, 0) == FAILURE
)
2718 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
2721 if (variable_check (size
, 0) == FAILURE
)
2724 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
2732 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
2735 if (array_check (put
, 1) == FAILURE
)
2738 if (rank_check (put
, 1, 1) == FAILURE
)
2741 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
2744 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
2751 if (size
!= NULL
|| put
!= NULL
)
2752 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
2755 if (array_check (get
, 2) == FAILURE
)
2758 if (rank_check (get
, 2, 1) == FAILURE
)
2761 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
2764 if (variable_check (get
, 2) == FAILURE
)
2767 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
2775 gfc_check_second_sub (gfc_expr
* time
)
2777 if (scalar_check (time
, 0) == FAILURE
)
2780 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2783 if (kind_value_check(time
, 0, 4) == FAILURE
)
2790 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2791 count, count_rate, and count_max are all optional arguments */
2794 gfc_check_system_clock (gfc_expr
* count
, gfc_expr
* count_rate
,
2795 gfc_expr
* count_max
)
2799 if (scalar_check (count
, 0) == FAILURE
)
2802 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
2805 if (variable_check (count
, 0) == FAILURE
)
2809 if (count_rate
!= NULL
)
2811 if (scalar_check (count_rate
, 1) == FAILURE
)
2814 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
2817 if (variable_check (count_rate
, 1) == FAILURE
)
2821 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
2826 if (count_max
!= NULL
)
2828 if (scalar_check (count_max
, 2) == FAILURE
)
2831 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
2834 if (variable_check (count_max
, 2) == FAILURE
)
2838 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
2841 if (count_rate
!= NULL
2842 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
2850 gfc_check_irand (gfc_expr
* x
)
2855 if (scalar_check (x
, 0) == FAILURE
)
2858 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2861 if (kind_value_check(x
, 0, 4) == FAILURE
)
2869 gfc_check_alarm_sub (gfc_expr
* seconds
, gfc_expr
* handler
, gfc_expr
* status
)
2871 if (scalar_check (seconds
, 0) == FAILURE
)
2874 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
2877 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
2880 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2881 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &handler
->where
);
2885 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
2891 if (scalar_check (status
, 2) == FAILURE
)
2894 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2902 gfc_check_rand (gfc_expr
* x
)
2907 if (scalar_check (x
, 0) == FAILURE
)
2910 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2913 if (kind_value_check(x
, 0, 4) == FAILURE
)
2920 gfc_check_srand (gfc_expr
* x
)
2922 if (scalar_check (x
, 0) == FAILURE
)
2925 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2928 if (kind_value_check(x
, 0, 4) == FAILURE
)
2935 gfc_check_ctime_sub (gfc_expr
* time
, gfc_expr
* result
)
2937 if (scalar_check (time
, 0) == FAILURE
)
2940 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
2943 if (type_check (result
, 1, BT_CHARACTER
) == FAILURE
)
2950 gfc_check_etime (gfc_expr
* x
)
2952 if (array_check (x
, 0) == FAILURE
)
2955 if (rank_check (x
, 0, 1) == FAILURE
)
2958 if (variable_check (x
, 0) == FAILURE
)
2961 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2964 if (kind_value_check(x
, 0, 4) == FAILURE
)
2971 gfc_check_etime_sub (gfc_expr
* values
, gfc_expr
* time
)
2973 if (array_check (values
, 0) == FAILURE
)
2976 if (rank_check (values
, 0, 1) == FAILURE
)
2979 if (variable_check (values
, 0) == FAILURE
)
2982 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
2985 if (kind_value_check(values
, 0, 4) == FAILURE
)
2988 if (scalar_check (time
, 1) == FAILURE
)
2991 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
2994 if (kind_value_check(time
, 1, 4) == FAILURE
)
3002 gfc_check_fdate_sub (gfc_expr
* date
)
3004 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
3012 gfc_check_gerror (gfc_expr
* msg
)
3014 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3022 gfc_check_getcwd_sub (gfc_expr
* cwd
, gfc_expr
* status
)
3024 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
3030 if (scalar_check (status
, 1) == FAILURE
)
3033 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3041 gfc_check_getlog (gfc_expr
* msg
)
3043 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
3051 gfc_check_exit (gfc_expr
* status
)
3056 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
3059 if (scalar_check (status
, 0) == FAILURE
)
3067 gfc_check_flush (gfc_expr
* unit
)
3072 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3075 if (scalar_check (unit
, 0) == FAILURE
)
3083 gfc_check_free (gfc_expr
* i
)
3085 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
3088 if (scalar_check (i
, 0) == FAILURE
)
3096 gfc_check_hostnm (gfc_expr
* name
)
3098 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3106 gfc_check_hostnm_sub (gfc_expr
* name
, gfc_expr
* status
)
3108 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3114 if (scalar_check (status
, 1) == FAILURE
)
3117 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3125 gfc_check_itime_idate (gfc_expr
* values
)
3127 if (array_check (values
, 0) == FAILURE
)
3130 if (rank_check (values
, 0, 1) == FAILURE
)
3133 if (variable_check (values
, 0) == FAILURE
)
3136 if (type_check (values
, 0, BT_INTEGER
) == FAILURE
)
3139 if (kind_value_check(values
, 0, gfc_default_integer_kind
) == FAILURE
)
3147 gfc_check_ltime_gmtime (gfc_expr
* time
, gfc_expr
* values
)
3149 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
3152 if (kind_value_check(time
, 0, gfc_default_integer_kind
) == FAILURE
)
3155 if (scalar_check (time
, 0) == FAILURE
)
3158 if (array_check (values
, 1) == FAILURE
)
3161 if (rank_check (values
, 1, 1) == FAILURE
)
3164 if (variable_check (values
, 1) == FAILURE
)
3167 if (type_check (values
, 1, BT_INTEGER
) == FAILURE
)
3170 if (kind_value_check(values
, 1, gfc_default_integer_kind
) == FAILURE
)
3178 gfc_check_ttynam_sub (gfc_expr
* unit
, gfc_expr
* name
)
3180 if (scalar_check (unit
, 0) == FAILURE
)
3183 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3186 if (type_check (name
, 1, BT_CHARACTER
) == FAILURE
)
3194 gfc_check_isatty (gfc_expr
* unit
)
3199 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3202 if (scalar_check (unit
, 0) == FAILURE
)
3210 gfc_check_perror (gfc_expr
* string
)
3212 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
3220 gfc_check_umask (gfc_expr
* mask
)
3222 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3225 if (scalar_check (mask
, 0) == FAILURE
)
3233 gfc_check_umask_sub (gfc_expr
* mask
, gfc_expr
* old
)
3235 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3238 if (scalar_check (mask
, 0) == FAILURE
)
3244 if (scalar_check (old
, 1) == FAILURE
)
3247 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
3255 gfc_check_unlink (gfc_expr
* name
)
3257 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3265 gfc_check_unlink_sub (gfc_expr
* name
, gfc_expr
* status
)
3267 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3273 if (scalar_check (status
, 1) == FAILURE
)
3276 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3284 gfc_check_signal (gfc_expr
* number
, gfc_expr
* handler
)
3286 if (scalar_check (number
, 0) == FAILURE
)
3289 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3292 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3295 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3296 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &handler
->where
);
3300 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3308 gfc_check_signal_sub (gfc_expr
* number
, gfc_expr
* handler
, gfc_expr
* status
)
3310 if (scalar_check (number
, 0) == FAILURE
)
3313 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3316 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3319 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3320 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &handler
->where
);
3324 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3330 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3333 if (scalar_check (status
, 2) == FAILURE
)
3341 gfc_check_system_sub (gfc_expr
* cmd
, gfc_expr
* status
)
3343 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
3346 if (scalar_check (status
, 1) == FAILURE
)
3349 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3352 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)
3359 /* This is used for the GNU intrinsics AND, OR and XOR. */
3361 gfc_check_and (gfc_expr
* i
, gfc_expr
* j
)
3363 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
3366 "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3367 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
, &i
->where
);
3371 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
3374 "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3375 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &j
->where
);
3379 if (i
->ts
.type
!= j
->ts
.type
)
3381 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3382 "have the same type", gfc_current_intrinsic_arg
[0],
3383 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
3388 if (scalar_check (i
, 0) == FAILURE
)
3391 if (scalar_check (j
, 1) == FAILURE
)