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 /***** Check functions *****/
383 /* Check subroutine suitable for intrinsics taking a real argument and
384 a kind argument for the result. */
387 check_a_kind (gfc_expr
* a
, gfc_expr
* kind
, bt type
)
389 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
391 if (kind_check (kind
, 1, type
) == FAILURE
)
397 /* Check subroutine suitable for ceiling, floor and nint. */
400 gfc_check_a_ikind (gfc_expr
* a
, gfc_expr
* kind
)
402 return check_a_kind (a
, kind
, BT_INTEGER
);
405 /* Check subroutine suitable for aint, anint. */
408 gfc_check_a_xkind (gfc_expr
* a
, gfc_expr
* kind
)
410 return check_a_kind (a
, kind
, BT_REAL
);
414 gfc_check_abs (gfc_expr
* a
)
416 if (numeric_check (a
, 0) == FAILURE
)
423 gfc_check_achar (gfc_expr
* a
)
426 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
434 gfc_check_all_any (gfc_expr
* mask
, gfc_expr
* dim
)
436 if (logical_array_check (mask
, 0) == FAILURE
)
439 if (dim_check (dim
, 1, 1) == FAILURE
)
447 gfc_check_allocated (gfc_expr
* array
)
449 if (variable_check (array
, 0) == FAILURE
)
452 if (array_check (array
, 0) == FAILURE
)
455 if (!array
->symtree
->n
.sym
->attr
.allocatable
)
457 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
458 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
467 /* Common check function where the first argument must be real or
468 integer and the second argument must be the same as the first. */
471 gfc_check_a_p (gfc_expr
* a
, gfc_expr
* p
)
473 if (int_or_real_check (a
, 0) == FAILURE
)
476 if (a
->ts
.type
!= p
->ts
.type
)
478 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
479 "have the same type", gfc_current_intrinsic_arg
[0],
480 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
485 if (a
->ts
.kind
!= p
->ts
.kind
)
487 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
488 &p
->where
) == FAILURE
)
497 gfc_check_associated (gfc_expr
* pointer
, gfc_expr
* target
)
499 symbol_attribute attr
;
503 if (pointer
->expr_type
== EXPR_VARIABLE
)
504 attr
= gfc_variable_attr (pointer
, NULL
);
505 else if (pointer
->expr_type
== EXPR_FUNCTION
)
506 attr
= pointer
->symtree
->n
.sym
->attr
;
508 gcc_assert (0); /* Pointer must be a variable or a function. */
512 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
513 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
,
518 /* Target argument is optional. */
522 if (target
->expr_type
== EXPR_NULL
)
524 gfc_error ("NULL pointer at %L is not permitted as actual argument "
525 "of '%s' intrinsic function",
526 &target
->where
, gfc_current_intrinsic
);
530 if (target
->expr_type
== EXPR_VARIABLE
)
531 attr
= gfc_variable_attr (target
, NULL
);
532 else if (target
->expr_type
== EXPR_FUNCTION
)
533 attr
= target
->symtree
->n
.sym
->attr
;
535 gcc_assert (0); /* Target must be a variable or a function. */
537 if (!attr
.pointer
&& !attr
.target
)
539 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
540 "or a TARGET", gfc_current_intrinsic_arg
[1],
541 gfc_current_intrinsic
, &target
->where
);
546 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
548 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
550 if (target
->rank
> 0)
552 for (i
= 0; i
< target
->rank
; i
++)
553 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
555 gfc_error ("Array section with a vector subscript at %L shall not "
556 "be the target of a pointer",
567 gfc_check_atan2 (gfc_expr
* y
, gfc_expr
* x
)
569 if (type_check (y
, 0, BT_REAL
) == FAILURE
)
571 if (same_type_check (y
, 0, x
, 1) == FAILURE
)
578 /* BESJN and BESYN functions. */
581 gfc_check_besn (gfc_expr
* n
, gfc_expr
* x
)
583 if (scalar_check (n
, 0) == FAILURE
)
586 if (type_check (n
, 0, BT_INTEGER
) == FAILURE
)
589 if (scalar_check (x
, 1) == FAILURE
)
592 if (type_check (x
, 1, BT_REAL
) == FAILURE
)
600 gfc_check_btest (gfc_expr
* i
, gfc_expr
* pos
)
602 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
604 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
612 gfc_check_char (gfc_expr
* i
, gfc_expr
* kind
)
614 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
616 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
624 gfc_check_chdir (gfc_expr
* dir
)
626 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
634 gfc_check_chdir_sub (gfc_expr
* dir
, gfc_expr
* status
)
636 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
642 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
645 if (scalar_check (status
, 1) == FAILURE
)
653 gfc_check_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
655 if (numeric_check (x
, 0) == FAILURE
)
660 if (numeric_check (y
, 1) == FAILURE
)
663 if (x
->ts
.type
== BT_COMPLEX
)
665 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
666 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
667 gfc_current_intrinsic
, &y
->where
);
672 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
680 gfc_check_complex (gfc_expr
* x
, gfc_expr
* y
)
682 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
685 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
686 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
, &x
->where
);
689 if (scalar_check (x
, 0) == FAILURE
)
692 if (y
->ts
.type
!= BT_INTEGER
&& y
->ts
.type
!= BT_REAL
)
695 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
696 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &y
->where
);
699 if (scalar_check (y
, 1) == FAILURE
)
707 gfc_check_count (gfc_expr
* mask
, gfc_expr
* dim
)
709 if (logical_array_check (mask
, 0) == FAILURE
)
711 if (dim_check (dim
, 1, 1) == FAILURE
)
719 gfc_check_cshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* dim
)
721 if (array_check (array
, 0) == FAILURE
)
724 if (array
->rank
== 1)
726 if (scalar_check (shift
, 1) == FAILURE
)
731 /* TODO: more requirements on shift parameter. */
734 if (dim_check (dim
, 2, 1) == FAILURE
)
742 gfc_check_ctime (gfc_expr
* time
)
744 if (scalar_check (time
, 0) == FAILURE
)
747 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
755 gfc_check_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
757 if (numeric_check (x
, 0) == FAILURE
)
762 if (numeric_check (y
, 1) == FAILURE
)
765 if (x
->ts
.type
== BT_COMPLEX
)
767 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
768 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg
[1],
769 gfc_current_intrinsic
, &y
->where
);
779 gfc_check_dble (gfc_expr
* x
)
781 if (numeric_check (x
, 0) == FAILURE
)
789 gfc_check_digits (gfc_expr
* x
)
791 if (int_or_real_check (x
, 0) == FAILURE
)
799 gfc_check_dot_product (gfc_expr
* vector_a
, gfc_expr
* vector_b
)
801 switch (vector_a
->ts
.type
)
804 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
811 if (numeric_check (vector_b
, 1) == FAILURE
)
816 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
817 "or LOGICAL", gfc_current_intrinsic_arg
[0],
818 gfc_current_intrinsic
, &vector_a
->where
);
822 if (rank_check (vector_a
, 0, 1) == FAILURE
)
825 if (rank_check (vector_b
, 1, 1) == FAILURE
)
828 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
830 gfc_error ("different shape for arguments '%s' and '%s' "
831 "at %L for intrinsic 'dot_product'",
832 gfc_current_intrinsic_arg
[0],
833 gfc_current_intrinsic_arg
[1],
843 gfc_check_eoshift (gfc_expr
* array
, gfc_expr
* shift
, gfc_expr
* boundary
,
846 if (array_check (array
, 0) == FAILURE
)
849 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
852 if (array
->rank
== 1)
854 if (scalar_check (shift
, 2) == FAILURE
)
859 /* TODO: more weird restrictions on shift. */
862 if (boundary
!= NULL
)
864 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
867 /* TODO: more restrictions on boundary. */
870 if (dim_check (dim
, 1, 1) == FAILURE
)
877 /* A single complex argument. */
880 gfc_check_fn_c (gfc_expr
* a
)
882 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
889 /* A single real argument. */
892 gfc_check_fn_r (gfc_expr
* a
)
894 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
901 /* A single real or complex argument. */
904 gfc_check_fn_rc (gfc_expr
* a
)
906 if (real_or_complex_check (a
, 0) == FAILURE
)
914 gfc_check_fnum (gfc_expr
* unit
)
916 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
919 if (scalar_check (unit
, 0) == FAILURE
)
926 /* This is used for the g77 one-argument Bessel functions, and the
930 gfc_check_g77_math1 (gfc_expr
* x
)
932 if (scalar_check (x
, 0) == FAILURE
)
935 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
943 gfc_check_huge (gfc_expr
* x
)
945 if (int_or_real_check (x
, 0) == FAILURE
)
952 /* Check that the single argument is an integer. */
955 gfc_check_i (gfc_expr
* i
)
957 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
965 gfc_check_iand (gfc_expr
* i
, gfc_expr
* j
)
967 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
970 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
973 if (i
->ts
.kind
!= j
->ts
.kind
)
975 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
976 &i
->where
) == FAILURE
)
985 gfc_check_ibclr (gfc_expr
* i
, gfc_expr
* pos
)
987 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
990 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
998 gfc_check_ibits (gfc_expr
* i
, gfc_expr
* pos
, gfc_expr
* len
)
1000 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1003 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1006 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1014 gfc_check_ibset (gfc_expr
* i
, gfc_expr
* pos
)
1016 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1019 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1027 gfc_check_ichar_iachar (gfc_expr
* c
)
1031 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
1034 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1040 /* Substring references don't have the charlength set. */
1042 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1045 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1049 /* Check that the argument is length one. Non-constant lengths
1050 can't be checked here, so assume thay are ok. */
1051 if (c
->ts
.cl
&& c
->ts
.cl
->length
)
1053 /* If we already have a length for this expression then use it. */
1054 if (c
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1056 i
= mpz_get_si (c
->ts
.cl
->length
->value
.integer
);
1063 start
= ref
->u
.ss
.start
;
1064 end
= ref
->u
.ss
.end
;
1067 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1068 || start
->expr_type
!= EXPR_CONSTANT
)
1071 i
= mpz_get_si (end
->value
.integer
) + 1
1072 - mpz_get_si (start
->value
.integer
);
1080 gfc_error ("Argument of %s at %L must be of length one",
1081 gfc_current_intrinsic
, &c
->where
);
1090 gfc_check_idnint (gfc_expr
* a
)
1092 if (double_check (a
, 0) == FAILURE
)
1100 gfc_check_ieor (gfc_expr
* i
, gfc_expr
* j
)
1102 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1105 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1108 if (i
->ts
.kind
!= j
->ts
.kind
)
1110 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1111 &i
->where
) == FAILURE
)
1120 gfc_check_index (gfc_expr
* string
, gfc_expr
* substring
, gfc_expr
* back
)
1122 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1123 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1127 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1130 if (string
->ts
.kind
!= substring
->ts
.kind
)
1132 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1133 "kind as '%s'", gfc_current_intrinsic_arg
[1],
1134 gfc_current_intrinsic
, &substring
->where
,
1135 gfc_current_intrinsic_arg
[0]);
1144 gfc_check_int (gfc_expr
* x
, gfc_expr
* kind
)
1146 if (numeric_check (x
, 0) == FAILURE
)
1151 if (type_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1154 if (scalar_check (kind
, 1) == FAILURE
)
1163 gfc_check_ior (gfc_expr
* i
, gfc_expr
* j
)
1165 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1168 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1171 if (i
->ts
.kind
!= j
->ts
.kind
)
1173 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1174 &i
->where
) == FAILURE
)
1183 gfc_check_ishft (gfc_expr
* i
, gfc_expr
* shift
)
1185 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1186 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1194 gfc_check_ishftc (gfc_expr
* i
, gfc_expr
* shift
, gfc_expr
* size
)
1196 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1197 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1200 if (size
!= NULL
&& type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1208 gfc_check_kill (gfc_expr
* pid
, gfc_expr
* sig
)
1210 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1213 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1221 gfc_check_kill_sub (gfc_expr
* pid
, gfc_expr
* sig
, gfc_expr
* status
)
1223 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
1226 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
1232 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1235 if (scalar_check (status
, 2) == FAILURE
)
1243 gfc_check_kind (gfc_expr
* x
)
1245 if (x
->ts
.type
== BT_DERIVED
)
1247 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1248 "non-derived type", gfc_current_intrinsic_arg
[0],
1249 gfc_current_intrinsic
, &x
->where
);
1258 gfc_check_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1260 if (array_check (array
, 0) == FAILURE
)
1265 if (dim_check (dim
, 1, 1) == FAILURE
)
1268 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
1276 gfc_check_link (gfc_expr
* path1
, gfc_expr
* path2
)
1278 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1281 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1289 gfc_check_link_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1291 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1294 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1300 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1303 if (scalar_check (status
, 2) == FAILURE
)
1310 gfc_check_loc (gfc_expr
*expr
)
1312 return variable_check (expr
, 0);
1317 gfc_check_symlnk (gfc_expr
* path1
, gfc_expr
* path2
)
1319 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1322 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1330 gfc_check_symlnk_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1332 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1335 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1341 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1344 if (scalar_check (status
, 2) == FAILURE
)
1352 gfc_check_logical (gfc_expr
* a
, gfc_expr
* kind
)
1354 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
1356 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
1363 /* Min/max family. */
1366 min_max_args (gfc_actual_arglist
* arg
)
1368 if (arg
== NULL
|| arg
->next
== NULL
)
1370 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1371 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
1380 check_rest (bt type
, int kind
, gfc_actual_arglist
* arg
)
1385 if (min_max_args (arg
) == FAILURE
)
1390 for (; arg
; arg
= arg
->next
, n
++)
1393 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
1395 if (x
->ts
.type
== type
)
1397 if (gfc_notify_std (GFC_STD_GNU
,
1398 "Extension: Different type kinds at %L", &x
->where
)
1404 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1405 n
, gfc_current_intrinsic
, &x
->where
,
1406 gfc_basic_typename (type
), kind
);
1417 gfc_check_min_max (gfc_actual_arglist
* arg
)
1421 if (min_max_args (arg
) == FAILURE
)
1426 if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
1429 ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1430 gfc_current_intrinsic
, &x
->where
);
1434 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
1439 gfc_check_min_max_integer (gfc_actual_arglist
* arg
)
1441 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
1446 gfc_check_min_max_real (gfc_actual_arglist
* arg
)
1448 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
1453 gfc_check_min_max_double (gfc_actual_arglist
* arg
)
1455 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
1458 /* End of min/max family. */
1461 gfc_check_malloc (gfc_expr
* size
)
1463 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
1466 if (scalar_check (size
, 0) == FAILURE
)
1474 gfc_check_matmul (gfc_expr
* matrix_a
, gfc_expr
* matrix_b
)
1476 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
1478 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1479 "or LOGICAL", gfc_current_intrinsic_arg
[0],
1480 gfc_current_intrinsic
, &matrix_a
->where
);
1484 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
1486 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1487 "or LOGICAL", gfc_current_intrinsic_arg
[1],
1488 gfc_current_intrinsic
, &matrix_b
->where
);
1492 switch (matrix_a
->rank
)
1495 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
1497 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1498 if (! identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
1500 gfc_error ("different shape on dimension 1 for arguments '%s' "
1501 "and '%s' at %L for intrinsic matmul",
1502 gfc_current_intrinsic_arg
[0],
1503 gfc_current_intrinsic_arg
[1],
1510 if (matrix_b
->rank
!= 2)
1512 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
1515 /* matrix_b has rank 1 or 2 here. Common check for the cases
1516 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1517 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1518 if (! identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
1520 gfc_error ("different shape on dimension 2 for argument '%s' and "
1521 "dimension 1 for argument '%s' at %L for intrinsic "
1522 "matmul", gfc_current_intrinsic_arg
[0],
1523 gfc_current_intrinsic_arg
[1], &matrix_a
->where
);
1529 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1530 "1 or 2", gfc_current_intrinsic_arg
[0],
1531 gfc_current_intrinsic
, &matrix_a
->where
);
1539 /* Whoever came up with this interface was probably on something.
1540 The possibilities for the occupation of the second and third
1547 NULL MASK minloc(array, mask=m)
1550 I.e. in the case of minloc(array,mask), mask will be in the second
1551 position of the argument list and we'll have to fix that up. */
1554 gfc_check_minloc_maxloc (gfc_actual_arglist
* ap
)
1556 gfc_expr
*a
, *m
, *d
;
1559 if (int_or_real_check (a
, 0) == FAILURE
1560 || array_check (a
, 0) == FAILURE
)
1564 m
= ap
->next
->next
->expr
;
1566 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1567 && ap
->next
->name
== NULL
)
1572 ap
->next
->expr
= NULL
;
1573 ap
->next
->next
->expr
= m
;
1576 if (dim_check (d
, 1, 1) == FAILURE
)
1579 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1582 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1588 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic %s",
1589 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1590 gfc_current_intrinsic
);
1591 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1599 /* Similar to minloc/maxloc, the argument list might need to be
1600 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1601 difference is that MINLOC/MAXLOC take an additional KIND argument.
1602 The possibilities are:
1608 NULL MASK minval(array, mask=m)
1611 I.e. in the case of minval(array,mask), mask will be in the second
1612 position of the argument list and we'll have to fix that up. */
1615 check_reduction (gfc_actual_arglist
* ap
)
1617 gfc_expr
*a
, *m
, *d
;
1621 m
= ap
->next
->next
->expr
;
1623 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
1624 && ap
->next
->name
== NULL
)
1629 ap
->next
->expr
= NULL
;
1630 ap
->next
->next
->expr
= m
;
1633 if (dim_check (d
, 1, 1) == FAILURE
)
1636 if (d
&& dim_rank_check (d
, a
, 0) == FAILURE
)
1639 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
1645 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic %s",
1646 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1647 gfc_current_intrinsic
);
1648 if (gfc_check_conformance (buffer
, a
, m
) == FAILURE
)
1657 gfc_check_minval_maxval (gfc_actual_arglist
* ap
)
1659 if (int_or_real_check (ap
->expr
, 0) == FAILURE
1660 || array_check (ap
->expr
, 0) == FAILURE
)
1663 return check_reduction (ap
);
1668 gfc_check_product_sum (gfc_actual_arglist
* ap
)
1670 if (numeric_check (ap
->expr
, 0) == FAILURE
1671 || array_check (ap
->expr
, 0) == FAILURE
)
1674 return check_reduction (ap
);
1679 gfc_check_merge (gfc_expr
* tsource
, gfc_expr
* fsource
, gfc_expr
* mask
)
1683 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
1686 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
1689 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic '%s'",
1690 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[1],
1691 gfc_current_intrinsic
);
1692 if (gfc_check_conformance (buffer
, tsource
, fsource
) == FAILURE
)
1695 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic '%s'",
1696 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[2],
1697 gfc_current_intrinsic
);
1698 if (gfc_check_conformance (buffer
, tsource
, mask
) == FAILURE
)
1706 gfc_check_nearest (gfc_expr
* x
, gfc_expr
* s
)
1708 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1711 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
1719 gfc_check_null (gfc_expr
* mold
)
1721 symbol_attribute attr
;
1726 if (variable_check (mold
, 0) == FAILURE
)
1729 attr
= gfc_variable_attr (mold
, NULL
);
1733 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1734 gfc_current_intrinsic_arg
[0],
1735 gfc_current_intrinsic
, &mold
->where
);
1744 gfc_check_pack (gfc_expr
* array
, gfc_expr
* mask
, gfc_expr
* vector
)
1748 if (array_check (array
, 0) == FAILURE
)
1751 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
1754 snprintf(buffer
, sizeof(buffer
), "arguments '%s' and '%s' for intrinsic '%s'",
1755 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic_arg
[1],
1756 gfc_current_intrinsic
);
1757 if (gfc_check_conformance (buffer
, array
, mask
) == FAILURE
)
1762 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
1765 if (rank_check (vector
, 2, 1) == FAILURE
)
1768 /* TODO: More constraints here. */
1776 gfc_check_precision (gfc_expr
* x
)
1778 if (x
->ts
.type
!= BT_REAL
&& x
->ts
.type
!= BT_COMPLEX
)
1780 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1781 "REAL or COMPLEX", gfc_current_intrinsic_arg
[0],
1782 gfc_current_intrinsic
, &x
->where
);
1791 gfc_check_present (gfc_expr
* a
)
1795 if (variable_check (a
, 0) == FAILURE
)
1798 sym
= a
->symtree
->n
.sym
;
1799 if (!sym
->attr
.dummy
)
1801 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1802 "dummy variable", gfc_current_intrinsic_arg
[0],
1803 gfc_current_intrinsic
, &a
->where
);
1807 if (!sym
->attr
.optional
)
1809 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1810 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg
[0],
1811 gfc_current_intrinsic
, &a
->where
);
1820 gfc_check_radix (gfc_expr
* x
)
1822 if (int_or_real_check (x
, 0) == FAILURE
)
1830 gfc_check_range (gfc_expr
* x
)
1832 if (numeric_check (x
, 0) == FAILURE
)
1839 /* real, float, sngl. */
1841 gfc_check_real (gfc_expr
* a
, gfc_expr
* kind
)
1843 if (numeric_check (a
, 0) == FAILURE
)
1846 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
1854 gfc_check_rename (gfc_expr
* path1
, gfc_expr
* path2
)
1856 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1859 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1867 gfc_check_rename_sub (gfc_expr
* path1
, gfc_expr
* path2
, gfc_expr
* status
)
1869 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
1872 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
1878 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1881 if (scalar_check (status
, 2) == FAILURE
)
1889 gfc_check_repeat (gfc_expr
* x
, gfc_expr
* y
)
1891 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1894 if (scalar_check (x
, 0) == FAILURE
)
1897 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
1900 if (scalar_check (y
, 1) == FAILURE
)
1908 gfc_check_reshape (gfc_expr
* source
, gfc_expr
* shape
,
1909 gfc_expr
* pad
, gfc_expr
* order
)
1914 if (array_check (source
, 0) == FAILURE
)
1917 if (rank_check (shape
, 1, 1) == FAILURE
)
1920 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
1923 if (gfc_array_size (shape
, &size
) != SUCCESS
)
1925 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1926 "array of constant size", &shape
->where
);
1930 m
= mpz_cmp_ui (size
, GFC_MAX_DIMENSIONS
);
1935 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
1936 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
1942 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
1944 if (array_check (pad
, 2) == FAILURE
)
1948 if (order
!= NULL
&& array_check (order
, 3) == FAILURE
)
1956 gfc_check_scale (gfc_expr
* x
, gfc_expr
* i
)
1958 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1961 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
1969 gfc_check_scan (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1971 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
1974 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
1977 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
1980 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1988 gfc_check_secnds (gfc_expr
* r
)
1991 if (type_check (r
, 0, BT_REAL
) == FAILURE
)
1994 if (kind_value_check (r
, 0, 4) == FAILURE
)
1997 if (scalar_check (r
, 0) == FAILURE
)
2005 gfc_check_selected_int_kind (gfc_expr
* r
)
2008 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
2011 if (scalar_check (r
, 0) == FAILURE
)
2019 gfc_check_selected_real_kind (gfc_expr
* p
, gfc_expr
* r
)
2021 if (p
== NULL
&& r
== NULL
)
2023 gfc_error ("Missing arguments to %s intrinsic at %L",
2024 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2029 if (p
!= NULL
&& type_check (p
, 0, BT_INTEGER
) == FAILURE
)
2032 if (r
!= NULL
&& type_check (r
, 1, BT_INTEGER
) == FAILURE
)
2040 gfc_check_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
2042 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2045 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
2053 gfc_check_shape (gfc_expr
* source
)
2057 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
2060 ar
= gfc_find_array_ref (source
);
2062 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
)
2064 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2065 "an assumed size array", &source
->where
);
2074 gfc_check_sign (gfc_expr
* a
, gfc_expr
* b
)
2076 if (int_or_real_check (a
, 0) == FAILURE
)
2079 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
2087 gfc_check_size (gfc_expr
* array
, gfc_expr
* dim
)
2089 if (array_check (array
, 0) == FAILURE
)
2094 if (type_check (dim
, 1, BT_INTEGER
) == FAILURE
)
2097 if (kind_value_check (dim
, 1, gfc_default_integer_kind
) == FAILURE
)
2100 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2109 gfc_check_sleep_sub (gfc_expr
* seconds
)
2111 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
2114 if (scalar_check (seconds
, 0) == FAILURE
)
2122 gfc_check_spread (gfc_expr
* source
, gfc_expr
* dim
, gfc_expr
* ncopies
)
2124 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
2126 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2127 "than rank %d", gfc_current_intrinsic_arg
[0],
2128 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
2133 if (dim_check (dim
, 1, 0) == FAILURE
)
2136 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
2139 if (scalar_check (ncopies
, 2) == FAILURE
)
2146 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2149 gfc_check_fgetputc_sub (gfc_expr
* unit
, gfc_expr
* c
, gfc_expr
* status
)
2151 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2154 if (scalar_check (unit
, 0) == FAILURE
)
2157 if (type_check (c
, 1, BT_CHARACTER
) == FAILURE
)
2163 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2164 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
2165 || scalar_check (status
, 2) == FAILURE
)
2173 gfc_check_fgetputc (gfc_expr
* unit
, gfc_expr
* c
)
2175 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
2180 gfc_check_fgetput_sub (gfc_expr
* c
, gfc_expr
* status
)
2182 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
2188 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
2189 || kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
2190 || scalar_check (status
, 1) == FAILURE
)
2198 gfc_check_fgetput (gfc_expr
* c
)
2200 return gfc_check_fgetput_sub (c
, NULL
);
2205 gfc_check_fstat (gfc_expr
* unit
, gfc_expr
* array
)
2207 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2210 if (scalar_check (unit
, 0) == FAILURE
)
2213 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2214 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
2217 if (array_check (array
, 1) == FAILURE
)
2225 gfc_check_fstat_sub (gfc_expr
* unit
, gfc_expr
* array
, gfc_expr
* status
)
2227 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2230 if (scalar_check (unit
, 0) == FAILURE
)
2233 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2234 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2237 if (array_check (array
, 1) == FAILURE
)
2243 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2244 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
2247 if (scalar_check (status
, 2) == FAILURE
)
2255 gfc_check_ftell (gfc_expr
* unit
)
2257 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2260 if (scalar_check (unit
, 0) == FAILURE
)
2268 gfc_check_ftell_sub (gfc_expr
* unit
, gfc_expr
* offset
)
2270 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2273 if (scalar_check (unit
, 0) == FAILURE
)
2276 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
2279 if (scalar_check (offset
, 1) == FAILURE
)
2287 gfc_check_stat (gfc_expr
* name
, gfc_expr
* array
)
2289 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2292 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2293 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2296 if (array_check (array
, 1) == FAILURE
)
2304 gfc_check_stat_sub (gfc_expr
* name
, gfc_expr
* array
, gfc_expr
* status
)
2306 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2309 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
2310 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2313 if (array_check (array
, 1) == FAILURE
)
2319 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
2320 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
2323 if (scalar_check (status
, 2) == FAILURE
)
2331 gfc_check_transfer (gfc_expr
* source ATTRIBUTE_UNUSED
,
2332 gfc_expr
* mold ATTRIBUTE_UNUSED
,
2337 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
2340 if (scalar_check (size
, 2) == FAILURE
)
2343 if (nonoptional_check (size
, 2) == FAILURE
)
2352 gfc_check_transpose (gfc_expr
* matrix
)
2354 if (rank_check (matrix
, 0, 2) == FAILURE
)
2362 gfc_check_ubound (gfc_expr
* array
, gfc_expr
* dim
)
2364 if (array_check (array
, 0) == FAILURE
)
2369 if (dim_check (dim
, 1, 1) == FAILURE
)
2372 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
2381 gfc_check_unpack (gfc_expr
* vector
, gfc_expr
* mask
, gfc_expr
* field
)
2383 if (rank_check (vector
, 0, 1) == FAILURE
)
2386 if (array_check (mask
, 1) == FAILURE
)
2389 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2392 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
2400 gfc_check_verify (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
2402 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2405 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
2408 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
2416 gfc_check_trim (gfc_expr
* x
)
2418 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
2421 if (scalar_check (x
, 0) == FAILURE
)
2429 gfc_check_ttynam (gfc_expr
* unit
)
2431 if (scalar_check (unit
, 0) == FAILURE
)
2434 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2441 /* Common check function for the half a dozen intrinsics that have a
2442 single real argument. */
2445 gfc_check_x (gfc_expr
* x
)
2447 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2454 /************* Check functions for intrinsic subroutines *************/
2457 gfc_check_cpu_time (gfc_expr
* time
)
2459 if (scalar_check (time
, 0) == FAILURE
)
2462 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2465 if (variable_check (time
, 0) == FAILURE
)
2473 gfc_check_date_and_time (gfc_expr
* date
, gfc_expr
* time
,
2474 gfc_expr
* zone
, gfc_expr
* values
)
2478 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
2480 if (scalar_check (date
, 0) == FAILURE
)
2482 if (variable_check (date
, 0) == FAILURE
)
2488 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
2490 if (scalar_check (time
, 1) == FAILURE
)
2492 if (variable_check (time
, 1) == FAILURE
)
2498 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
2500 if (scalar_check (zone
, 2) == FAILURE
)
2502 if (variable_check (zone
, 2) == FAILURE
)
2508 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
2510 if (array_check (values
, 3) == FAILURE
)
2512 if (rank_check (values
, 3, 1) == FAILURE
)
2514 if (variable_check (values
, 3) == FAILURE
)
2523 gfc_check_mvbits (gfc_expr
* from
, gfc_expr
* frompos
, gfc_expr
* len
,
2524 gfc_expr
* to
, gfc_expr
* topos
)
2526 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
2529 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
2532 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
2535 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
2538 if (variable_check (to
, 3) == FAILURE
)
2541 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
2549 gfc_check_random_number (gfc_expr
* harvest
)
2551 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
2554 if (variable_check (harvest
, 0) == FAILURE
)
2562 gfc_check_random_seed (gfc_expr
* size
, gfc_expr
* put
, gfc_expr
* get
)
2566 if (scalar_check (size
, 0) == FAILURE
)
2569 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
2572 if (variable_check (size
, 0) == FAILURE
)
2575 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
2583 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
2586 if (array_check (put
, 1) == FAILURE
)
2589 if (rank_check (put
, 1, 1) == FAILURE
)
2592 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
2595 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
2602 if (size
!= NULL
|| put
!= NULL
)
2603 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
,
2606 if (array_check (get
, 2) == FAILURE
)
2609 if (rank_check (get
, 2, 1) == FAILURE
)
2612 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
2615 if (variable_check (get
, 2) == FAILURE
)
2618 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
2626 gfc_check_second_sub (gfc_expr
* time
)
2628 if (scalar_check (time
, 0) == FAILURE
)
2631 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
2634 if (kind_value_check(time
, 0, 4) == FAILURE
)
2641 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2642 count, count_rate, and count_max are all optional arguments */
2645 gfc_check_system_clock (gfc_expr
* count
, gfc_expr
* count_rate
,
2646 gfc_expr
* count_max
)
2650 if (scalar_check (count
, 0) == FAILURE
)
2653 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
2656 if (variable_check (count
, 0) == FAILURE
)
2660 if (count_rate
!= NULL
)
2662 if (scalar_check (count_rate
, 1) == FAILURE
)
2665 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
2668 if (variable_check (count_rate
, 1) == FAILURE
)
2672 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
2677 if (count_max
!= NULL
)
2679 if (scalar_check (count_max
, 2) == FAILURE
)
2682 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
2685 if (variable_check (count_max
, 2) == FAILURE
)
2689 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
2692 if (count_rate
!= NULL
2693 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
2701 gfc_check_irand (gfc_expr
* x
)
2706 if (scalar_check (x
, 0) == FAILURE
)
2709 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2712 if (kind_value_check(x
, 0, 4) == FAILURE
)
2720 gfc_check_alarm_sub (gfc_expr
* seconds
, gfc_expr
* handler
, gfc_expr
* status
)
2722 if (scalar_check (seconds
, 0) == FAILURE
)
2725 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
2728 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
2731 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2732 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &handler
->where
);
2736 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
2742 if (scalar_check (status
, 2) == FAILURE
)
2745 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2753 gfc_check_rand (gfc_expr
* x
)
2758 if (scalar_check (x
, 0) == FAILURE
)
2761 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2764 if (kind_value_check(x
, 0, 4) == FAILURE
)
2771 gfc_check_srand (gfc_expr
* x
)
2773 if (scalar_check (x
, 0) == FAILURE
)
2776 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
2779 if (kind_value_check(x
, 0, 4) == FAILURE
)
2786 gfc_check_ctime_sub (gfc_expr
* time
, gfc_expr
* result
)
2788 if (scalar_check (time
, 0) == FAILURE
)
2791 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
2794 if (type_check (result
, 1, BT_CHARACTER
) == FAILURE
)
2801 gfc_check_etime (gfc_expr
* x
)
2803 if (array_check (x
, 0) == FAILURE
)
2806 if (rank_check (x
, 0, 1) == FAILURE
)
2809 if (variable_check (x
, 0) == FAILURE
)
2812 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2815 if (kind_value_check(x
, 0, 4) == FAILURE
)
2822 gfc_check_etime_sub (gfc_expr
* values
, gfc_expr
* time
)
2824 if (array_check (values
, 0) == FAILURE
)
2827 if (rank_check (values
, 0, 1) == FAILURE
)
2830 if (variable_check (values
, 0) == FAILURE
)
2833 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
2836 if (kind_value_check(values
, 0, 4) == FAILURE
)
2839 if (scalar_check (time
, 1) == FAILURE
)
2842 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
2845 if (kind_value_check(time
, 1, 4) == FAILURE
)
2853 gfc_check_fdate_sub (gfc_expr
* date
)
2855 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
2863 gfc_check_gerror (gfc_expr
* msg
)
2865 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
2873 gfc_check_getcwd_sub (gfc_expr
* cwd
, gfc_expr
* status
)
2875 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
2881 if (scalar_check (status
, 1) == FAILURE
)
2884 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
2892 gfc_check_getlog (gfc_expr
* msg
)
2894 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
2902 gfc_check_exit (gfc_expr
* status
)
2907 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
2910 if (scalar_check (status
, 0) == FAILURE
)
2918 gfc_check_flush (gfc_expr
* unit
)
2923 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2926 if (scalar_check (unit
, 0) == FAILURE
)
2934 gfc_check_free (gfc_expr
* i
)
2936 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
2939 if (scalar_check (i
, 0) == FAILURE
)
2947 gfc_check_hostnm (gfc_expr
* name
)
2949 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2957 gfc_check_hostnm_sub (gfc_expr
* name
, gfc_expr
* status
)
2959 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
2965 if (scalar_check (status
, 1) == FAILURE
)
2968 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
2976 gfc_check_ttynam_sub (gfc_expr
* unit
, gfc_expr
* name
)
2978 if (scalar_check (unit
, 0) == FAILURE
)
2981 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
2984 if (type_check (name
, 1, BT_CHARACTER
) == FAILURE
)
2992 gfc_check_isatty (gfc_expr
* unit
)
2997 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3000 if (scalar_check (unit
, 0) == FAILURE
)
3008 gfc_check_perror (gfc_expr
* string
)
3010 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
3018 gfc_check_umask (gfc_expr
* mask
)
3020 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3023 if (scalar_check (mask
, 0) == FAILURE
)
3031 gfc_check_umask_sub (gfc_expr
* mask
, gfc_expr
* old
)
3033 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
3036 if (scalar_check (mask
, 0) == FAILURE
)
3042 if (scalar_check (old
, 1) == FAILURE
)
3045 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
3053 gfc_check_unlink (gfc_expr
* name
)
3055 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3063 gfc_check_unlink_sub (gfc_expr
* name
, gfc_expr
* status
)
3065 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3071 if (scalar_check (status
, 1) == FAILURE
)
3074 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3082 gfc_check_signal (gfc_expr
* number
, gfc_expr
* handler
)
3084 if (scalar_check (number
, 0) == FAILURE
)
3087 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3090 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3093 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3094 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &handler
->where
);
3098 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3106 gfc_check_signal_sub (gfc_expr
* number
, gfc_expr
* handler
, gfc_expr
* status
)
3108 if (scalar_check (number
, 0) == FAILURE
)
3111 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
3114 if (handler
->ts
.type
!= BT_INTEGER
&& handler
->ts
.type
!= BT_PROCEDURE
)
3117 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3118 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &handler
->where
);
3122 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
3128 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3131 if (scalar_check (status
, 2) == FAILURE
)
3139 gfc_check_system_sub (gfc_expr
* cmd
, gfc_expr
* status
)
3141 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
3144 if (scalar_check (status
, 1) == FAILURE
)
3147 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
3150 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)
3157 /* This is used for the GNU intrinsics AND, OR and XOR. */
3159 gfc_check_and (gfc_expr
* i
, gfc_expr
* j
)
3161 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
3164 "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3165 gfc_current_intrinsic_arg
[0], gfc_current_intrinsic
, &i
->where
);
3169 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
3172 "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3173 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
, &j
->where
);
3177 if (i
->ts
.type
!= j
->ts
.type
)
3179 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3180 "have the same type", gfc_current_intrinsic_arg
[0],
3181 gfc_current_intrinsic_arg
[1], gfc_current_intrinsic
,
3186 if (scalar_check (i
, 0) == FAILURE
)
3189 if (scalar_check (j
, 1) == FAILURE
)