2 Copyright (C) 2002-2016 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 3, 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 COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 /* Users sometime use a subroutine designator as an actual argument to
76 an intrinsic subprogram that expects an argument with a numeric type. */
77 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
80 if (gfc_numeric_ts (&e
->ts
))
83 /* If the expression has not got a type, check if its namespace can
84 offer a default type. */
85 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
86 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
87 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
88 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
90 e
->ts
= e
->symtree
->n
.sym
->ts
;
96 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
97 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
104 /* Check that an expression is integer or real. */
107 int_or_real_check (gfc_expr
*e
, int n
)
109 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
111 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
112 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
113 gfc_current_intrinsic
, &e
->where
);
121 /* Check that an expression is real or complex. */
124 real_or_complex_check (gfc_expr
*e
, int n
)
126 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
128 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
129 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
130 gfc_current_intrinsic
, &e
->where
);
138 /* Check that an expression is INTEGER or PROCEDURE. */
141 int_or_proc_check (gfc_expr
*e
, int n
)
143 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
145 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
146 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
147 gfc_current_intrinsic
, &e
->where
);
155 /* Check that the expression is an optional constant integer
156 and that it specifies a valid kind for that type. */
159 kind_check (gfc_expr
*k
, int n
, bt type
)
166 if (!type_check (k
, n
, BT_INTEGER
))
169 if (!scalar_check (k
, n
))
172 if (!gfc_check_init_expr (k
))
174 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
175 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
180 if (gfc_extract_int (k
, &kind
) != NULL
181 || gfc_validate_kind (type
, kind
, true) < 0)
183 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
192 /* Make sure the expression is a double precision real. */
195 double_check (gfc_expr
*d
, int n
)
197 if (!type_check (d
, n
, BT_REAL
))
200 if (d
->ts
.kind
!= gfc_default_double_kind
)
202 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
203 "precision", gfc_current_intrinsic_arg
[n
]->name
,
204 gfc_current_intrinsic
, &d
->where
);
213 coarray_check (gfc_expr
*e
, int n
)
215 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
216 && CLASS_DATA (e
)->attr
.codimension
217 && CLASS_DATA (e
)->as
->corank
)
219 gfc_add_class_array_ref (e
);
223 if (!gfc_is_coarray (e
))
225 gfc_error ("Expected coarray variable as %qs argument to the %s "
226 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
227 gfc_current_intrinsic
, &e
->where
);
235 /* Make sure the expression is a logical array. */
238 logical_array_check (gfc_expr
*array
, int n
)
240 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
242 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
243 "array", gfc_current_intrinsic_arg
[n
]->name
,
244 gfc_current_intrinsic
, &array
->where
);
252 /* Make sure an expression is an array. */
255 array_check (gfc_expr
*e
, int n
)
257 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
258 && CLASS_DATA (e
)->attr
.dimension
259 && CLASS_DATA (e
)->as
->rank
)
261 gfc_add_class_array_ref (e
);
265 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
268 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
269 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
276 /* If expr is a constant, then check to ensure that it is greater than
280 nonnegative_check (const char *arg
, gfc_expr
*expr
)
284 if (expr
->expr_type
== EXPR_CONSTANT
)
286 gfc_extract_int (expr
, &i
);
289 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
298 /* If expr2 is constant, then check that the value is less than
299 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
302 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
303 gfc_expr
*expr2
, bool or_equal
)
307 if (expr2
->expr_type
== EXPR_CONSTANT
)
309 gfc_extract_int (expr2
, &i2
);
310 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
312 /* For ISHFT[C], check that |shift| <= bit_size(i). */
318 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
320 gfc_error ("The absolute value of SHIFT at %L must be less "
321 "than or equal to BIT_SIZE(%qs)",
322 &expr2
->where
, arg1
);
329 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
331 gfc_error ("%qs at %L must be less than "
332 "or equal to BIT_SIZE(%qs)",
333 arg2
, &expr2
->where
, arg1
);
339 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
341 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
342 arg2
, &expr2
->where
, arg1
);
352 /* If expr is constant, then check that the value is less than or equal
353 to the bit_size of the kind k. */
356 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
360 if (expr
->expr_type
!= EXPR_CONSTANT
)
363 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
364 gfc_extract_int (expr
, &val
);
366 if (val
> gfc_integer_kinds
[i
].bit_size
)
368 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
369 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
377 /* If expr2 and expr3 are constants, then check that the value is less than
378 or equal to bit_size(expr1). */
381 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
382 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
386 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
388 gfc_extract_int (expr2
, &i2
);
389 gfc_extract_int (expr3
, &i3
);
391 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
392 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
394 gfc_error ("%<%s + %s%> at %L must be less than or equal "
396 arg2
, arg3
, &expr2
->where
, arg1
);
404 /* Make sure two expressions have the same type. */
407 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
409 gfc_typespec
*ets
= &e
->ts
;
410 gfc_typespec
*fts
= &f
->ts
;
412 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
413 ets
= &e
->symtree
->n
.sym
->ts
;
414 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
415 fts
= &f
->symtree
->n
.sym
->ts
;
417 if (gfc_compare_types (ets
, fts
))
420 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
421 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
422 gfc_current_intrinsic
, &f
->where
,
423 gfc_current_intrinsic_arg
[n
]->name
);
429 /* Make sure that an expression has a certain (nonzero) rank. */
432 rank_check (gfc_expr
*e
, int n
, int rank
)
437 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
438 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
445 /* Make sure a variable expression is not an optional dummy argument. */
448 nonoptional_check (gfc_expr
*e
, int n
)
450 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
452 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
453 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
457 /* TODO: Recursive check on nonoptional variables? */
463 /* Check for ALLOCATABLE attribute. */
466 allocatable_check (gfc_expr
*e
, int n
)
468 symbol_attribute attr
;
470 attr
= gfc_variable_attr (e
, NULL
);
471 if (!attr
.allocatable
|| attr
.associate_var
)
473 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
474 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
483 /* Check that an expression has a particular kind. */
486 kind_value_check (gfc_expr
*e
, int n
, int k
)
491 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
492 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
499 /* Make sure an expression is a variable. */
502 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
504 if (e
->expr_type
== EXPR_VARIABLE
505 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
506 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
507 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
510 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
511 && CLASS_DATA (e
->symtree
->n
.sym
)
512 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
513 : e
->symtree
->n
.sym
->attr
.pointer
;
515 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
517 if (pointer
&& ref
->type
== REF_COMPONENT
)
519 if (ref
->type
== REF_COMPONENT
520 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
521 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
522 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
523 && ref
->u
.c
.component
->attr
.pointer
)))
529 gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
530 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
531 gfc_current_intrinsic
, &e
->where
);
536 if (e
->expr_type
== EXPR_VARIABLE
537 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
538 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
541 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
542 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
545 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
546 if (ns
->proc_name
== e
->symtree
->n
.sym
)
550 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
551 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
557 /* Check the common DIM parameter for correctness. */
560 dim_check (gfc_expr
*dim
, int n
, bool optional
)
565 if (!type_check (dim
, n
, BT_INTEGER
))
568 if (!scalar_check (dim
, n
))
571 if (!optional
&& !nonoptional_check (dim
, n
))
578 /* If a coarray DIM parameter is a constant, make sure that it is greater than
579 zero and less than or equal to the corank of the given array. */
582 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
586 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
588 if (dim
->expr_type
!= EXPR_CONSTANT
)
591 if (array
->ts
.type
== BT_CLASS
)
594 corank
= gfc_get_corank (array
);
596 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
597 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
599 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
600 "codimension index", gfc_current_intrinsic
, &dim
->where
);
609 /* If a DIM parameter is a constant, make sure that it is greater than
610 zero and less than or equal to the rank of the given array. If
611 allow_assumed is zero then dim must be less than the rank of the array
612 for assumed size arrays. */
615 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
623 if (dim
->expr_type
!= EXPR_CONSTANT
)
626 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
627 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
628 rank
= array
->rank
+ 1;
632 /* Assumed-rank array. */
634 rank
= GFC_MAX_DIMENSIONS
;
636 if (array
->expr_type
== EXPR_VARIABLE
)
638 ar
= gfc_find_array_ref (array
);
639 if (ar
->as
->type
== AS_ASSUMED_SIZE
641 && ar
->type
!= AR_ELEMENT
642 && ar
->type
!= AR_SECTION
)
646 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
647 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
649 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
650 "dimension index", gfc_current_intrinsic
, &dim
->where
);
659 /* Compare the size of a along dimension ai with the size of b along
660 dimension bi, returning 0 if they are known not to be identical,
661 and 1 if they are identical, or if this cannot be determined. */
664 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
666 mpz_t a_size
, b_size
;
669 gcc_assert (a
->rank
> ai
);
670 gcc_assert (b
->rank
> bi
);
674 if (gfc_array_dimen_size (a
, ai
, &a_size
))
676 if (gfc_array_dimen_size (b
, bi
, &b_size
))
678 if (mpz_cmp (a_size
, b_size
) != 0)
688 /* Calculate the length of a character variable, including substrings.
689 Strip away parentheses if necessary. Return -1 if no length could
693 gfc_var_strlen (const gfc_expr
*a
)
697 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
700 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
710 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
711 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
713 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
715 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
716 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
718 else if (ra
->u
.ss
.start
719 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
725 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
726 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
727 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
728 else if (a
->expr_type
== EXPR_CONSTANT
729 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
730 return a
->value
.character
.length
;
736 /* Check whether two character expressions have the same length;
737 returns true if they have or if the length cannot be determined,
738 otherwise return false and raise a gfc_error. */
741 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
745 len_a
= gfc_var_strlen(a
);
746 len_b
= gfc_var_strlen(b
);
748 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
752 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
753 len_a
, len_b
, name
, &a
->where
);
759 /***** Check functions *****/
761 /* Check subroutine suitable for intrinsics taking a real argument and
762 a kind argument for the result. */
765 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
767 if (!type_check (a
, 0, BT_REAL
))
769 if (!kind_check (kind
, 1, type
))
776 /* Check subroutine suitable for ceiling, floor and nint. */
779 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
781 return check_a_kind (a
, kind
, BT_INTEGER
);
785 /* Check subroutine suitable for aint, anint. */
788 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
790 return check_a_kind (a
, kind
, BT_REAL
);
795 gfc_check_abs (gfc_expr
*a
)
797 if (!numeric_check (a
, 0))
805 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
807 if (!type_check (a
, 0, BT_INTEGER
))
809 if (!kind_check (kind
, 1, BT_CHARACTER
))
817 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
819 if (!type_check (name
, 0, BT_CHARACTER
)
820 || !scalar_check (name
, 0))
822 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
825 if (!type_check (mode
, 1, BT_CHARACTER
)
826 || !scalar_check (mode
, 1))
828 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
836 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
838 if (!logical_array_check (mask
, 0))
841 if (!dim_check (dim
, 1, false))
844 if (!dim_rank_check (dim
, mask
, 0))
852 gfc_check_allocated (gfc_expr
*array
)
854 if (!variable_check (array
, 0, false))
856 if (!allocatable_check (array
, 0))
863 /* Common check function where the first argument must be real or
864 integer and the second argument must be the same as the first. */
867 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
869 if (!int_or_real_check (a
, 0))
872 if (a
->ts
.type
!= p
->ts
.type
)
874 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
875 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
876 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
881 if (a
->ts
.kind
!= p
->ts
.kind
)
883 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
893 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
895 if (!double_check (x
, 0) || !double_check (y
, 1))
903 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
905 symbol_attribute attr1
, attr2
;
910 where
= &pointer
->where
;
912 if (pointer
->expr_type
== EXPR_NULL
)
915 attr1
= gfc_expr_attr (pointer
);
917 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
919 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
920 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
926 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
928 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
929 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
930 gfc_current_intrinsic
, &pointer
->where
);
934 /* Target argument is optional. */
938 where
= &target
->where
;
939 if (target
->expr_type
== EXPR_NULL
)
942 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
943 attr2
= gfc_expr_attr (target
);
946 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
947 "or target VARIABLE or FUNCTION",
948 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
953 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
955 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
956 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
957 gfc_current_intrinsic
, &target
->where
);
962 if (attr1
.pointer
&& gfc_is_coindexed (target
))
964 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
965 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
966 gfc_current_intrinsic
, &target
->where
);
971 if (!same_type_check (pointer
, 0, target
, 1))
973 if (!rank_check (target
, 0, pointer
->rank
))
975 if (target
->rank
> 0)
977 for (i
= 0; i
< target
->rank
; i
++)
978 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
980 gfc_error ("Array section with a vector subscript at %L shall not "
981 "be the target of a pointer",
991 gfc_error ("NULL pointer at %L is not permitted as actual argument "
992 "of %qs intrinsic function", where
, gfc_current_intrinsic
);
999 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1001 /* gfc_notify_std would be a waste of time as the return value
1002 is seemingly used only for the generic resolution. The error
1003 will be: Too many arguments. */
1004 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1007 return gfc_check_atan2 (y
, x
);
1012 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1014 if (!type_check (y
, 0, BT_REAL
))
1016 if (!same_type_check (y
, 0, x
, 1))
1024 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1025 gfc_expr
*stat
, int stat_no
)
1027 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1030 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1031 && !(atom
->ts
.type
== BT_LOGICAL
1032 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1034 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1035 "integer of ATOMIC_INT_KIND or a logical of "
1036 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1040 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1042 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1043 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1047 if (atom
->ts
.type
!= value
->ts
.type
)
1049 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1050 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1051 gfc_current_intrinsic
, &value
->where
,
1052 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1058 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1060 if (!scalar_check (stat
, stat_no
))
1062 if (!variable_check (stat
, stat_no
, false))
1064 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1067 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1068 gfc_current_intrinsic
, &stat
->where
))
1077 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1079 if (atom
->expr_type
== EXPR_FUNCTION
1080 && atom
->value
.function
.isym
1081 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1082 atom
= atom
->value
.function
.actual
->expr
;
1084 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1086 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1087 "definable", gfc_current_intrinsic
, &atom
->where
);
1091 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1096 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1098 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1100 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1101 "integer of ATOMIC_INT_KIND", &atom
->where
,
1102 gfc_current_intrinsic
);
1106 return gfc_check_atomic_def (atom
, value
, stat
);
1111 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1113 if (atom
->expr_type
== EXPR_FUNCTION
1114 && atom
->value
.function
.isym
1115 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1116 atom
= atom
->value
.function
.actual
->expr
;
1118 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1120 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1121 "definable", gfc_current_intrinsic
, &value
->where
);
1125 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1130 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1131 gfc_expr
*new_val
, gfc_expr
*stat
)
1133 if (atom
->expr_type
== EXPR_FUNCTION
1134 && atom
->value
.function
.isym
1135 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1136 atom
= atom
->value
.function
.actual
->expr
;
1138 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1141 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1144 if (!same_type_check (atom
, 0, old
, 1))
1147 if (!same_type_check (atom
, 0, compare
, 2))
1150 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1152 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1153 "definable", gfc_current_intrinsic
, &atom
->where
);
1157 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1159 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1160 "definable", gfc_current_intrinsic
, &old
->where
);
1168 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1170 if (event
->ts
.type
!= BT_DERIVED
1171 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1172 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1174 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1175 "shall be of type EVENT_TYPE", &event
->where
);
1179 if (!scalar_check (event
, 0))
1182 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1184 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1185 "shall be definable", &count
->where
);
1189 if (!type_check (count
, 1, BT_INTEGER
))
1192 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1193 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1195 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1197 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1198 "shall have at least the range of the default integer",
1205 if (!type_check (stat
, 2, BT_INTEGER
))
1207 if (!scalar_check (stat
, 2))
1209 if (!variable_check (stat
, 2, false))
1212 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1213 gfc_current_intrinsic
, &stat
->where
))
1222 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1225 if (atom
->expr_type
== EXPR_FUNCTION
1226 && atom
->value
.function
.isym
1227 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1228 atom
= atom
->value
.function
.actual
->expr
;
1230 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1232 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1233 "integer of ATOMIC_INT_KIND", &atom
->where
,
1234 gfc_current_intrinsic
);
1238 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1241 if (!scalar_check (old
, 2))
1244 if (!same_type_check (atom
, 0, old
, 2))
1247 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1249 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1250 "definable", gfc_current_intrinsic
, &atom
->where
);
1254 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1256 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1257 "definable", gfc_current_intrinsic
, &old
->where
);
1265 /* BESJN and BESYN functions. */
1268 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1270 if (!type_check (n
, 0, BT_INTEGER
))
1272 if (n
->expr_type
== EXPR_CONSTANT
)
1275 gfc_extract_int (n
, &i
);
1276 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1277 "N at %L", &n
->where
))
1281 if (!type_check (x
, 1, BT_REAL
))
1288 /* Transformational version of the Bessel JN and YN functions. */
1291 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1293 if (!type_check (n1
, 0, BT_INTEGER
))
1295 if (!scalar_check (n1
, 0))
1297 if (!nonnegative_check ("N1", n1
))
1300 if (!type_check (n2
, 1, BT_INTEGER
))
1302 if (!scalar_check (n2
, 1))
1304 if (!nonnegative_check ("N2", n2
))
1307 if (!type_check (x
, 2, BT_REAL
))
1309 if (!scalar_check (x
, 2))
1317 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1319 if (!type_check (i
, 0, BT_INTEGER
))
1322 if (!type_check (j
, 1, BT_INTEGER
))
1330 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1332 if (!type_check (i
, 0, BT_INTEGER
))
1335 if (!type_check (pos
, 1, BT_INTEGER
))
1338 if (!nonnegative_check ("pos", pos
))
1341 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1349 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1351 if (!type_check (i
, 0, BT_INTEGER
))
1353 if (!kind_check (kind
, 1, BT_CHARACTER
))
1361 gfc_check_chdir (gfc_expr
*dir
)
1363 if (!type_check (dir
, 0, BT_CHARACTER
))
1365 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1373 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1375 if (!type_check (dir
, 0, BT_CHARACTER
))
1377 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1383 if (!type_check (status
, 1, BT_INTEGER
))
1385 if (!scalar_check (status
, 1))
1393 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1395 if (!type_check (name
, 0, BT_CHARACTER
))
1397 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1400 if (!type_check (mode
, 1, BT_CHARACTER
))
1402 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1410 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1412 if (!type_check (name
, 0, BT_CHARACTER
))
1414 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1417 if (!type_check (mode
, 1, BT_CHARACTER
))
1419 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1425 if (!type_check (status
, 2, BT_INTEGER
))
1428 if (!scalar_check (status
, 2))
1436 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1438 if (!numeric_check (x
, 0))
1443 if (!numeric_check (y
, 1))
1446 if (x
->ts
.type
== BT_COMPLEX
)
1448 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1449 "present if %<x%> is COMPLEX",
1450 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1455 if (y
->ts
.type
== BT_COMPLEX
)
1457 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1458 "of either REAL or INTEGER",
1459 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1466 if (!kind_check (kind
, 2, BT_COMPLEX
))
1469 if (!kind
&& warn_conversion
1470 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1471 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1472 "COMPLEX(%d) at %L might lose precision, consider using "
1473 "the KIND argument", gfc_typename (&x
->ts
),
1474 gfc_default_real_kind
, &x
->where
);
1475 else if (y
&& !kind
&& warn_conversion
1476 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1477 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1478 "COMPLEX(%d) at %L might lose precision, consider using "
1479 "the KIND argument", gfc_typename (&y
->ts
),
1480 gfc_default_real_kind
, &y
->where
);
1486 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1487 gfc_expr
*errmsg
, bool co_reduce
)
1489 if (!variable_check (a
, 0, false))
1492 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1496 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1497 if (gfc_has_vector_subscript (a
))
1499 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1500 "subroutine %s shall not have a vector subscript",
1501 &a
->where
, gfc_current_intrinsic
);
1505 if (gfc_is_coindexed (a
))
1507 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1508 "coindexed", &a
->where
, gfc_current_intrinsic
);
1512 if (image_idx
!= NULL
)
1514 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1516 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1522 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1524 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1526 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1528 if (stat
->ts
.kind
!= 4)
1530 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1531 "variable", &stat
->where
);
1538 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1540 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1542 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1544 if (errmsg
->ts
.kind
!= 1)
1546 gfc_error ("The errmsg= argument at %L must be a default-kind "
1547 "character variable", &errmsg
->where
);
1552 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1554 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1564 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1567 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1569 gfc_error ("Support for the A argument at %L which is polymorphic A "
1570 "argument or has allocatable components is not yet "
1571 "implemented", &a
->where
);
1574 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1579 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1580 gfc_expr
*stat
, gfc_expr
*errmsg
)
1582 symbol_attribute attr
;
1583 gfc_formal_arglist
*formal
;
1586 if (a
->ts
.type
== BT_CLASS
)
1588 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1593 if (gfc_expr_attr (a
).alloc_comp
)
1595 gfc_error ("Support for the A argument at %L with allocatable components"
1596 " is not yet implemented", &a
->where
);
1600 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1603 if (!gfc_resolve_expr (op
))
1606 attr
= gfc_expr_attr (op
);
1607 if (!attr
.pure
|| !attr
.function
)
1609 gfc_error ("OPERATOR argument at %L must be a PURE function",
1616 /* None of the intrinsics fulfills the criteria of taking two arguments,
1617 returning the same type and kind as the arguments and being permitted
1618 as actual argument. */
1619 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1620 op
->symtree
->n
.sym
->name
, &op
->where
);
1624 if (gfc_is_proc_ptr_comp (op
))
1626 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1627 sym
= comp
->ts
.interface
;
1630 sym
= op
->symtree
->n
.sym
;
1632 formal
= sym
->formal
;
1634 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1636 gfc_error ("The function passed as OPERATOR at %L shall have two "
1637 "arguments", &op
->where
);
1641 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1642 gfc_set_default_type (sym
->result
, 0, NULL
);
1644 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1646 gfc_error ("A argument at %L has type %s but the function passed as "
1647 "OPERATOR at %L returns %s",
1648 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1649 gfc_typename (&sym
->result
->ts
));
1652 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1653 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1655 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1656 "%s and %s but shall have type %s", &op
->where
,
1657 gfc_typename (&formal
->sym
->ts
),
1658 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1661 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1662 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1663 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1664 || formal
->next
->sym
->attr
.pointer
)
1666 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1667 "nonallocatable nonpointer arguments and return a "
1668 "nonallocatable nonpointer scalar", &op
->where
);
1672 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1674 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1675 "attribute either for none or both arguments", &op
->where
);
1679 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1681 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1682 "attribute either for none or both arguments", &op
->where
);
1686 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1688 gfc_error ("The function passed as OPERATOR at %L shall have the "
1689 "ASYNCHRONOUS attribute either for none or both arguments",
1694 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1696 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1697 "OPTIONAL attribute for either of the arguments", &op
->where
);
1701 if (a
->ts
.type
== BT_CHARACTER
)
1704 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1707 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1708 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1710 cl
= formal
->sym
->ts
.u
.cl
;
1711 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1712 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1714 cl
= formal
->next
->sym
->ts
.u
.cl
;
1715 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1716 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1719 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1720 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1723 && ((formal_size1
&& actual_size
!= formal_size1
)
1724 || (formal_size2
&& actual_size
!= formal_size2
)))
1726 gfc_error ("The character length of the A argument at %L and of the "
1727 "arguments of the OPERATOR at %L shall be the same",
1728 &a
->where
, &op
->where
);
1731 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1733 gfc_error ("The character length of the A argument at %L and of the "
1734 "function result of the OPERATOR at %L shall be the same",
1735 &a
->where
, &op
->where
);
1745 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1748 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1749 && a
->ts
.type
!= BT_CHARACTER
)
1751 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1752 "integer, real or character",
1753 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1757 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1762 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1765 if (!numeric_check (a
, 0))
1767 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1772 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1774 if (!int_or_real_check (x
, 0))
1776 if (!scalar_check (x
, 0))
1779 if (!int_or_real_check (y
, 1))
1781 if (!scalar_check (y
, 1))
1789 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1791 if (!logical_array_check (mask
, 0))
1793 if (!dim_check (dim
, 1, false))
1795 if (!dim_rank_check (dim
, mask
, 0))
1797 if (!kind_check (kind
, 2, BT_INTEGER
))
1799 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1800 "with KIND argument at %L",
1801 gfc_current_intrinsic
, &kind
->where
))
1809 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1811 if (!array_check (array
, 0))
1814 if (!type_check (shift
, 1, BT_INTEGER
))
1817 if (!dim_check (dim
, 2, true))
1820 if (!dim_rank_check (dim
, array
, false))
1823 if (array
->rank
== 1 || shift
->rank
== 0)
1825 if (!scalar_check (shift
, 1))
1828 else if (shift
->rank
== array
->rank
- 1)
1833 else if (dim
->expr_type
== EXPR_CONSTANT
)
1834 gfc_extract_int (dim
, &d
);
1841 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1844 if (!identical_dimen_shape (array
, i
, shift
, j
))
1846 gfc_error ("%qs argument of %qs intrinsic at %L has "
1847 "invalid shape in dimension %d (%ld/%ld)",
1848 gfc_current_intrinsic_arg
[1]->name
,
1849 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1850 mpz_get_si (array
->shape
[i
]),
1851 mpz_get_si (shift
->shape
[j
]));
1861 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
1862 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1863 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1872 gfc_check_ctime (gfc_expr
*time
)
1874 if (!scalar_check (time
, 0))
1877 if (!type_check (time
, 0, BT_INTEGER
))
1884 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1886 if (!double_check (y
, 0) || !double_check (x
, 1))
1893 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1895 if (!numeric_check (x
, 0))
1900 if (!numeric_check (y
, 1))
1903 if (x
->ts
.type
== BT_COMPLEX
)
1905 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1906 "present if %<x%> is COMPLEX",
1907 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1912 if (y
->ts
.type
== BT_COMPLEX
)
1914 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1915 "of either REAL or INTEGER",
1916 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1927 gfc_check_dble (gfc_expr
*x
)
1929 if (!numeric_check (x
, 0))
1937 gfc_check_digits (gfc_expr
*x
)
1939 if (!int_or_real_check (x
, 0))
1947 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1949 switch (vector_a
->ts
.type
)
1952 if (!type_check (vector_b
, 1, BT_LOGICAL
))
1959 if (!numeric_check (vector_b
, 1))
1964 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
1965 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1966 gfc_current_intrinsic
, &vector_a
->where
);
1970 if (!rank_check (vector_a
, 0, 1))
1973 if (!rank_check (vector_b
, 1, 1))
1976 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1978 gfc_error ("Different shape for arguments %qs and %qs at %L for "
1979 "intrinsic %<dot_product%>",
1980 gfc_current_intrinsic_arg
[0]->name
,
1981 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1990 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1992 if (!type_check (x
, 0, BT_REAL
)
1993 || !type_check (y
, 1, BT_REAL
))
1996 if (x
->ts
.kind
!= gfc_default_real_kind
)
1998 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
1999 "real", gfc_current_intrinsic_arg
[0]->name
,
2000 gfc_current_intrinsic
, &x
->where
);
2004 if (y
->ts
.kind
!= gfc_default_real_kind
)
2006 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2007 "real", gfc_current_intrinsic_arg
[1]->name
,
2008 gfc_current_intrinsic
, &y
->where
);
2017 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2019 if (!type_check (i
, 0, BT_INTEGER
))
2022 if (!type_check (j
, 1, BT_INTEGER
))
2025 if (i
->is_boz
&& j
->is_boz
)
2027 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2028 "constants", &i
->where
, &j
->where
);
2032 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
2035 if (!type_check (shift
, 2, BT_INTEGER
))
2038 if (!nonnegative_check ("SHIFT", shift
))
2043 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
2045 i
->ts
.kind
= j
->ts
.kind
;
2049 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2051 j
->ts
.kind
= i
->ts
.kind
;
2059 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2062 if (!array_check (array
, 0))
2065 if (!type_check (shift
, 1, BT_INTEGER
))
2068 if (!dim_check (dim
, 3, true))
2071 if (!dim_rank_check (dim
, array
, false))
2074 if (array
->rank
== 1 || shift
->rank
== 0)
2076 if (!scalar_check (shift
, 1))
2079 else if (shift
->rank
== array
->rank
- 1)
2084 else if (dim
->expr_type
== EXPR_CONSTANT
)
2085 gfc_extract_int (dim
, &d
);
2092 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2095 if (!identical_dimen_shape (array
, i
, shift
, j
))
2097 gfc_error ("%qs argument of %qs intrinsic at %L has "
2098 "invalid shape in dimension %d (%ld/%ld)",
2099 gfc_current_intrinsic_arg
[1]->name
,
2100 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2101 mpz_get_si (array
->shape
[i
]),
2102 mpz_get_si (shift
->shape
[j
]));
2112 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2113 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2114 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2118 if (boundary
!= NULL
)
2120 if (!same_type_check (array
, 0, boundary
, 2))
2123 if (array
->rank
== 1 || boundary
->rank
== 0)
2125 if (!scalar_check (boundary
, 2))
2128 else if (boundary
->rank
== array
->rank
- 1)
2130 if (!gfc_check_conformance (shift
, boundary
,
2131 "arguments '%s' and '%s' for "
2133 gfc_current_intrinsic_arg
[1]->name
,
2134 gfc_current_intrinsic_arg
[2]->name
,
2135 gfc_current_intrinsic
))
2140 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2141 "rank %d or be a scalar",
2142 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2143 &shift
->where
, array
->rank
- 1);
2152 gfc_check_float (gfc_expr
*a
)
2154 if (!type_check (a
, 0, BT_INTEGER
))
2157 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2158 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2159 "kind argument to %s intrinsic at %L",
2160 gfc_current_intrinsic
, &a
->where
))
2166 /* A single complex argument. */
2169 gfc_check_fn_c (gfc_expr
*a
)
2171 if (!type_check (a
, 0, BT_COMPLEX
))
2177 /* A single real argument. */
2180 gfc_check_fn_r (gfc_expr
*a
)
2182 if (!type_check (a
, 0, BT_REAL
))
2188 /* A single double argument. */
2191 gfc_check_fn_d (gfc_expr
*a
)
2193 if (!double_check (a
, 0))
2199 /* A single real or complex argument. */
2202 gfc_check_fn_rc (gfc_expr
*a
)
2204 if (!real_or_complex_check (a
, 0))
2212 gfc_check_fn_rc2008 (gfc_expr
*a
)
2214 if (!real_or_complex_check (a
, 0))
2217 if (a
->ts
.type
== BT_COMPLEX
2218 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2219 "of %qs intrinsic at %L",
2220 gfc_current_intrinsic_arg
[0]->name
,
2221 gfc_current_intrinsic
, &a
->where
))
2229 gfc_check_fnum (gfc_expr
*unit
)
2231 if (!type_check (unit
, 0, BT_INTEGER
))
2234 if (!scalar_check (unit
, 0))
2242 gfc_check_huge (gfc_expr
*x
)
2244 if (!int_or_real_check (x
, 0))
2252 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2254 if (!type_check (x
, 0, BT_REAL
))
2256 if (!same_type_check (x
, 0, y
, 1))
2263 /* Check that the single argument is an integer. */
2266 gfc_check_i (gfc_expr
*i
)
2268 if (!type_check (i
, 0, BT_INTEGER
))
2276 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2278 if (!type_check (i
, 0, BT_INTEGER
))
2281 if (!type_check (j
, 1, BT_INTEGER
))
2284 if (i
->ts
.kind
!= j
->ts
.kind
)
2286 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2296 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2298 if (!type_check (i
, 0, BT_INTEGER
))
2301 if (!type_check (pos
, 1, BT_INTEGER
))
2304 if (!type_check (len
, 2, BT_INTEGER
))
2307 if (!nonnegative_check ("pos", pos
))
2310 if (!nonnegative_check ("len", len
))
2313 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2321 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2325 if (!type_check (c
, 0, BT_CHARACTER
))
2328 if (!kind_check (kind
, 1, BT_INTEGER
))
2331 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2332 "with KIND argument at %L",
2333 gfc_current_intrinsic
, &kind
->where
))
2336 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2342 /* Substring references don't have the charlength set. */
2344 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2347 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2351 /* Check that the argument is length one. Non-constant lengths
2352 can't be checked here, so assume they are ok. */
2353 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2355 /* If we already have a length for this expression then use it. */
2356 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2358 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2365 start
= ref
->u
.ss
.start
;
2366 end
= ref
->u
.ss
.end
;
2369 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2370 || start
->expr_type
!= EXPR_CONSTANT
)
2373 i
= mpz_get_si (end
->value
.integer
) + 1
2374 - mpz_get_si (start
->value
.integer
);
2382 gfc_error ("Argument of %s at %L must be of length one",
2383 gfc_current_intrinsic
, &c
->where
);
2392 gfc_check_idnint (gfc_expr
*a
)
2394 if (!double_check (a
, 0))
2402 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2404 if (!type_check (i
, 0, BT_INTEGER
))
2407 if (!type_check (j
, 1, BT_INTEGER
))
2410 if (i
->ts
.kind
!= j
->ts
.kind
)
2412 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2422 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2425 if (!type_check (string
, 0, BT_CHARACTER
)
2426 || !type_check (substring
, 1, BT_CHARACTER
))
2429 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2432 if (!kind_check (kind
, 3, BT_INTEGER
))
2434 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2435 "with KIND argument at %L",
2436 gfc_current_intrinsic
, &kind
->where
))
2439 if (string
->ts
.kind
!= substring
->ts
.kind
)
2441 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2442 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2443 gfc_current_intrinsic
, &substring
->where
,
2444 gfc_current_intrinsic_arg
[0]->name
);
2453 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2455 if (!numeric_check (x
, 0))
2458 if (!kind_check (kind
, 1, BT_INTEGER
))
2466 gfc_check_intconv (gfc_expr
*x
)
2468 if (!numeric_check (x
, 0))
2476 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2478 if (!type_check (i
, 0, BT_INTEGER
))
2481 if (!type_check (j
, 1, BT_INTEGER
))
2484 if (i
->ts
.kind
!= j
->ts
.kind
)
2486 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2496 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2498 if (!type_check (i
, 0, BT_INTEGER
)
2499 || !type_check (shift
, 1, BT_INTEGER
))
2502 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2510 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2512 if (!type_check (i
, 0, BT_INTEGER
)
2513 || !type_check (shift
, 1, BT_INTEGER
))
2520 if (!type_check (size
, 2, BT_INTEGER
))
2523 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2526 if (size
->expr_type
== EXPR_CONSTANT
)
2528 gfc_extract_int (size
, &i3
);
2531 gfc_error ("SIZE at %L must be positive", &size
->where
);
2535 if (shift
->expr_type
== EXPR_CONSTANT
)
2537 gfc_extract_int (shift
, &i2
);
2543 gfc_error ("The absolute value of SHIFT at %L must be less "
2544 "than or equal to SIZE at %L", &shift
->where
,
2551 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2559 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2561 if (!type_check (pid
, 0, BT_INTEGER
))
2564 if (!type_check (sig
, 1, BT_INTEGER
))
2572 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2574 if (!type_check (pid
, 0, BT_INTEGER
))
2577 if (!scalar_check (pid
, 0))
2580 if (!type_check (sig
, 1, BT_INTEGER
))
2583 if (!scalar_check (sig
, 1))
2589 if (!type_check (status
, 2, BT_INTEGER
))
2592 if (!scalar_check (status
, 2))
2600 gfc_check_kind (gfc_expr
*x
)
2602 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
2604 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2605 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2606 gfc_current_intrinsic
, &x
->where
);
2609 if (x
->ts
.type
== BT_PROCEDURE
)
2611 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2612 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2622 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2624 if (!array_check (array
, 0))
2627 if (!dim_check (dim
, 1, false))
2630 if (!dim_rank_check (dim
, array
, 1))
2633 if (!kind_check (kind
, 2, BT_INTEGER
))
2635 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2636 "with KIND argument at %L",
2637 gfc_current_intrinsic
, &kind
->where
))
2645 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2647 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2649 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2653 if (!coarray_check (coarray
, 0))
2658 if (!dim_check (dim
, 1, false))
2661 if (!dim_corank_check (dim
, coarray
))
2665 if (!kind_check (kind
, 2, BT_INTEGER
))
2673 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2675 if (!type_check (s
, 0, BT_CHARACTER
))
2678 if (!kind_check (kind
, 1, BT_INTEGER
))
2680 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2681 "with KIND argument at %L",
2682 gfc_current_intrinsic
, &kind
->where
))
2690 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2692 if (!type_check (a
, 0, BT_CHARACTER
))
2694 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2697 if (!type_check (b
, 1, BT_CHARACTER
))
2699 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2707 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2709 if (!type_check (path1
, 0, BT_CHARACTER
))
2711 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2714 if (!type_check (path2
, 1, BT_CHARACTER
))
2716 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2724 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2726 if (!type_check (path1
, 0, BT_CHARACTER
))
2728 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2731 if (!type_check (path2
, 1, BT_CHARACTER
))
2733 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2739 if (!type_check (status
, 2, BT_INTEGER
))
2742 if (!scalar_check (status
, 2))
2750 gfc_check_loc (gfc_expr
*expr
)
2752 return variable_check (expr
, 0, true);
2757 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2759 if (!type_check (path1
, 0, BT_CHARACTER
))
2761 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2764 if (!type_check (path2
, 1, BT_CHARACTER
))
2766 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2774 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2776 if (!type_check (path1
, 0, BT_CHARACTER
))
2778 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2781 if (!type_check (path2
, 1, BT_CHARACTER
))
2783 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2789 if (!type_check (status
, 2, BT_INTEGER
))
2792 if (!scalar_check (status
, 2))
2800 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2802 if (!type_check (a
, 0, BT_LOGICAL
))
2804 if (!kind_check (kind
, 1, BT_LOGICAL
))
2811 /* Min/max family. */
2814 min_max_args (gfc_actual_arglist
*args
)
2816 gfc_actual_arglist
*arg
;
2817 int i
, j
, nargs
, *nlabels
, nlabelless
;
2818 bool a1
= false, a2
= false;
2820 if (args
== NULL
|| args
->next
== NULL
)
2822 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
2823 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2830 if (!args
->next
->name
)
2834 for (arg
= args
; arg
; arg
= arg
->next
)
2841 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2843 nlabels
= XALLOCAVEC (int, nargs
);
2844 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2850 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2852 n
= strtol (&arg
->name
[1], &endp
, 10);
2853 if (endp
[0] != '\0')
2857 if (n
<= nlabelless
)
2870 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
2871 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2872 gfc_current_intrinsic_where
);
2876 /* Check for duplicates. */
2877 for (i
= 0; i
< nargs
; i
++)
2878 for (j
= i
+ 1; j
< nargs
; j
++)
2879 if (nlabels
[i
] == nlabels
[j
])
2885 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
2886 &arg
->expr
->where
, gfc_current_intrinsic
);
2890 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
2891 &arg
->expr
->where
, gfc_current_intrinsic
);
2897 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2899 gfc_actual_arglist
*arg
, *tmp
;
2903 if (!min_max_args (arglist
))
2906 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2909 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2911 if (x
->ts
.type
== type
)
2913 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
2914 "kinds at %L", &x
->where
))
2919 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
2920 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2921 gfc_basic_typename (type
), kind
);
2926 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2927 if (!gfc_check_conformance (tmp
->expr
, x
,
2928 "arguments 'a%d' and 'a%d' for "
2929 "intrinsic '%s'", m
, n
,
2930 gfc_current_intrinsic
))
2939 gfc_check_min_max (gfc_actual_arglist
*arg
)
2943 if (!min_max_args (arg
))
2948 if (x
->ts
.type
== BT_CHARACTER
)
2950 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2951 "with CHARACTER argument at %L",
2952 gfc_current_intrinsic
, &x
->where
))
2955 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2957 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
2958 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2962 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2967 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2969 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2974 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2976 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2981 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2983 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2987 /* End of min/max family. */
2990 gfc_check_malloc (gfc_expr
*size
)
2992 if (!type_check (size
, 0, BT_INTEGER
))
2995 if (!scalar_check (size
, 0))
3003 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3005 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3007 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3008 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3009 gfc_current_intrinsic
, &matrix_a
->where
);
3013 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3015 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3016 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3017 gfc_current_intrinsic
, &matrix_b
->where
);
3021 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3022 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3024 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3025 gfc_current_intrinsic
, &matrix_a
->where
,
3026 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3030 switch (matrix_a
->rank
)
3033 if (!rank_check (matrix_b
, 1, 2))
3035 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3036 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3038 gfc_error ("Different shape on dimension 1 for arguments %qs "
3039 "and %qs at %L for intrinsic matmul",
3040 gfc_current_intrinsic_arg
[0]->name
,
3041 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3047 if (matrix_b
->rank
!= 2)
3049 if (!rank_check (matrix_b
, 1, 1))
3052 /* matrix_b has rank 1 or 2 here. Common check for the cases
3053 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3054 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3055 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3057 gfc_error ("Different shape on dimension 2 for argument %qs and "
3058 "dimension 1 for argument %qs at %L for intrinsic "
3059 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3060 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3066 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3067 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3068 gfc_current_intrinsic
, &matrix_a
->where
);
3076 /* Whoever came up with this interface was probably on something.
3077 The possibilities for the occupation of the second and third
3084 NULL MASK minloc(array, mask=m)
3087 I.e. in the case of minloc(array,mask), mask will be in the second
3088 position of the argument list and we'll have to fix that up. */
3091 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3093 gfc_expr
*a
, *m
, *d
;
3096 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
3100 m
= ap
->next
->next
->expr
;
3102 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3103 && ap
->next
->name
== NULL
)
3107 ap
->next
->expr
= NULL
;
3108 ap
->next
->next
->expr
= m
;
3111 if (!dim_check (d
, 1, false))
3114 if (!dim_rank_check (d
, a
, 0))
3117 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3121 && !gfc_check_conformance (a
, m
,
3122 "arguments '%s' and '%s' for intrinsic %s",
3123 gfc_current_intrinsic_arg
[0]->name
,
3124 gfc_current_intrinsic_arg
[2]->name
,
3125 gfc_current_intrinsic
))
3132 /* Similar to minloc/maxloc, the argument list might need to be
3133 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3134 difference is that MINLOC/MAXLOC take an additional KIND argument.
3135 The possibilities are:
3141 NULL MASK minval(array, mask=m)
3144 I.e. in the case of minval(array,mask), mask will be in the second
3145 position of the argument list and we'll have to fix that up. */
3148 check_reduction (gfc_actual_arglist
*ap
)
3150 gfc_expr
*a
, *m
, *d
;
3154 m
= ap
->next
->next
->expr
;
3156 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3157 && ap
->next
->name
== NULL
)
3161 ap
->next
->expr
= NULL
;
3162 ap
->next
->next
->expr
= m
;
3165 if (!dim_check (d
, 1, false))
3168 if (!dim_rank_check (d
, a
, 0))
3171 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3175 && !gfc_check_conformance (a
, m
,
3176 "arguments '%s' and '%s' for intrinsic %s",
3177 gfc_current_intrinsic_arg
[0]->name
,
3178 gfc_current_intrinsic_arg
[2]->name
,
3179 gfc_current_intrinsic
))
3187 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3189 if (!int_or_real_check (ap
->expr
, 0)
3190 || !array_check (ap
->expr
, 0))
3193 return check_reduction (ap
);
3198 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3200 if (!numeric_check (ap
->expr
, 0)
3201 || !array_check (ap
->expr
, 0))
3204 return check_reduction (ap
);
3208 /* For IANY, IALL and IPARITY. */
3211 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3215 if (!type_check (i
, 0, BT_INTEGER
))
3218 if (!nonnegative_check ("I", i
))
3221 if (!kind_check (kind
, 1, BT_INTEGER
))
3225 gfc_extract_int (kind
, &k
);
3227 k
= gfc_default_integer_kind
;
3229 if (!less_than_bitsizekind ("I", i
, k
))
3237 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3239 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3241 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3242 gfc_current_intrinsic_arg
[0]->name
,
3243 gfc_current_intrinsic
, &ap
->expr
->where
);
3247 if (!array_check (ap
->expr
, 0))
3250 return check_reduction (ap
);
3255 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3257 if (!same_type_check (tsource
, 0, fsource
, 1))
3260 if (!type_check (mask
, 2, BT_LOGICAL
))
3263 if (tsource
->ts
.type
== BT_CHARACTER
)
3264 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3271 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3273 if (!type_check (i
, 0, BT_INTEGER
))
3276 if (!type_check (j
, 1, BT_INTEGER
))
3279 if (!type_check (mask
, 2, BT_INTEGER
))
3282 if (!same_type_check (i
, 0, j
, 1))
3285 if (!same_type_check (i
, 0, mask
, 2))
3293 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3295 if (!variable_check (from
, 0, false))
3297 if (!allocatable_check (from
, 0))
3299 if (gfc_is_coindexed (from
))
3301 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3302 "coindexed", &from
->where
);
3306 if (!variable_check (to
, 1, false))
3308 if (!allocatable_check (to
, 1))
3310 if (gfc_is_coindexed (to
))
3312 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3313 "coindexed", &to
->where
);
3317 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3319 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3320 "polymorphic if FROM is polymorphic",
3325 if (!same_type_check (to
, 1, from
, 0))
3328 if (to
->rank
!= from
->rank
)
3330 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3331 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3336 /* IR F08/0040; cf. 12-006A. */
3337 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3339 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3340 "must have the same corank %d/%d", &to
->where
,
3341 gfc_get_corank (from
), gfc_get_corank (to
));
3345 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3346 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3347 and cmp2 are allocatable. After the allocation is transferred,
3348 the 'to' chain is broken by the nullification of the 'from'. A bit
3349 of reflection reveals that this can only occur for derived types
3350 with recursive allocatable components. */
3351 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3352 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3354 gfc_ref
*to_ref
, *from_ref
;
3356 from_ref
= from
->ref
;
3357 bool aliasing
= true;
3359 for (; from_ref
&& to_ref
;
3360 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3362 if (to_ref
->type
!= from
->ref
->type
)
3364 else if (to_ref
->type
== REF_ARRAY
3365 && to_ref
->u
.ar
.type
!= AR_FULL
3366 && from_ref
->u
.ar
.type
!= AR_FULL
)
3367 /* Play safe; assume sections and elements are different. */
3369 else if (to_ref
->type
== REF_COMPONENT
3370 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3379 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3380 "restrictions (F2003 12.4.1.7)", &to
->where
);
3385 /* CLASS arguments: Make sure the vtab of from is present. */
3386 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3387 gfc_find_vtab (&from
->ts
);
3394 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3396 if (!type_check (x
, 0, BT_REAL
))
3399 if (!type_check (s
, 1, BT_REAL
))
3402 if (s
->expr_type
== EXPR_CONSTANT
)
3404 if (mpfr_sgn (s
->value
.real
) == 0)
3406 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3417 gfc_check_new_line (gfc_expr
*a
)
3419 if (!type_check (a
, 0, BT_CHARACTER
))
3427 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3429 if (!type_check (array
, 0, BT_REAL
))
3432 if (!array_check (array
, 0))
3435 if (!dim_rank_check (dim
, array
, false))
3442 gfc_check_null (gfc_expr
*mold
)
3444 symbol_attribute attr
;
3449 if (!variable_check (mold
, 0, true))
3452 attr
= gfc_variable_attr (mold
, NULL
);
3454 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3456 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3457 "ALLOCATABLE or procedure pointer",
3458 gfc_current_intrinsic_arg
[0]->name
,
3459 gfc_current_intrinsic
, &mold
->where
);
3463 if (attr
.allocatable
3464 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3465 "allocatable MOLD at %L", &mold
->where
))
3469 if (gfc_is_coindexed (mold
))
3471 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3472 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3473 gfc_current_intrinsic
, &mold
->where
);
3482 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3484 if (!array_check (array
, 0))
3487 if (!type_check (mask
, 1, BT_LOGICAL
))
3490 if (!gfc_check_conformance (array
, mask
,
3491 "arguments '%s' and '%s' for intrinsic '%s'",
3492 gfc_current_intrinsic_arg
[0]->name
,
3493 gfc_current_intrinsic_arg
[1]->name
,
3494 gfc_current_intrinsic
))
3499 mpz_t array_size
, vector_size
;
3500 bool have_array_size
, have_vector_size
;
3502 if (!same_type_check (array
, 0, vector
, 2))
3505 if (!rank_check (vector
, 2, 1))
3508 /* VECTOR requires at least as many elements as MASK
3509 has .TRUE. values. */
3510 have_array_size
= gfc_array_size(array
, &array_size
);
3511 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3513 if (have_vector_size
3514 && (mask
->expr_type
== EXPR_ARRAY
3515 || (mask
->expr_type
== EXPR_CONSTANT
3516 && have_array_size
)))
3518 int mask_true_values
= 0;
3520 if (mask
->expr_type
== EXPR_ARRAY
)
3522 gfc_constructor
*mask_ctor
;
3523 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3526 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3528 mask_true_values
= 0;
3532 if (mask_ctor
->expr
->value
.logical
)
3535 mask_ctor
= gfc_constructor_next (mask_ctor
);
3538 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3539 mask_true_values
= mpz_get_si (array_size
);
3541 if (mpz_get_si (vector_size
) < mask_true_values
)
3543 gfc_error ("%qs argument of %qs intrinsic at %L must "
3544 "provide at least as many elements as there "
3545 "are .TRUE. values in %qs (%ld/%d)",
3546 gfc_current_intrinsic_arg
[2]->name
,
3547 gfc_current_intrinsic
, &vector
->where
,
3548 gfc_current_intrinsic_arg
[1]->name
,
3549 mpz_get_si (vector_size
), mask_true_values
);
3554 if (have_array_size
)
3555 mpz_clear (array_size
);
3556 if (have_vector_size
)
3557 mpz_clear (vector_size
);
3565 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3567 if (!type_check (mask
, 0, BT_LOGICAL
))
3570 if (!array_check (mask
, 0))
3573 if (!dim_rank_check (dim
, mask
, false))
3581 gfc_check_precision (gfc_expr
*x
)
3583 if (!real_or_complex_check (x
, 0))
3591 gfc_check_present (gfc_expr
*a
)
3595 if (!variable_check (a
, 0, true))
3598 sym
= a
->symtree
->n
.sym
;
3599 if (!sym
->attr
.dummy
)
3601 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3602 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3603 gfc_current_intrinsic
, &a
->where
);
3607 if (!sym
->attr
.optional
)
3609 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3610 "an OPTIONAL dummy variable",
3611 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3616 /* 13.14.82 PRESENT(A)
3618 Argument. A shall be the name of an optional dummy argument that is
3619 accessible in the subprogram in which the PRESENT function reference
3623 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3624 && (a
->ref
->u
.ar
.type
== AR_FULL
3625 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3626 && a
->ref
->u
.ar
.as
->rank
== 0))))
3628 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3629 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3630 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3639 gfc_check_radix (gfc_expr
*x
)
3641 if (!int_or_real_check (x
, 0))
3649 gfc_check_range (gfc_expr
*x
)
3651 if (!numeric_check (x
, 0))
3659 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3661 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3662 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3664 bool is_variable
= true;
3666 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3667 if (a
->expr_type
== EXPR_FUNCTION
)
3668 is_variable
= a
->value
.function
.esym
3669 ? a
->value
.function
.esym
->result
->attr
.pointer
3670 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3672 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3673 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3676 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3677 "object", &a
->where
);
3685 /* real, float, sngl. */
3687 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3689 if (!numeric_check (a
, 0))
3692 if (!kind_check (kind
, 1, BT_REAL
))
3700 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3702 if (!type_check (path1
, 0, BT_CHARACTER
))
3704 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3707 if (!type_check (path2
, 1, BT_CHARACTER
))
3709 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3717 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3719 if (!type_check (path1
, 0, BT_CHARACTER
))
3721 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3724 if (!type_check (path2
, 1, BT_CHARACTER
))
3726 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3732 if (!type_check (status
, 2, BT_INTEGER
))
3735 if (!scalar_check (status
, 2))
3743 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3745 if (!type_check (x
, 0, BT_CHARACTER
))
3748 if (!scalar_check (x
, 0))
3751 if (!type_check (y
, 0, BT_INTEGER
))
3754 if (!scalar_check (y
, 1))
3762 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3763 gfc_expr
*pad
, gfc_expr
*order
)
3769 if (!array_check (source
, 0))
3772 if (!rank_check (shape
, 1, 1))
3775 if (!type_check (shape
, 1, BT_INTEGER
))
3778 if (!gfc_array_size (shape
, &size
))
3780 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3781 "array of constant size", &shape
->where
);
3785 shape_size
= mpz_get_ui (size
);
3788 if (shape_size
<= 0)
3790 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3791 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3795 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3797 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
3798 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3801 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3805 for (i
= 0; i
< shape_size
; ++i
)
3807 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3808 if (e
->expr_type
!= EXPR_CONSTANT
)
3811 gfc_extract_int (e
, &extent
);
3814 gfc_error ("%qs argument of %qs intrinsic at %L has "
3815 "negative element (%d)",
3816 gfc_current_intrinsic_arg
[1]->name
,
3817 gfc_current_intrinsic
, &e
->where
, extent
);
3822 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
3823 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
3824 && shape
->ref
->u
.ar
.as
3825 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
3826 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
3827 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
3828 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
3829 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
3834 v
= shape
->symtree
->n
.sym
->value
;
3836 for (i
= 0; i
< shape_size
; i
++)
3838 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
3842 gfc_extract_int (e
, &extent
);
3846 gfc_error ("Element %d of actual argument of RESHAPE at %L "
3847 "cannot be negative", i
+ 1, &shape
->where
);
3855 if (!same_type_check (source
, 0, pad
, 2))
3858 if (!array_check (pad
, 2))
3864 if (!array_check (order
, 3))
3867 if (!type_check (order
, 3, BT_INTEGER
))
3870 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
3872 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3875 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3878 gfc_array_size (order
, &size
);
3879 order_size
= mpz_get_ui (size
);
3882 if (order_size
!= shape_size
)
3884 gfc_error ("%qs argument of %qs intrinsic at %L "
3885 "has wrong number of elements (%d/%d)",
3886 gfc_current_intrinsic_arg
[3]->name
,
3887 gfc_current_intrinsic
, &order
->where
,
3888 order_size
, shape_size
);
3892 for (i
= 1; i
<= order_size
; ++i
)
3894 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3895 if (e
->expr_type
!= EXPR_CONSTANT
)
3898 gfc_extract_int (e
, &dim
);
3900 if (dim
< 1 || dim
> order_size
)
3902 gfc_error ("%qs argument of %qs intrinsic at %L "
3903 "has out-of-range dimension (%d)",
3904 gfc_current_intrinsic_arg
[3]->name
,
3905 gfc_current_intrinsic
, &e
->where
, dim
);
3909 if (perm
[dim
-1] != 0)
3911 gfc_error ("%qs argument of %qs intrinsic at %L has "
3912 "invalid permutation of dimensions (dimension "
3914 gfc_current_intrinsic_arg
[3]->name
,
3915 gfc_current_intrinsic
, &e
->where
, dim
);
3924 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3925 && gfc_is_constant_expr (shape
)
3926 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3927 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3929 /* Check the match in size between source and destination. */
3930 if (gfc_array_size (source
, &nelems
))
3936 mpz_init_set_ui (size
, 1);
3937 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3938 c
; c
= gfc_constructor_next (c
))
3939 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3941 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3947 gfc_error ("Without padding, there are not enough elements "
3948 "in the intrinsic RESHAPE source at %L to match "
3949 "the shape", &source
->where
);
3960 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3962 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3964 gfc_error ("%qs argument of %qs intrinsic at %L "
3965 "cannot be of type %s",
3966 gfc_current_intrinsic_arg
[0]->name
,
3967 gfc_current_intrinsic
,
3968 &a
->where
, gfc_typename (&a
->ts
));
3972 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3974 gfc_error ("%qs argument of %qs intrinsic at %L "
3975 "must be of an extensible type",
3976 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3981 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3983 gfc_error ("%qs argument of %qs intrinsic at %L "
3984 "cannot be of type %s",
3985 gfc_current_intrinsic_arg
[0]->name
,
3986 gfc_current_intrinsic
,
3987 &b
->where
, gfc_typename (&b
->ts
));
3991 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3993 gfc_error ("%qs argument of %qs intrinsic at %L "
3994 "must be of an extensible type",
3995 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4005 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4007 if (!type_check (x
, 0, BT_REAL
))
4010 if (!type_check (i
, 1, BT_INTEGER
))
4018 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4020 if (!type_check (x
, 0, BT_CHARACTER
))
4023 if (!type_check (y
, 1, BT_CHARACTER
))
4026 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4029 if (!kind_check (kind
, 3, BT_INTEGER
))
4031 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4032 "with KIND argument at %L",
4033 gfc_current_intrinsic
, &kind
->where
))
4036 if (!same_type_check (x
, 0, y
, 1))
4044 gfc_check_secnds (gfc_expr
*r
)
4046 if (!type_check (r
, 0, BT_REAL
))
4049 if (!kind_value_check (r
, 0, 4))
4052 if (!scalar_check (r
, 0))
4060 gfc_check_selected_char_kind (gfc_expr
*name
)
4062 if (!type_check (name
, 0, BT_CHARACTER
))
4065 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4068 if (!scalar_check (name
, 0))
4076 gfc_check_selected_int_kind (gfc_expr
*r
)
4078 if (!type_check (r
, 0, BT_INTEGER
))
4081 if (!scalar_check (r
, 0))
4089 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4091 if (p
== NULL
&& r
== NULL
4092 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4093 " neither %<P%> nor %<R%> argument at %L",
4094 gfc_current_intrinsic_where
))
4099 if (!type_check (p
, 0, BT_INTEGER
))
4102 if (!scalar_check (p
, 0))
4108 if (!type_check (r
, 1, BT_INTEGER
))
4111 if (!scalar_check (r
, 1))
4117 if (!type_check (radix
, 1, BT_INTEGER
))
4120 if (!scalar_check (radix
, 1))
4123 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4124 "RADIX argument at %L", gfc_current_intrinsic
,
4134 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4136 if (!type_check (x
, 0, BT_REAL
))
4139 if (!type_check (i
, 1, BT_INTEGER
))
4147 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4151 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4154 ar
= gfc_find_array_ref (source
);
4156 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4158 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4159 "an assumed size array", &source
->where
);
4163 if (!kind_check (kind
, 1, BT_INTEGER
))
4165 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4166 "with KIND argument at %L",
4167 gfc_current_intrinsic
, &kind
->where
))
4175 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4177 if (!type_check (i
, 0, BT_INTEGER
))
4180 if (!type_check (shift
, 0, BT_INTEGER
))
4183 if (!nonnegative_check ("SHIFT", shift
))
4186 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4194 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4196 if (!int_or_real_check (a
, 0))
4199 if (!same_type_check (a
, 0, b
, 1))
4207 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4209 if (!array_check (array
, 0))
4212 if (!dim_check (dim
, 1, true))
4215 if (!dim_rank_check (dim
, array
, 0))
4218 if (!kind_check (kind
, 2, BT_INTEGER
))
4220 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4221 "with KIND argument at %L",
4222 gfc_current_intrinsic
, &kind
->where
))
4231 gfc_check_sizeof (gfc_expr
*arg
)
4233 if (arg
->ts
.type
== BT_PROCEDURE
)
4235 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4236 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4241 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4242 if (arg
->ts
.type
== BT_ASSUMED
4243 && (arg
->symtree
->n
.sym
->as
== NULL
4244 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4245 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4246 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4248 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4249 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4254 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4255 && arg
->symtree
->n
.sym
->as
!= NULL
4256 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4257 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4259 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4260 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4261 gfc_current_intrinsic
, &arg
->where
);
4269 /* Check whether an expression is interoperable. When returning false,
4270 msg is set to a string telling why the expression is not interoperable,
4271 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4272 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4273 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4274 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4278 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4282 if (expr
->ts
.type
== BT_CLASS
)
4284 *msg
= "Expression is polymorphic";
4288 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4289 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4291 *msg
= "Expression is a noninteroperable derived type";
4295 if (expr
->ts
.type
== BT_PROCEDURE
)
4297 *msg
= "Procedure unexpected as argument";
4301 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4304 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4305 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4307 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4311 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4312 && expr
->ts
.kind
!= 1)
4314 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4318 if (expr
->ts
.type
== BT_CHARACTER
) {
4319 if (expr
->ts
.deferred
)
4321 /* TS 29113 allows deferred-length strings as dummy arguments,
4322 but it is not an interoperable type. */
4323 *msg
= "Expression shall not be a deferred-length string";
4327 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4328 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4329 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4331 if (!c_loc
&& expr
->ts
.u
.cl
4332 && (!expr
->ts
.u
.cl
->length
4333 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4334 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4336 *msg
= "Type shall have a character length of 1";
4341 /* Note: The following checks are about interoperatable variables, Fortran
4342 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4343 is allowed, e.g. assumed-shape arrays with TS 29113. */
4345 if (gfc_is_coarray (expr
))
4347 *msg
= "Coarrays are not interoperable";
4351 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4353 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4354 if (ar
->type
!= AR_FULL
)
4356 *msg
= "Only whole-arrays are interoperable";
4359 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4360 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4362 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4372 gfc_check_c_sizeof (gfc_expr
*arg
)
4376 if (!is_c_interoperable (arg
, &msg
, false, false))
4378 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4379 "interoperable data entity: %s",
4380 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4385 if (arg
->ts
.type
== BT_ASSUMED
)
4387 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4389 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4394 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4395 && arg
->symtree
->n
.sym
->as
!= NULL
4396 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4397 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4399 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4400 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4401 gfc_current_intrinsic
, &arg
->where
);
4410 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4412 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4413 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4414 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4415 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4417 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4418 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4422 if (!scalar_check (c_ptr_1
, 0))
4426 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4427 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4428 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4429 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4431 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4432 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4433 gfc_typename (&c_ptr_1
->ts
),
4434 gfc_typename (&c_ptr_2
->ts
));
4438 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4446 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4448 symbol_attribute attr
;
4451 if (cptr
->ts
.type
!= BT_DERIVED
4452 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4453 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4455 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4456 "type TYPE(C_PTR)", &cptr
->where
);
4460 if (!scalar_check (cptr
, 0))
4463 attr
= gfc_expr_attr (fptr
);
4467 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4472 if (fptr
->ts
.type
== BT_CLASS
)
4474 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4479 if (gfc_is_coindexed (fptr
))
4481 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4482 "coindexed", &fptr
->where
);
4486 if (fptr
->rank
== 0 && shape
)
4488 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4489 "FPTR", &fptr
->where
);
4492 else if (fptr
->rank
&& !shape
)
4494 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4495 "FPTR at %L", &fptr
->where
);
4499 if (shape
&& !rank_check (shape
, 2, 1))
4502 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4508 if (gfc_array_size (shape
, &size
))
4510 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4513 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4514 "size as the RANK of FPTR", &shape
->where
);
4521 if (fptr
->ts
.type
== BT_CLASS
)
4523 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4527 if (!is_c_interoperable (fptr
, &msg
, false, true))
4528 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4529 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4536 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4538 symbol_attribute attr
;
4540 if (cptr
->ts
.type
!= BT_DERIVED
4541 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4542 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4544 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4545 "type TYPE(C_FUNPTR)", &cptr
->where
);
4549 if (!scalar_check (cptr
, 0))
4552 attr
= gfc_expr_attr (fptr
);
4554 if (!attr
.proc_pointer
)
4556 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4557 "pointer", &fptr
->where
);
4561 if (gfc_is_coindexed (fptr
))
4563 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4564 "coindexed", &fptr
->where
);
4568 if (!attr
.is_bind_c
)
4569 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4570 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4577 gfc_check_c_funloc (gfc_expr
*x
)
4579 symbol_attribute attr
;
4581 if (gfc_is_coindexed (x
))
4583 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4584 "coindexed", &x
->where
);
4588 attr
= gfc_expr_attr (x
);
4590 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4591 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4593 gfc_namespace
*ns
= gfc_current_ns
;
4595 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4596 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4598 gfc_error ("Function result %qs at %L is invalid as X argument "
4599 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4604 if (attr
.flavor
!= FL_PROCEDURE
)
4606 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4607 "or a procedure pointer", &x
->where
);
4611 if (!attr
.is_bind_c
)
4612 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4613 "at %L to C_FUNLOC", &x
->where
);
4619 gfc_check_c_loc (gfc_expr
*x
)
4621 symbol_attribute attr
;
4624 if (gfc_is_coindexed (x
))
4626 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4630 if (x
->ts
.type
== BT_CLASS
)
4632 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4637 attr
= gfc_expr_attr (x
);
4640 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4641 || attr
.flavor
== FL_PARAMETER
))
4643 gfc_error ("Argument X at %L to C_LOC shall have either "
4644 "the POINTER or the TARGET attribute", &x
->where
);
4648 if (x
->ts
.type
== BT_CHARACTER
4649 && gfc_var_strlen (x
) == 0)
4651 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4652 "string", &x
->where
);
4656 if (!is_c_interoperable (x
, &msg
, true, false))
4658 if (x
->ts
.type
== BT_CLASS
)
4660 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4666 && !gfc_notify_std (GFC_STD_F2008_TS
,
4667 "Noninteroperable array at %L as"
4668 " argument to C_LOC: %s", &x
->where
, msg
))
4671 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4673 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4675 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4676 && !attr
.allocatable
4677 && !gfc_notify_std (GFC_STD_F2008
,
4678 "Array of interoperable type at %L "
4679 "to C_LOC which is nonallocatable and neither "
4680 "assumed size nor explicit size", &x
->where
))
4682 else if (ar
->type
!= AR_FULL
4683 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4684 "to C_LOC", &x
->where
))
4693 gfc_check_sleep_sub (gfc_expr
*seconds
)
4695 if (!type_check (seconds
, 0, BT_INTEGER
))
4698 if (!scalar_check (seconds
, 0))
4705 gfc_check_sngl (gfc_expr
*a
)
4707 if (!type_check (a
, 0, BT_REAL
))
4710 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4711 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4712 "REAL argument to %s intrinsic at %L",
4713 gfc_current_intrinsic
, &a
->where
))
4720 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4722 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4724 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4725 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4726 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4734 if (!dim_check (dim
, 1, false))
4737 /* dim_rank_check() does not apply here. */
4739 && dim
->expr_type
== EXPR_CONSTANT
4740 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4741 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4743 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4744 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4745 gfc_current_intrinsic
, &dim
->where
);
4749 if (!type_check (ncopies
, 2, BT_INTEGER
))
4752 if (!scalar_check (ncopies
, 2))
4759 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4763 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4765 if (!type_check (unit
, 0, BT_INTEGER
))
4768 if (!scalar_check (unit
, 0))
4771 if (!type_check (c
, 1, BT_CHARACTER
))
4773 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4779 if (!type_check (status
, 2, BT_INTEGER
)
4780 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4781 || !scalar_check (status
, 2))
4789 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4791 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4796 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4798 if (!type_check (c
, 0, BT_CHARACTER
))
4800 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4806 if (!type_check (status
, 1, BT_INTEGER
)
4807 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4808 || !scalar_check (status
, 1))
4816 gfc_check_fgetput (gfc_expr
*c
)
4818 return gfc_check_fgetput_sub (c
, NULL
);
4823 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4825 if (!type_check (unit
, 0, BT_INTEGER
))
4828 if (!scalar_check (unit
, 0))
4831 if (!type_check (offset
, 1, BT_INTEGER
))
4834 if (!scalar_check (offset
, 1))
4837 if (!type_check (whence
, 2, BT_INTEGER
))
4840 if (!scalar_check (whence
, 2))
4846 if (!type_check (status
, 3, BT_INTEGER
))
4849 if (!kind_value_check (status
, 3, 4))
4852 if (!scalar_check (status
, 3))
4861 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4863 if (!type_check (unit
, 0, BT_INTEGER
))
4866 if (!scalar_check (unit
, 0))
4869 if (!type_check (array
, 1, BT_INTEGER
)
4870 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4873 if (!array_check (array
, 1))
4881 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4883 if (!type_check (unit
, 0, BT_INTEGER
))
4886 if (!scalar_check (unit
, 0))
4889 if (!type_check (array
, 1, BT_INTEGER
)
4890 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4893 if (!array_check (array
, 1))
4899 if (!type_check (status
, 2, BT_INTEGER
)
4900 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4903 if (!scalar_check (status
, 2))
4911 gfc_check_ftell (gfc_expr
*unit
)
4913 if (!type_check (unit
, 0, BT_INTEGER
))
4916 if (!scalar_check (unit
, 0))
4924 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4926 if (!type_check (unit
, 0, BT_INTEGER
))
4929 if (!scalar_check (unit
, 0))
4932 if (!type_check (offset
, 1, BT_INTEGER
))
4935 if (!scalar_check (offset
, 1))
4943 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4945 if (!type_check (name
, 0, BT_CHARACTER
))
4947 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4950 if (!type_check (array
, 1, BT_INTEGER
)
4951 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4954 if (!array_check (array
, 1))
4962 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4964 if (!type_check (name
, 0, BT_CHARACTER
))
4966 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4969 if (!type_check (array
, 1, BT_INTEGER
)
4970 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4973 if (!array_check (array
, 1))
4979 if (!type_check (status
, 2, BT_INTEGER
)
4980 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4983 if (!scalar_check (status
, 2))
4991 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4995 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4997 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5001 if (!coarray_check (coarray
, 0))
5006 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5007 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5011 if (gfc_array_size (sub
, &nelems
))
5013 int corank
= gfc_get_corank (coarray
);
5015 if (mpz_cmp_ui (nelems
, corank
) != 0)
5017 gfc_error ("The number of array elements of the SUB argument to "
5018 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5019 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5031 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5033 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5035 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5041 if (!type_check (distance
, 0, BT_INTEGER
))
5044 if (!nonnegative_check ("DISTANCE", distance
))
5047 if (!scalar_check (distance
, 0))
5050 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5051 "NUM_IMAGES at %L", &distance
->where
))
5057 if (!type_check (failed
, 1, BT_LOGICAL
))
5060 if (!scalar_check (failed
, 1))
5063 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5064 "NUM_IMAGES at %L", &distance
->where
))
5073 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5075 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5077 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5081 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5084 if (dim
!= NULL
&& coarray
== NULL
)
5086 gfc_error ("DIM argument without COARRAY argument not allowed for "
5087 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5091 if (distance
&& (coarray
|| dim
))
5093 gfc_error ("The DISTANCE argument may not be specified together with the "
5094 "COARRAY or DIM argument in intrinsic at %L",
5099 /* Assume that we have "this_image (distance)". */
5100 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5104 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5113 if (!type_check (distance
, 2, BT_INTEGER
))
5116 if (!nonnegative_check ("DISTANCE", distance
))
5119 if (!scalar_check (distance
, 2))
5122 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5123 "THIS_IMAGE at %L", &distance
->where
))
5129 if (!coarray_check (coarray
, 0))
5134 if (!dim_check (dim
, 1, false))
5137 if (!dim_corank_check (dim
, coarray
))
5144 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5145 by gfc_simplify_transfer. Return false if we cannot do so. */
5148 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5149 size_t *source_size
, size_t *result_size
,
5150 size_t *result_length_p
)
5152 size_t result_elt_size
;
5154 if (source
->expr_type
== EXPR_FUNCTION
)
5157 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5160 /* Calculate the size of the source. */
5161 *source_size
= gfc_target_expr_size (source
);
5162 if (*source_size
== 0)
5165 /* Determine the size of the element. */
5166 result_elt_size
= gfc_element_size (mold
);
5167 if (result_elt_size
== 0)
5170 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5175 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5178 result_length
= *source_size
/ result_elt_size
;
5179 if (result_length
* result_elt_size
< *source_size
)
5183 *result_size
= result_length
* result_elt_size
;
5184 if (result_length_p
)
5185 *result_length_p
= result_length
;
5188 *result_size
= result_elt_size
;
5195 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5200 if (mold
->ts
.type
== BT_HOLLERITH
)
5202 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5203 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5209 if (!type_check (size
, 2, BT_INTEGER
))
5212 if (!scalar_check (size
, 2))
5215 if (!nonoptional_check (size
, 2))
5219 if (!warn_surprising
)
5222 /* If we can't calculate the sizes, we cannot check any more.
5223 Return true for that case. */
5225 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5226 &result_size
, NULL
))
5229 if (source_size
< result_size
)
5230 gfc_warning (OPT_Wsurprising
,
5231 "Intrinsic TRANSFER at %L has partly undefined result: "
5232 "source size %ld < result size %ld", &source
->where
,
5233 (long) source_size
, (long) result_size
);
5240 gfc_check_transpose (gfc_expr
*matrix
)
5242 if (!rank_check (matrix
, 0, 2))
5250 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5252 if (!array_check (array
, 0))
5255 if (!dim_check (dim
, 1, false))
5258 if (!dim_rank_check (dim
, array
, 0))
5261 if (!kind_check (kind
, 2, BT_INTEGER
))
5263 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5264 "with KIND argument at %L",
5265 gfc_current_intrinsic
, &kind
->where
))
5273 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5275 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5277 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5281 if (!coarray_check (coarray
, 0))
5286 if (!dim_check (dim
, 1, false))
5289 if (!dim_corank_check (dim
, coarray
))
5293 if (!kind_check (kind
, 2, BT_INTEGER
))
5301 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5305 if (!rank_check (vector
, 0, 1))
5308 if (!array_check (mask
, 1))
5311 if (!type_check (mask
, 1, BT_LOGICAL
))
5314 if (!same_type_check (vector
, 0, field
, 2))
5317 if (mask
->expr_type
== EXPR_ARRAY
5318 && gfc_array_size (vector
, &vector_size
))
5320 int mask_true_count
= 0;
5321 gfc_constructor
*mask_ctor
;
5322 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5325 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5327 mask_true_count
= 0;
5331 if (mask_ctor
->expr
->value
.logical
)
5334 mask_ctor
= gfc_constructor_next (mask_ctor
);
5337 if (mpz_get_si (vector_size
) < mask_true_count
)
5339 gfc_error ("%qs argument of %qs intrinsic at %L must "
5340 "provide at least as many elements as there "
5341 "are .TRUE. values in %qs (%ld/%d)",
5342 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5343 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5344 mpz_get_si (vector_size
), mask_true_count
);
5348 mpz_clear (vector_size
);
5351 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5353 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5354 "the same rank as %qs or be a scalar",
5355 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5356 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5360 if (mask
->rank
== field
->rank
)
5363 for (i
= 0; i
< field
->rank
; i
++)
5364 if (! identical_dimen_shape (mask
, i
, field
, i
))
5366 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5367 "must have identical shape.",
5368 gfc_current_intrinsic_arg
[2]->name
,
5369 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5379 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5381 if (!type_check (x
, 0, BT_CHARACTER
))
5384 if (!same_type_check (x
, 0, y
, 1))
5387 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5390 if (!kind_check (kind
, 3, BT_INTEGER
))
5392 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5393 "with KIND argument at %L",
5394 gfc_current_intrinsic
, &kind
->where
))
5402 gfc_check_trim (gfc_expr
*x
)
5404 if (!type_check (x
, 0, BT_CHARACTER
))
5407 if (!scalar_check (x
, 0))
5415 gfc_check_ttynam (gfc_expr
*unit
)
5417 if (!scalar_check (unit
, 0))
5420 if (!type_check (unit
, 0, BT_INTEGER
))
5427 /* Common check function for the half a dozen intrinsics that have a
5428 single real argument. */
5431 gfc_check_x (gfc_expr
*x
)
5433 if (!type_check (x
, 0, BT_REAL
))
5440 /************* Check functions for intrinsic subroutines *************/
5443 gfc_check_cpu_time (gfc_expr
*time
)
5445 if (!scalar_check (time
, 0))
5448 if (!type_check (time
, 0, BT_REAL
))
5451 if (!variable_check (time
, 0, false))
5459 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5460 gfc_expr
*zone
, gfc_expr
*values
)
5464 if (!type_check (date
, 0, BT_CHARACTER
))
5466 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5468 if (!scalar_check (date
, 0))
5470 if (!variable_check (date
, 0, false))
5476 if (!type_check (time
, 1, BT_CHARACTER
))
5478 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5480 if (!scalar_check (time
, 1))
5482 if (!variable_check (time
, 1, false))
5488 if (!type_check (zone
, 2, BT_CHARACTER
))
5490 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5492 if (!scalar_check (zone
, 2))
5494 if (!variable_check (zone
, 2, false))
5500 if (!type_check (values
, 3, BT_INTEGER
))
5502 if (!array_check (values
, 3))
5504 if (!rank_check (values
, 3, 1))
5506 if (!variable_check (values
, 3, false))
5515 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5516 gfc_expr
*to
, gfc_expr
*topos
)
5518 if (!type_check (from
, 0, BT_INTEGER
))
5521 if (!type_check (frompos
, 1, BT_INTEGER
))
5524 if (!type_check (len
, 2, BT_INTEGER
))
5527 if (!same_type_check (from
, 0, to
, 3))
5530 if (!variable_check (to
, 3, false))
5533 if (!type_check (topos
, 4, BT_INTEGER
))
5536 if (!nonnegative_check ("frompos", frompos
))
5539 if (!nonnegative_check ("topos", topos
))
5542 if (!nonnegative_check ("len", len
))
5545 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5548 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5556 gfc_check_random_number (gfc_expr
*harvest
)
5558 if (!type_check (harvest
, 0, BT_REAL
))
5561 if (!variable_check (harvest
, 0, false))
5569 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5571 unsigned int nargs
= 0, seed_size
;
5572 locus
*where
= NULL
;
5573 mpz_t put_size
, get_size
;
5575 /* Keep the number of bytes in sync with master_state in
5576 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5577 part of the state too. */
5578 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5582 if (size
->expr_type
!= EXPR_VARIABLE
5583 || !size
->symtree
->n
.sym
->attr
.optional
)
5586 if (!scalar_check (size
, 0))
5589 if (!type_check (size
, 0, BT_INTEGER
))
5592 if (!variable_check (size
, 0, false))
5595 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5601 if (put
->expr_type
!= EXPR_VARIABLE
5602 || !put
->symtree
->n
.sym
->attr
.optional
)
5605 where
= &put
->where
;
5608 if (!array_check (put
, 1))
5611 if (!rank_check (put
, 1, 1))
5614 if (!type_check (put
, 1, BT_INTEGER
))
5617 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5620 if (gfc_array_size (put
, &put_size
)
5621 && mpz_get_ui (put_size
) < seed_size
)
5622 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5623 "too small (%i/%i)",
5624 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5625 where
, (int) mpz_get_ui (put_size
), seed_size
);
5630 if (get
->expr_type
!= EXPR_VARIABLE
5631 || !get
->symtree
->n
.sym
->attr
.optional
)
5634 where
= &get
->where
;
5637 if (!array_check (get
, 2))
5640 if (!rank_check (get
, 2, 1))
5643 if (!type_check (get
, 2, BT_INTEGER
))
5646 if (!variable_check (get
, 2, false))
5649 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5652 if (gfc_array_size (get
, &get_size
)
5653 && mpz_get_ui (get_size
) < seed_size
)
5654 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5655 "too small (%i/%i)",
5656 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5657 where
, (int) mpz_get_ui (get_size
), seed_size
);
5660 /* RANDOM_SEED may not have more than one non-optional argument. */
5662 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5668 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5672 int num_percent
, nargs
;
5675 if (e
->expr_type
!= EXPR_CONSTANT
)
5678 len
= e
->value
.character
.length
;
5679 if (e
->value
.character
.string
[len
-1] != '\0')
5680 gfc_internal_error ("fe_runtime_error string must be null terminated");
5683 for (i
=0; i
<len
-1; i
++)
5684 if (e
->value
.character
.string
[i
] == '%')
5688 for (; a
; a
= a
->next
)
5691 if (nargs
-1 != num_percent
)
5692 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5693 nargs
, num_percent
++);
5699 gfc_check_second_sub (gfc_expr
*time
)
5701 if (!scalar_check (time
, 0))
5704 if (!type_check (time
, 0, BT_REAL
))
5707 if (!kind_value_check (time
, 0, 4))
5714 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5715 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5716 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5717 count_max are all optional arguments */
5720 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5721 gfc_expr
*count_max
)
5725 if (!scalar_check (count
, 0))
5728 if (!type_check (count
, 0, BT_INTEGER
))
5731 if (count
->ts
.kind
!= gfc_default_integer_kind
5732 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5733 "SYSTEM_CLOCK at %L has non-default kind",
5737 if (!variable_check (count
, 0, false))
5741 if (count_rate
!= NULL
)
5743 if (!scalar_check (count_rate
, 1))
5746 if (!variable_check (count_rate
, 1, false))
5749 if (count_rate
->ts
.type
== BT_REAL
)
5751 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5752 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5757 if (!type_check (count_rate
, 1, BT_INTEGER
))
5760 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5761 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5762 "SYSTEM_CLOCK at %L has non-default kind",
5763 &count_rate
->where
))
5769 if (count_max
!= NULL
)
5771 if (!scalar_check (count_max
, 2))
5774 if (!type_check (count_max
, 2, BT_INTEGER
))
5777 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5778 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5779 "SYSTEM_CLOCK at %L has non-default kind",
5783 if (!variable_check (count_max
, 2, false))
5792 gfc_check_irand (gfc_expr
*x
)
5797 if (!scalar_check (x
, 0))
5800 if (!type_check (x
, 0, BT_INTEGER
))
5803 if (!kind_value_check (x
, 0, 4))
5811 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5813 if (!scalar_check (seconds
, 0))
5815 if (!type_check (seconds
, 0, BT_INTEGER
))
5818 if (!int_or_proc_check (handler
, 1))
5820 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5826 if (!scalar_check (status
, 2))
5828 if (!type_check (status
, 2, BT_INTEGER
))
5830 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5838 gfc_check_rand (gfc_expr
*x
)
5843 if (!scalar_check (x
, 0))
5846 if (!type_check (x
, 0, BT_INTEGER
))
5849 if (!kind_value_check (x
, 0, 4))
5857 gfc_check_srand (gfc_expr
*x
)
5859 if (!scalar_check (x
, 0))
5862 if (!type_check (x
, 0, BT_INTEGER
))
5865 if (!kind_value_check (x
, 0, 4))
5873 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5875 if (!scalar_check (time
, 0))
5877 if (!type_check (time
, 0, BT_INTEGER
))
5880 if (!type_check (result
, 1, BT_CHARACTER
))
5882 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5890 gfc_check_dtime_etime (gfc_expr
*x
)
5892 if (!array_check (x
, 0))
5895 if (!rank_check (x
, 0, 1))
5898 if (!variable_check (x
, 0, false))
5901 if (!type_check (x
, 0, BT_REAL
))
5904 if (!kind_value_check (x
, 0, 4))
5912 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5914 if (!array_check (values
, 0))
5917 if (!rank_check (values
, 0, 1))
5920 if (!variable_check (values
, 0, false))
5923 if (!type_check (values
, 0, BT_REAL
))
5926 if (!kind_value_check (values
, 0, 4))
5929 if (!scalar_check (time
, 1))
5932 if (!type_check (time
, 1, BT_REAL
))
5935 if (!kind_value_check (time
, 1, 4))
5943 gfc_check_fdate_sub (gfc_expr
*date
)
5945 if (!type_check (date
, 0, BT_CHARACTER
))
5947 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5955 gfc_check_gerror (gfc_expr
*msg
)
5957 if (!type_check (msg
, 0, BT_CHARACTER
))
5959 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5967 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5969 if (!type_check (cwd
, 0, BT_CHARACTER
))
5971 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5977 if (!scalar_check (status
, 1))
5980 if (!type_check (status
, 1, BT_INTEGER
))
5988 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5990 if (!type_check (pos
, 0, BT_INTEGER
))
5993 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5995 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
5996 "not wider than the default kind (%d)",
5997 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5998 &pos
->where
, gfc_default_integer_kind
);
6002 if (!type_check (value
, 1, BT_CHARACTER
))
6004 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6012 gfc_check_getlog (gfc_expr
*msg
)
6014 if (!type_check (msg
, 0, BT_CHARACTER
))
6016 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6024 gfc_check_exit (gfc_expr
*status
)
6029 if (!type_check (status
, 0, BT_INTEGER
))
6032 if (!scalar_check (status
, 0))
6040 gfc_check_flush (gfc_expr
*unit
)
6045 if (!type_check (unit
, 0, BT_INTEGER
))
6048 if (!scalar_check (unit
, 0))
6056 gfc_check_free (gfc_expr
*i
)
6058 if (!type_check (i
, 0, BT_INTEGER
))
6061 if (!scalar_check (i
, 0))
6069 gfc_check_hostnm (gfc_expr
*name
)
6071 if (!type_check (name
, 0, BT_CHARACTER
))
6073 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6081 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6083 if (!type_check (name
, 0, BT_CHARACTER
))
6085 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6091 if (!scalar_check (status
, 1))
6094 if (!type_check (status
, 1, BT_INTEGER
))
6102 gfc_check_itime_idate (gfc_expr
*values
)
6104 if (!array_check (values
, 0))
6107 if (!rank_check (values
, 0, 1))
6110 if (!variable_check (values
, 0, false))
6113 if (!type_check (values
, 0, BT_INTEGER
))
6116 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6124 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6126 if (!type_check (time
, 0, BT_INTEGER
))
6129 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6132 if (!scalar_check (time
, 0))
6135 if (!array_check (values
, 1))
6138 if (!rank_check (values
, 1, 1))
6141 if (!variable_check (values
, 1, false))
6144 if (!type_check (values
, 1, BT_INTEGER
))
6147 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6155 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6157 if (!scalar_check (unit
, 0))
6160 if (!type_check (unit
, 0, BT_INTEGER
))
6163 if (!type_check (name
, 1, BT_CHARACTER
))
6165 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6173 gfc_check_isatty (gfc_expr
*unit
)
6178 if (!type_check (unit
, 0, BT_INTEGER
))
6181 if (!scalar_check (unit
, 0))
6189 gfc_check_isnan (gfc_expr
*x
)
6191 if (!type_check (x
, 0, BT_REAL
))
6199 gfc_check_perror (gfc_expr
*string
)
6201 if (!type_check (string
, 0, BT_CHARACTER
))
6203 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6211 gfc_check_umask (gfc_expr
*mask
)
6213 if (!type_check (mask
, 0, BT_INTEGER
))
6216 if (!scalar_check (mask
, 0))
6224 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6226 if (!type_check (mask
, 0, BT_INTEGER
))
6229 if (!scalar_check (mask
, 0))
6235 if (!scalar_check (old
, 1))
6238 if (!type_check (old
, 1, BT_INTEGER
))
6246 gfc_check_unlink (gfc_expr
*name
)
6248 if (!type_check (name
, 0, BT_CHARACTER
))
6250 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6258 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6260 if (!type_check (name
, 0, BT_CHARACTER
))
6262 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6268 if (!scalar_check (status
, 1))
6271 if (!type_check (status
, 1, BT_INTEGER
))
6279 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6281 if (!scalar_check (number
, 0))
6283 if (!type_check (number
, 0, BT_INTEGER
))
6286 if (!int_or_proc_check (handler
, 1))
6288 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6296 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6298 if (!scalar_check (number
, 0))
6300 if (!type_check (number
, 0, BT_INTEGER
))
6303 if (!int_or_proc_check (handler
, 1))
6305 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6311 if (!type_check (status
, 2, BT_INTEGER
))
6313 if (!scalar_check (status
, 2))
6321 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6323 if (!type_check (cmd
, 0, BT_CHARACTER
))
6325 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6328 if (!scalar_check (status
, 1))
6331 if (!type_check (status
, 1, BT_INTEGER
))
6334 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6341 /* This is used for the GNU intrinsics AND, OR and XOR. */
6343 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6345 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6347 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6348 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6349 gfc_current_intrinsic
, &i
->where
);
6353 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6355 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6356 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6357 gfc_current_intrinsic
, &j
->where
);
6361 if (i
->ts
.type
!= j
->ts
.type
)
6363 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6364 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6365 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6370 if (!scalar_check (i
, 0))
6373 if (!scalar_check (j
, 1))
6381 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6384 if (a
->expr_type
== EXPR_NULL
)
6386 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6387 "argument to STORAGE_SIZE, because it returns a "
6388 "disassociated pointer", &a
->where
);
6392 if (a
->ts
.type
== BT_ASSUMED
)
6394 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6395 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6400 if (a
->ts
.type
== BT_PROCEDURE
)
6402 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6403 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6404 gfc_current_intrinsic
, &a
->where
);
6411 if (!type_check (kind
, 1, BT_INTEGER
))
6414 if (!scalar_check (kind
, 1))
6417 if (kind
->expr_type
!= EXPR_CONSTANT
)
6419 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6420 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,