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 /* CLASS arguments: Make sure the vtab of from is present. */
3346 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3347 gfc_find_vtab (&from
->ts
);
3354 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3356 if (!type_check (x
, 0, BT_REAL
))
3359 if (!type_check (s
, 1, BT_REAL
))
3362 if (s
->expr_type
== EXPR_CONSTANT
)
3364 if (mpfr_sgn (s
->value
.real
) == 0)
3366 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3377 gfc_check_new_line (gfc_expr
*a
)
3379 if (!type_check (a
, 0, BT_CHARACTER
))
3387 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3389 if (!type_check (array
, 0, BT_REAL
))
3392 if (!array_check (array
, 0))
3395 if (!dim_rank_check (dim
, array
, false))
3402 gfc_check_null (gfc_expr
*mold
)
3404 symbol_attribute attr
;
3409 if (!variable_check (mold
, 0, true))
3412 attr
= gfc_variable_attr (mold
, NULL
);
3414 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3416 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3417 "ALLOCATABLE or procedure pointer",
3418 gfc_current_intrinsic_arg
[0]->name
,
3419 gfc_current_intrinsic
, &mold
->where
);
3423 if (attr
.allocatable
3424 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3425 "allocatable MOLD at %L", &mold
->where
))
3429 if (gfc_is_coindexed (mold
))
3431 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3432 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3433 gfc_current_intrinsic
, &mold
->where
);
3442 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3444 if (!array_check (array
, 0))
3447 if (!type_check (mask
, 1, BT_LOGICAL
))
3450 if (!gfc_check_conformance (array
, mask
,
3451 "arguments '%s' and '%s' for intrinsic '%s'",
3452 gfc_current_intrinsic_arg
[0]->name
,
3453 gfc_current_intrinsic_arg
[1]->name
,
3454 gfc_current_intrinsic
))
3459 mpz_t array_size
, vector_size
;
3460 bool have_array_size
, have_vector_size
;
3462 if (!same_type_check (array
, 0, vector
, 2))
3465 if (!rank_check (vector
, 2, 1))
3468 /* VECTOR requires at least as many elements as MASK
3469 has .TRUE. values. */
3470 have_array_size
= gfc_array_size(array
, &array_size
);
3471 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3473 if (have_vector_size
3474 && (mask
->expr_type
== EXPR_ARRAY
3475 || (mask
->expr_type
== EXPR_CONSTANT
3476 && have_array_size
)))
3478 int mask_true_values
= 0;
3480 if (mask
->expr_type
== EXPR_ARRAY
)
3482 gfc_constructor
*mask_ctor
;
3483 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3486 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3488 mask_true_values
= 0;
3492 if (mask_ctor
->expr
->value
.logical
)
3495 mask_ctor
= gfc_constructor_next (mask_ctor
);
3498 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3499 mask_true_values
= mpz_get_si (array_size
);
3501 if (mpz_get_si (vector_size
) < mask_true_values
)
3503 gfc_error ("%qs argument of %qs intrinsic at %L must "
3504 "provide at least as many elements as there "
3505 "are .TRUE. values in %qs (%ld/%d)",
3506 gfc_current_intrinsic_arg
[2]->name
,
3507 gfc_current_intrinsic
, &vector
->where
,
3508 gfc_current_intrinsic_arg
[1]->name
,
3509 mpz_get_si (vector_size
), mask_true_values
);
3514 if (have_array_size
)
3515 mpz_clear (array_size
);
3516 if (have_vector_size
)
3517 mpz_clear (vector_size
);
3525 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3527 if (!type_check (mask
, 0, BT_LOGICAL
))
3530 if (!array_check (mask
, 0))
3533 if (!dim_rank_check (dim
, mask
, false))
3541 gfc_check_precision (gfc_expr
*x
)
3543 if (!real_or_complex_check (x
, 0))
3551 gfc_check_present (gfc_expr
*a
)
3555 if (!variable_check (a
, 0, true))
3558 sym
= a
->symtree
->n
.sym
;
3559 if (!sym
->attr
.dummy
)
3561 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3562 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3563 gfc_current_intrinsic
, &a
->where
);
3567 if (!sym
->attr
.optional
)
3569 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3570 "an OPTIONAL dummy variable",
3571 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3576 /* 13.14.82 PRESENT(A)
3578 Argument. A shall be the name of an optional dummy argument that is
3579 accessible in the subprogram in which the PRESENT function reference
3583 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3584 && (a
->ref
->u
.ar
.type
== AR_FULL
3585 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3586 && a
->ref
->u
.ar
.as
->rank
== 0))))
3588 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3589 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3590 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3599 gfc_check_radix (gfc_expr
*x
)
3601 if (!int_or_real_check (x
, 0))
3609 gfc_check_range (gfc_expr
*x
)
3611 if (!numeric_check (x
, 0))
3619 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3621 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3622 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3624 bool is_variable
= true;
3626 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3627 if (a
->expr_type
== EXPR_FUNCTION
)
3628 is_variable
= a
->value
.function
.esym
3629 ? a
->value
.function
.esym
->result
->attr
.pointer
3630 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3632 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3633 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3636 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3637 "object", &a
->where
);
3645 /* real, float, sngl. */
3647 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3649 if (!numeric_check (a
, 0))
3652 if (!kind_check (kind
, 1, BT_REAL
))
3660 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3662 if (!type_check (path1
, 0, BT_CHARACTER
))
3664 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3667 if (!type_check (path2
, 1, BT_CHARACTER
))
3669 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3677 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3679 if (!type_check (path1
, 0, BT_CHARACTER
))
3681 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3684 if (!type_check (path2
, 1, BT_CHARACTER
))
3686 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3692 if (!type_check (status
, 2, BT_INTEGER
))
3695 if (!scalar_check (status
, 2))
3703 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3705 if (!type_check (x
, 0, BT_CHARACTER
))
3708 if (!scalar_check (x
, 0))
3711 if (!type_check (y
, 0, BT_INTEGER
))
3714 if (!scalar_check (y
, 1))
3722 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3723 gfc_expr
*pad
, gfc_expr
*order
)
3729 if (!array_check (source
, 0))
3732 if (!rank_check (shape
, 1, 1))
3735 if (!type_check (shape
, 1, BT_INTEGER
))
3738 if (!gfc_array_size (shape
, &size
))
3740 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3741 "array of constant size", &shape
->where
);
3745 shape_size
= mpz_get_ui (size
);
3748 if (shape_size
<= 0)
3750 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3751 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3755 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3757 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
3758 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3761 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3765 for (i
= 0; i
< shape_size
; ++i
)
3767 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3768 if (e
->expr_type
!= EXPR_CONSTANT
)
3771 gfc_extract_int (e
, &extent
);
3774 gfc_error ("%qs argument of %qs intrinsic at %L has "
3775 "negative element (%d)",
3776 gfc_current_intrinsic_arg
[1]->name
,
3777 gfc_current_intrinsic
, &e
->where
, extent
);
3782 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
3783 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
3784 && shape
->ref
->u
.ar
.as
3785 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
3786 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
3787 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
3788 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
3789 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
3794 v
= shape
->symtree
->n
.sym
->value
;
3796 for (i
= 0; i
< shape_size
; i
++)
3798 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
3802 gfc_extract_int (e
, &extent
);
3806 gfc_error ("Element %d of actual argument of RESHAPE at %L "
3807 "cannot be negative", i
+ 1, &shape
->where
);
3815 if (!same_type_check (source
, 0, pad
, 2))
3818 if (!array_check (pad
, 2))
3824 if (!array_check (order
, 3))
3827 if (!type_check (order
, 3, BT_INTEGER
))
3830 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
3832 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3835 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3838 gfc_array_size (order
, &size
);
3839 order_size
= mpz_get_ui (size
);
3842 if (order_size
!= shape_size
)
3844 gfc_error ("%qs argument of %qs intrinsic at %L "
3845 "has wrong number of elements (%d/%d)",
3846 gfc_current_intrinsic_arg
[3]->name
,
3847 gfc_current_intrinsic
, &order
->where
,
3848 order_size
, shape_size
);
3852 for (i
= 1; i
<= order_size
; ++i
)
3854 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3855 if (e
->expr_type
!= EXPR_CONSTANT
)
3858 gfc_extract_int (e
, &dim
);
3860 if (dim
< 1 || dim
> order_size
)
3862 gfc_error ("%qs argument of %qs intrinsic at %L "
3863 "has out-of-range dimension (%d)",
3864 gfc_current_intrinsic_arg
[3]->name
,
3865 gfc_current_intrinsic
, &e
->where
, dim
);
3869 if (perm
[dim
-1] != 0)
3871 gfc_error ("%qs argument of %qs intrinsic at %L has "
3872 "invalid permutation of dimensions (dimension "
3874 gfc_current_intrinsic_arg
[3]->name
,
3875 gfc_current_intrinsic
, &e
->where
, dim
);
3884 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3885 && gfc_is_constant_expr (shape
)
3886 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3887 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3889 /* Check the match in size between source and destination. */
3890 if (gfc_array_size (source
, &nelems
))
3896 mpz_init_set_ui (size
, 1);
3897 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3898 c
; c
= gfc_constructor_next (c
))
3899 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3901 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3907 gfc_error ("Without padding, there are not enough elements "
3908 "in the intrinsic RESHAPE source at %L to match "
3909 "the shape", &source
->where
);
3920 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3922 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3924 gfc_error ("%qs argument of %qs intrinsic at %L "
3925 "cannot be of type %s",
3926 gfc_current_intrinsic_arg
[0]->name
,
3927 gfc_current_intrinsic
,
3928 &a
->where
, gfc_typename (&a
->ts
));
3932 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3934 gfc_error ("%qs argument of %qs intrinsic at %L "
3935 "must be of an extensible type",
3936 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3941 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3943 gfc_error ("%qs argument of %qs intrinsic at %L "
3944 "cannot be of type %s",
3945 gfc_current_intrinsic_arg
[0]->name
,
3946 gfc_current_intrinsic
,
3947 &b
->where
, gfc_typename (&b
->ts
));
3951 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3953 gfc_error ("%qs argument of %qs intrinsic at %L "
3954 "must be of an extensible type",
3955 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3965 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3967 if (!type_check (x
, 0, BT_REAL
))
3970 if (!type_check (i
, 1, BT_INTEGER
))
3978 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3980 if (!type_check (x
, 0, BT_CHARACTER
))
3983 if (!type_check (y
, 1, BT_CHARACTER
))
3986 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
3989 if (!kind_check (kind
, 3, BT_INTEGER
))
3991 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3992 "with KIND argument at %L",
3993 gfc_current_intrinsic
, &kind
->where
))
3996 if (!same_type_check (x
, 0, y
, 1))
4004 gfc_check_secnds (gfc_expr
*r
)
4006 if (!type_check (r
, 0, BT_REAL
))
4009 if (!kind_value_check (r
, 0, 4))
4012 if (!scalar_check (r
, 0))
4020 gfc_check_selected_char_kind (gfc_expr
*name
)
4022 if (!type_check (name
, 0, BT_CHARACTER
))
4025 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4028 if (!scalar_check (name
, 0))
4036 gfc_check_selected_int_kind (gfc_expr
*r
)
4038 if (!type_check (r
, 0, BT_INTEGER
))
4041 if (!scalar_check (r
, 0))
4049 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4051 if (p
== NULL
&& r
== NULL
4052 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4053 " neither %<P%> nor %<R%> argument at %L",
4054 gfc_current_intrinsic_where
))
4059 if (!type_check (p
, 0, BT_INTEGER
))
4062 if (!scalar_check (p
, 0))
4068 if (!type_check (r
, 1, BT_INTEGER
))
4071 if (!scalar_check (r
, 1))
4077 if (!type_check (radix
, 1, BT_INTEGER
))
4080 if (!scalar_check (radix
, 1))
4083 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4084 "RADIX argument at %L", gfc_current_intrinsic
,
4094 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4096 if (!type_check (x
, 0, BT_REAL
))
4099 if (!type_check (i
, 1, BT_INTEGER
))
4107 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4111 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4114 ar
= gfc_find_array_ref (source
);
4116 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4118 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4119 "an assumed size array", &source
->where
);
4123 if (!kind_check (kind
, 1, BT_INTEGER
))
4125 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4126 "with KIND argument at %L",
4127 gfc_current_intrinsic
, &kind
->where
))
4135 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4137 if (!type_check (i
, 0, BT_INTEGER
))
4140 if (!type_check (shift
, 0, BT_INTEGER
))
4143 if (!nonnegative_check ("SHIFT", shift
))
4146 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4154 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4156 if (!int_or_real_check (a
, 0))
4159 if (!same_type_check (a
, 0, b
, 1))
4167 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4169 if (!array_check (array
, 0))
4172 if (!dim_check (dim
, 1, true))
4175 if (!dim_rank_check (dim
, array
, 0))
4178 if (!kind_check (kind
, 2, BT_INTEGER
))
4180 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4181 "with KIND argument at %L",
4182 gfc_current_intrinsic
, &kind
->where
))
4191 gfc_check_sizeof (gfc_expr
*arg
)
4193 if (arg
->ts
.type
== BT_PROCEDURE
)
4195 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4196 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4201 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4202 if (arg
->ts
.type
== BT_ASSUMED
4203 && (arg
->symtree
->n
.sym
->as
== NULL
4204 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4205 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4206 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4208 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4209 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4214 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4215 && arg
->symtree
->n
.sym
->as
!= NULL
4216 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4217 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4219 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4220 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4221 gfc_current_intrinsic
, &arg
->where
);
4229 /* Check whether an expression is interoperable. When returning false,
4230 msg is set to a string telling why the expression is not interoperable,
4231 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4232 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4233 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4234 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4238 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4242 if (expr
->ts
.type
== BT_CLASS
)
4244 *msg
= "Expression is polymorphic";
4248 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4249 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4251 *msg
= "Expression is a noninteroperable derived type";
4255 if (expr
->ts
.type
== BT_PROCEDURE
)
4257 *msg
= "Procedure unexpected as argument";
4261 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4264 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4265 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4267 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4271 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4272 && expr
->ts
.kind
!= 1)
4274 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4278 if (expr
->ts
.type
== BT_CHARACTER
) {
4279 if (expr
->ts
.deferred
)
4281 /* TS 29113 allows deferred-length strings as dummy arguments,
4282 but it is not an interoperable type. */
4283 *msg
= "Expression shall not be a deferred-length string";
4287 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4288 && !gfc_simplify_expr (expr
, 0))
4289 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4291 if (!c_loc
&& expr
->ts
.u
.cl
4292 && (!expr
->ts
.u
.cl
->length
4293 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4294 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4296 *msg
= "Type shall have a character length of 1";
4301 /* Note: The following checks are about interoperatable variables, Fortran
4302 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4303 is allowed, e.g. assumed-shape arrays with TS 29113. */
4305 if (gfc_is_coarray (expr
))
4307 *msg
= "Coarrays are not interoperable";
4311 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4313 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4314 if (ar
->type
!= AR_FULL
)
4316 *msg
= "Only whole-arrays are interoperable";
4319 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4320 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4322 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4332 gfc_check_c_sizeof (gfc_expr
*arg
)
4336 if (!is_c_interoperable (arg
, &msg
, false, false))
4338 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4339 "interoperable data entity: %s",
4340 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4345 if (arg
->ts
.type
== BT_ASSUMED
)
4347 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4349 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4354 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4355 && arg
->symtree
->n
.sym
->as
!= NULL
4356 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4357 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4359 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4360 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4361 gfc_current_intrinsic
, &arg
->where
);
4370 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4372 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4373 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4374 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4375 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4377 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4378 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4382 if (!scalar_check (c_ptr_1
, 0))
4386 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4387 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4388 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4389 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4391 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4392 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4393 gfc_typename (&c_ptr_1
->ts
),
4394 gfc_typename (&c_ptr_2
->ts
));
4398 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4406 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4408 symbol_attribute attr
;
4411 if (cptr
->ts
.type
!= BT_DERIVED
4412 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4413 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4415 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4416 "type TYPE(C_PTR)", &cptr
->where
);
4420 if (!scalar_check (cptr
, 0))
4423 attr
= gfc_expr_attr (fptr
);
4427 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4432 if (fptr
->ts
.type
== BT_CLASS
)
4434 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4439 if (gfc_is_coindexed (fptr
))
4441 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4442 "coindexed", &fptr
->where
);
4446 if (fptr
->rank
== 0 && shape
)
4448 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4449 "FPTR", &fptr
->where
);
4452 else if (fptr
->rank
&& !shape
)
4454 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4455 "FPTR at %L", &fptr
->where
);
4459 if (shape
&& !rank_check (shape
, 2, 1))
4462 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4468 if (gfc_array_size (shape
, &size
))
4470 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4473 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4474 "size as the RANK of FPTR", &shape
->where
);
4481 if (fptr
->ts
.type
== BT_CLASS
)
4483 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4487 if (!is_c_interoperable (fptr
, &msg
, false, true))
4488 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4489 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4496 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4498 symbol_attribute attr
;
4500 if (cptr
->ts
.type
!= BT_DERIVED
4501 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4502 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4504 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4505 "type TYPE(C_FUNPTR)", &cptr
->where
);
4509 if (!scalar_check (cptr
, 0))
4512 attr
= gfc_expr_attr (fptr
);
4514 if (!attr
.proc_pointer
)
4516 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4517 "pointer", &fptr
->where
);
4521 if (gfc_is_coindexed (fptr
))
4523 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4524 "coindexed", &fptr
->where
);
4528 if (!attr
.is_bind_c
)
4529 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4530 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4537 gfc_check_c_funloc (gfc_expr
*x
)
4539 symbol_attribute attr
;
4541 if (gfc_is_coindexed (x
))
4543 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4544 "coindexed", &x
->where
);
4548 attr
= gfc_expr_attr (x
);
4550 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4551 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4553 gfc_namespace
*ns
= gfc_current_ns
;
4555 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4556 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4558 gfc_error ("Function result %qs at %L is invalid as X argument "
4559 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4564 if (attr
.flavor
!= FL_PROCEDURE
)
4566 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4567 "or a procedure pointer", &x
->where
);
4571 if (!attr
.is_bind_c
)
4572 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4573 "at %L to C_FUNLOC", &x
->where
);
4579 gfc_check_c_loc (gfc_expr
*x
)
4581 symbol_attribute attr
;
4584 if (gfc_is_coindexed (x
))
4586 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4590 if (x
->ts
.type
== BT_CLASS
)
4592 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4597 attr
= gfc_expr_attr (x
);
4600 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4601 || attr
.flavor
== FL_PARAMETER
))
4603 gfc_error ("Argument X at %L to C_LOC shall have either "
4604 "the POINTER or the TARGET attribute", &x
->where
);
4608 if (x
->ts
.type
== BT_CHARACTER
4609 && gfc_var_strlen (x
) == 0)
4611 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4612 "string", &x
->where
);
4616 if (!is_c_interoperable (x
, &msg
, true, false))
4618 if (x
->ts
.type
== BT_CLASS
)
4620 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4626 && !gfc_notify_std (GFC_STD_F2008_TS
,
4627 "Noninteroperable array at %L as"
4628 " argument to C_LOC: %s", &x
->where
, msg
))
4631 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4633 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4635 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4636 && !attr
.allocatable
4637 && !gfc_notify_std (GFC_STD_F2008
,
4638 "Array of interoperable type at %L "
4639 "to C_LOC which is nonallocatable and neither "
4640 "assumed size nor explicit size", &x
->where
))
4642 else if (ar
->type
!= AR_FULL
4643 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4644 "to C_LOC", &x
->where
))
4653 gfc_check_sleep_sub (gfc_expr
*seconds
)
4655 if (!type_check (seconds
, 0, BT_INTEGER
))
4658 if (!scalar_check (seconds
, 0))
4665 gfc_check_sngl (gfc_expr
*a
)
4667 if (!type_check (a
, 0, BT_REAL
))
4670 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4671 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4672 "REAL argument to %s intrinsic at %L",
4673 gfc_current_intrinsic
, &a
->where
))
4680 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4682 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4684 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4685 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4686 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4694 if (!dim_check (dim
, 1, false))
4697 /* dim_rank_check() does not apply here. */
4699 && dim
->expr_type
== EXPR_CONSTANT
4700 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4701 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4703 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4704 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4705 gfc_current_intrinsic
, &dim
->where
);
4709 if (!type_check (ncopies
, 2, BT_INTEGER
))
4712 if (!scalar_check (ncopies
, 2))
4719 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4723 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4725 if (!type_check (unit
, 0, BT_INTEGER
))
4728 if (!scalar_check (unit
, 0))
4731 if (!type_check (c
, 1, BT_CHARACTER
))
4733 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4739 if (!type_check (status
, 2, BT_INTEGER
)
4740 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4741 || !scalar_check (status
, 2))
4749 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4751 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4756 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4758 if (!type_check (c
, 0, BT_CHARACTER
))
4760 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4766 if (!type_check (status
, 1, BT_INTEGER
)
4767 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4768 || !scalar_check (status
, 1))
4776 gfc_check_fgetput (gfc_expr
*c
)
4778 return gfc_check_fgetput_sub (c
, NULL
);
4783 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4785 if (!type_check (unit
, 0, BT_INTEGER
))
4788 if (!scalar_check (unit
, 0))
4791 if (!type_check (offset
, 1, BT_INTEGER
))
4794 if (!scalar_check (offset
, 1))
4797 if (!type_check (whence
, 2, BT_INTEGER
))
4800 if (!scalar_check (whence
, 2))
4806 if (!type_check (status
, 3, BT_INTEGER
))
4809 if (!kind_value_check (status
, 3, 4))
4812 if (!scalar_check (status
, 3))
4821 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4823 if (!type_check (unit
, 0, BT_INTEGER
))
4826 if (!scalar_check (unit
, 0))
4829 if (!type_check (array
, 1, BT_INTEGER
)
4830 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4833 if (!array_check (array
, 1))
4841 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4843 if (!type_check (unit
, 0, BT_INTEGER
))
4846 if (!scalar_check (unit
, 0))
4849 if (!type_check (array
, 1, BT_INTEGER
)
4850 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4853 if (!array_check (array
, 1))
4859 if (!type_check (status
, 2, BT_INTEGER
)
4860 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4863 if (!scalar_check (status
, 2))
4871 gfc_check_ftell (gfc_expr
*unit
)
4873 if (!type_check (unit
, 0, BT_INTEGER
))
4876 if (!scalar_check (unit
, 0))
4884 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4886 if (!type_check (unit
, 0, BT_INTEGER
))
4889 if (!scalar_check (unit
, 0))
4892 if (!type_check (offset
, 1, BT_INTEGER
))
4895 if (!scalar_check (offset
, 1))
4903 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4905 if (!type_check (name
, 0, BT_CHARACTER
))
4907 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4910 if (!type_check (array
, 1, BT_INTEGER
)
4911 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4914 if (!array_check (array
, 1))
4922 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4924 if (!type_check (name
, 0, BT_CHARACTER
))
4926 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4929 if (!type_check (array
, 1, BT_INTEGER
)
4930 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4933 if (!array_check (array
, 1))
4939 if (!type_check (status
, 2, BT_INTEGER
)
4940 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4943 if (!scalar_check (status
, 2))
4951 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4955 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4957 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4961 if (!coarray_check (coarray
, 0))
4966 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4967 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
4971 if (gfc_array_size (sub
, &nelems
))
4973 int corank
= gfc_get_corank (coarray
);
4975 if (mpz_cmp_ui (nelems
, corank
) != 0)
4977 gfc_error ("The number of array elements of the SUB argument to "
4978 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4979 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
4991 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
4993 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4995 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5001 if (!type_check (distance
, 0, BT_INTEGER
))
5004 if (!nonnegative_check ("DISTANCE", distance
))
5007 if (!scalar_check (distance
, 0))
5010 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5011 "NUM_IMAGES at %L", &distance
->where
))
5017 if (!type_check (failed
, 1, BT_LOGICAL
))
5020 if (!scalar_check (failed
, 1))
5023 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5024 "NUM_IMAGES at %L", &distance
->where
))
5033 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5035 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5037 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5041 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5044 if (dim
!= NULL
&& coarray
== NULL
)
5046 gfc_error ("DIM argument without COARRAY argument not allowed for "
5047 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5051 if (distance
&& (coarray
|| dim
))
5053 gfc_error ("The DISTANCE argument may not be specified together with the "
5054 "COARRAY or DIM argument in intrinsic at %L",
5059 /* Assume that we have "this_image (distance)". */
5060 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5064 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5073 if (!type_check (distance
, 2, BT_INTEGER
))
5076 if (!nonnegative_check ("DISTANCE", distance
))
5079 if (!scalar_check (distance
, 2))
5082 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5083 "THIS_IMAGE at %L", &distance
->where
))
5089 if (!coarray_check (coarray
, 0))
5094 if (!dim_check (dim
, 1, false))
5097 if (!dim_corank_check (dim
, coarray
))
5104 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5105 by gfc_simplify_transfer. Return false if we cannot do so. */
5108 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5109 size_t *source_size
, size_t *result_size
,
5110 size_t *result_length_p
)
5112 size_t result_elt_size
;
5114 if (source
->expr_type
== EXPR_FUNCTION
)
5117 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5120 /* Calculate the size of the source. */
5121 *source_size
= gfc_target_expr_size (source
);
5122 if (*source_size
== 0)
5125 /* Determine the size of the element. */
5126 result_elt_size
= gfc_element_size (mold
);
5127 if (result_elt_size
== 0)
5130 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5135 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5138 result_length
= *source_size
/ result_elt_size
;
5139 if (result_length
* result_elt_size
< *source_size
)
5143 *result_size
= result_length
* result_elt_size
;
5144 if (result_length_p
)
5145 *result_length_p
= result_length
;
5148 *result_size
= result_elt_size
;
5155 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5160 if (mold
->ts
.type
== BT_HOLLERITH
)
5162 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5163 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5169 if (!type_check (size
, 2, BT_INTEGER
))
5172 if (!scalar_check (size
, 2))
5175 if (!nonoptional_check (size
, 2))
5179 if (!warn_surprising
)
5182 /* If we can't calculate the sizes, we cannot check any more.
5183 Return true for that case. */
5185 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5186 &result_size
, NULL
))
5189 if (source_size
< result_size
)
5190 gfc_warning (0, "Intrinsic TRANSFER at %L has partly undefined result: "
5191 "source size %ld < result size %ld", &source
->where
,
5192 (long) source_size
, (long) result_size
);
5199 gfc_check_transpose (gfc_expr
*matrix
)
5201 if (!rank_check (matrix
, 0, 2))
5209 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5211 if (!array_check (array
, 0))
5214 if (!dim_check (dim
, 1, false))
5217 if (!dim_rank_check (dim
, array
, 0))
5220 if (!kind_check (kind
, 2, BT_INTEGER
))
5222 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5223 "with KIND argument at %L",
5224 gfc_current_intrinsic
, &kind
->where
))
5232 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5234 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5236 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5240 if (!coarray_check (coarray
, 0))
5245 if (!dim_check (dim
, 1, false))
5248 if (!dim_corank_check (dim
, coarray
))
5252 if (!kind_check (kind
, 2, BT_INTEGER
))
5260 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5264 if (!rank_check (vector
, 0, 1))
5267 if (!array_check (mask
, 1))
5270 if (!type_check (mask
, 1, BT_LOGICAL
))
5273 if (!same_type_check (vector
, 0, field
, 2))
5276 if (mask
->expr_type
== EXPR_ARRAY
5277 && gfc_array_size (vector
, &vector_size
))
5279 int mask_true_count
= 0;
5280 gfc_constructor
*mask_ctor
;
5281 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5284 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5286 mask_true_count
= 0;
5290 if (mask_ctor
->expr
->value
.logical
)
5293 mask_ctor
= gfc_constructor_next (mask_ctor
);
5296 if (mpz_get_si (vector_size
) < mask_true_count
)
5298 gfc_error ("%qs argument of %qs intrinsic at %L must "
5299 "provide at least as many elements as there "
5300 "are .TRUE. values in %qs (%ld/%d)",
5301 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5302 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5303 mpz_get_si (vector_size
), mask_true_count
);
5307 mpz_clear (vector_size
);
5310 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5312 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5313 "the same rank as %qs or be a scalar",
5314 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5315 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5319 if (mask
->rank
== field
->rank
)
5322 for (i
= 0; i
< field
->rank
; i
++)
5323 if (! identical_dimen_shape (mask
, i
, field
, i
))
5325 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5326 "must have identical shape.",
5327 gfc_current_intrinsic_arg
[2]->name
,
5328 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5338 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5340 if (!type_check (x
, 0, BT_CHARACTER
))
5343 if (!same_type_check (x
, 0, y
, 1))
5346 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5349 if (!kind_check (kind
, 3, BT_INTEGER
))
5351 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5352 "with KIND argument at %L",
5353 gfc_current_intrinsic
, &kind
->where
))
5361 gfc_check_trim (gfc_expr
*x
)
5363 if (!type_check (x
, 0, BT_CHARACTER
))
5366 if (!scalar_check (x
, 0))
5374 gfc_check_ttynam (gfc_expr
*unit
)
5376 if (!scalar_check (unit
, 0))
5379 if (!type_check (unit
, 0, BT_INTEGER
))
5386 /* Common check function for the half a dozen intrinsics that have a
5387 single real argument. */
5390 gfc_check_x (gfc_expr
*x
)
5392 if (!type_check (x
, 0, BT_REAL
))
5399 /************* Check functions for intrinsic subroutines *************/
5402 gfc_check_cpu_time (gfc_expr
*time
)
5404 if (!scalar_check (time
, 0))
5407 if (!type_check (time
, 0, BT_REAL
))
5410 if (!variable_check (time
, 0, false))
5418 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5419 gfc_expr
*zone
, gfc_expr
*values
)
5423 if (!type_check (date
, 0, BT_CHARACTER
))
5425 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5427 if (!scalar_check (date
, 0))
5429 if (!variable_check (date
, 0, false))
5435 if (!type_check (time
, 1, BT_CHARACTER
))
5437 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5439 if (!scalar_check (time
, 1))
5441 if (!variable_check (time
, 1, false))
5447 if (!type_check (zone
, 2, BT_CHARACTER
))
5449 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5451 if (!scalar_check (zone
, 2))
5453 if (!variable_check (zone
, 2, false))
5459 if (!type_check (values
, 3, BT_INTEGER
))
5461 if (!array_check (values
, 3))
5463 if (!rank_check (values
, 3, 1))
5465 if (!variable_check (values
, 3, false))
5474 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5475 gfc_expr
*to
, gfc_expr
*topos
)
5477 if (!type_check (from
, 0, BT_INTEGER
))
5480 if (!type_check (frompos
, 1, BT_INTEGER
))
5483 if (!type_check (len
, 2, BT_INTEGER
))
5486 if (!same_type_check (from
, 0, to
, 3))
5489 if (!variable_check (to
, 3, false))
5492 if (!type_check (topos
, 4, BT_INTEGER
))
5495 if (!nonnegative_check ("frompos", frompos
))
5498 if (!nonnegative_check ("topos", topos
))
5501 if (!nonnegative_check ("len", len
))
5504 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5507 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5515 gfc_check_random_number (gfc_expr
*harvest
)
5517 if (!type_check (harvest
, 0, BT_REAL
))
5520 if (!variable_check (harvest
, 0, false))
5528 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5530 unsigned int nargs
= 0, kiss_size
;
5531 locus
*where
= NULL
;
5532 mpz_t put_size
, get_size
;
5533 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
5535 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
5537 /* Keep the number of bytes in sync with kiss_size in
5538 libgfortran/intrinsics/random.c. */
5539 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
5543 if (size
->expr_type
!= EXPR_VARIABLE
5544 || !size
->symtree
->n
.sym
->attr
.optional
)
5547 if (!scalar_check (size
, 0))
5550 if (!type_check (size
, 0, BT_INTEGER
))
5553 if (!variable_check (size
, 0, false))
5556 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5562 if (put
->expr_type
!= EXPR_VARIABLE
5563 || !put
->symtree
->n
.sym
->attr
.optional
)
5566 where
= &put
->where
;
5569 if (!array_check (put
, 1))
5572 if (!rank_check (put
, 1, 1))
5575 if (!type_check (put
, 1, BT_INTEGER
))
5578 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5581 if (gfc_array_size (put
, &put_size
)
5582 && mpz_get_ui (put_size
) < kiss_size
)
5583 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5584 "too small (%i/%i)",
5585 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5586 where
, (int) mpz_get_ui (put_size
), kiss_size
);
5591 if (get
->expr_type
!= EXPR_VARIABLE
5592 || !get
->symtree
->n
.sym
->attr
.optional
)
5595 where
= &get
->where
;
5598 if (!array_check (get
, 2))
5601 if (!rank_check (get
, 2, 1))
5604 if (!type_check (get
, 2, BT_INTEGER
))
5607 if (!variable_check (get
, 2, false))
5610 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5613 if (gfc_array_size (get
, &get_size
)
5614 && mpz_get_ui (get_size
) < kiss_size
)
5615 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5616 "too small (%i/%i)",
5617 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5618 where
, (int) mpz_get_ui (get_size
), kiss_size
);
5621 /* RANDOM_SEED may not have more than one non-optional argument. */
5623 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5629 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5633 int num_percent
, nargs
;
5636 if (e
->expr_type
!= EXPR_CONSTANT
)
5639 len
= e
->value
.character
.length
;
5640 if (e
->value
.character
.string
[len
-1] != '\0')
5641 gfc_internal_error ("fe_runtime_error string must be null terminated");
5644 for (i
=0; i
<len
-1; i
++)
5645 if (e
->value
.character
.string
[i
] == '%')
5649 for (; a
; a
= a
->next
)
5652 if (nargs
-1 != num_percent
)
5653 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5654 nargs
, num_percent
++);
5660 gfc_check_second_sub (gfc_expr
*time
)
5662 if (!scalar_check (time
, 0))
5665 if (!type_check (time
, 0, BT_REAL
))
5668 if (!kind_value_check (time
, 0, 4))
5675 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5676 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5677 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5678 count_max are all optional arguments */
5681 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5682 gfc_expr
*count_max
)
5686 if (!scalar_check (count
, 0))
5689 if (!type_check (count
, 0, BT_INTEGER
))
5692 if (count
->ts
.kind
!= gfc_default_integer_kind
5693 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5694 "SYSTEM_CLOCK at %L has non-default kind",
5698 if (!variable_check (count
, 0, false))
5702 if (count_rate
!= NULL
)
5704 if (!scalar_check (count_rate
, 1))
5707 if (!variable_check (count_rate
, 1, false))
5710 if (count_rate
->ts
.type
== BT_REAL
)
5712 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5713 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5718 if (!type_check (count_rate
, 1, BT_INTEGER
))
5721 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5722 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5723 "SYSTEM_CLOCK at %L has non-default kind",
5724 &count_rate
->where
))
5730 if (count_max
!= NULL
)
5732 if (!scalar_check (count_max
, 2))
5735 if (!type_check (count_max
, 2, BT_INTEGER
))
5738 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5739 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5740 "SYSTEM_CLOCK at %L has non-default kind",
5744 if (!variable_check (count_max
, 2, false))
5753 gfc_check_irand (gfc_expr
*x
)
5758 if (!scalar_check (x
, 0))
5761 if (!type_check (x
, 0, BT_INTEGER
))
5764 if (!kind_value_check (x
, 0, 4))
5772 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5774 if (!scalar_check (seconds
, 0))
5776 if (!type_check (seconds
, 0, BT_INTEGER
))
5779 if (!int_or_proc_check (handler
, 1))
5781 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5787 if (!scalar_check (status
, 2))
5789 if (!type_check (status
, 2, BT_INTEGER
))
5791 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5799 gfc_check_rand (gfc_expr
*x
)
5804 if (!scalar_check (x
, 0))
5807 if (!type_check (x
, 0, BT_INTEGER
))
5810 if (!kind_value_check (x
, 0, 4))
5818 gfc_check_srand (gfc_expr
*x
)
5820 if (!scalar_check (x
, 0))
5823 if (!type_check (x
, 0, BT_INTEGER
))
5826 if (!kind_value_check (x
, 0, 4))
5834 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5836 if (!scalar_check (time
, 0))
5838 if (!type_check (time
, 0, BT_INTEGER
))
5841 if (!type_check (result
, 1, BT_CHARACTER
))
5843 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5851 gfc_check_dtime_etime (gfc_expr
*x
)
5853 if (!array_check (x
, 0))
5856 if (!rank_check (x
, 0, 1))
5859 if (!variable_check (x
, 0, false))
5862 if (!type_check (x
, 0, BT_REAL
))
5865 if (!kind_value_check (x
, 0, 4))
5873 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5875 if (!array_check (values
, 0))
5878 if (!rank_check (values
, 0, 1))
5881 if (!variable_check (values
, 0, false))
5884 if (!type_check (values
, 0, BT_REAL
))
5887 if (!kind_value_check (values
, 0, 4))
5890 if (!scalar_check (time
, 1))
5893 if (!type_check (time
, 1, BT_REAL
))
5896 if (!kind_value_check (time
, 1, 4))
5904 gfc_check_fdate_sub (gfc_expr
*date
)
5906 if (!type_check (date
, 0, BT_CHARACTER
))
5908 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5916 gfc_check_gerror (gfc_expr
*msg
)
5918 if (!type_check (msg
, 0, BT_CHARACTER
))
5920 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5928 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5930 if (!type_check (cwd
, 0, BT_CHARACTER
))
5932 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5938 if (!scalar_check (status
, 1))
5941 if (!type_check (status
, 1, BT_INTEGER
))
5949 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5951 if (!type_check (pos
, 0, BT_INTEGER
))
5954 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5956 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
5957 "not wider than the default kind (%d)",
5958 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5959 &pos
->where
, gfc_default_integer_kind
);
5963 if (!type_check (value
, 1, BT_CHARACTER
))
5965 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
5973 gfc_check_getlog (gfc_expr
*msg
)
5975 if (!type_check (msg
, 0, BT_CHARACTER
))
5977 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5985 gfc_check_exit (gfc_expr
*status
)
5990 if (!type_check (status
, 0, BT_INTEGER
))
5993 if (!scalar_check (status
, 0))
6001 gfc_check_flush (gfc_expr
*unit
)
6006 if (!type_check (unit
, 0, BT_INTEGER
))
6009 if (!scalar_check (unit
, 0))
6017 gfc_check_free (gfc_expr
*i
)
6019 if (!type_check (i
, 0, BT_INTEGER
))
6022 if (!scalar_check (i
, 0))
6030 gfc_check_hostnm (gfc_expr
*name
)
6032 if (!type_check (name
, 0, BT_CHARACTER
))
6034 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6042 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6044 if (!type_check (name
, 0, BT_CHARACTER
))
6046 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6052 if (!scalar_check (status
, 1))
6055 if (!type_check (status
, 1, BT_INTEGER
))
6063 gfc_check_itime_idate (gfc_expr
*values
)
6065 if (!array_check (values
, 0))
6068 if (!rank_check (values
, 0, 1))
6071 if (!variable_check (values
, 0, false))
6074 if (!type_check (values
, 0, BT_INTEGER
))
6077 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6085 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6087 if (!type_check (time
, 0, BT_INTEGER
))
6090 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6093 if (!scalar_check (time
, 0))
6096 if (!array_check (values
, 1))
6099 if (!rank_check (values
, 1, 1))
6102 if (!variable_check (values
, 1, false))
6105 if (!type_check (values
, 1, BT_INTEGER
))
6108 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6116 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6118 if (!scalar_check (unit
, 0))
6121 if (!type_check (unit
, 0, BT_INTEGER
))
6124 if (!type_check (name
, 1, BT_CHARACTER
))
6126 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6134 gfc_check_isatty (gfc_expr
*unit
)
6139 if (!type_check (unit
, 0, BT_INTEGER
))
6142 if (!scalar_check (unit
, 0))
6150 gfc_check_isnan (gfc_expr
*x
)
6152 if (!type_check (x
, 0, BT_REAL
))
6160 gfc_check_perror (gfc_expr
*string
)
6162 if (!type_check (string
, 0, BT_CHARACTER
))
6164 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6172 gfc_check_umask (gfc_expr
*mask
)
6174 if (!type_check (mask
, 0, BT_INTEGER
))
6177 if (!scalar_check (mask
, 0))
6185 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6187 if (!type_check (mask
, 0, BT_INTEGER
))
6190 if (!scalar_check (mask
, 0))
6196 if (!scalar_check (old
, 1))
6199 if (!type_check (old
, 1, BT_INTEGER
))
6207 gfc_check_unlink (gfc_expr
*name
)
6209 if (!type_check (name
, 0, BT_CHARACTER
))
6211 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6219 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6221 if (!type_check (name
, 0, BT_CHARACTER
))
6223 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6229 if (!scalar_check (status
, 1))
6232 if (!type_check (status
, 1, BT_INTEGER
))
6240 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6242 if (!scalar_check (number
, 0))
6244 if (!type_check (number
, 0, BT_INTEGER
))
6247 if (!int_or_proc_check (handler
, 1))
6249 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6257 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6259 if (!scalar_check (number
, 0))
6261 if (!type_check (number
, 0, BT_INTEGER
))
6264 if (!int_or_proc_check (handler
, 1))
6266 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6272 if (!type_check (status
, 2, BT_INTEGER
))
6274 if (!scalar_check (status
, 2))
6282 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6284 if (!type_check (cmd
, 0, BT_CHARACTER
))
6286 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6289 if (!scalar_check (status
, 1))
6292 if (!type_check (status
, 1, BT_INTEGER
))
6295 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6302 /* This is used for the GNU intrinsics AND, OR and XOR. */
6304 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6306 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6308 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6309 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6310 gfc_current_intrinsic
, &i
->where
);
6314 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6316 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6317 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6318 gfc_current_intrinsic
, &j
->where
);
6322 if (i
->ts
.type
!= j
->ts
.type
)
6324 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6325 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6326 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6331 if (!scalar_check (i
, 0))
6334 if (!scalar_check (j
, 1))
6342 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6345 if (a
->expr_type
== EXPR_NULL
)
6347 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6348 "argument to STORAGE_SIZE, because it returns a "
6349 "disassociated pointer", &a
->where
);
6353 if (a
->ts
.type
== BT_ASSUMED
)
6355 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6356 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6361 if (a
->ts
.type
== BT_PROCEDURE
)
6363 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6364 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6365 gfc_current_intrinsic
, &a
->where
);
6372 if (!type_check (kind
, 1, BT_INTEGER
))
6375 if (!scalar_check (kind
, 1))
6378 if (kind
->expr_type
!= EXPR_CONSTANT
)
6380 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6381 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,