2 Copyright (C) 2002-2013 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 ("'%s' argument of '%s' 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 ("'%s' argument of '%s' 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 if (gfc_numeric_ts (&e
->ts
))
78 /* If the expression has not got a type, check if its namespace can
79 offer a default type. */
80 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
81 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
82 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
83 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
85 e
->ts
= e
->symtree
->n
.sym
->ts
;
89 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
90 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
97 /* Check that an expression is integer or real. */
100 int_or_real_check (gfc_expr
*e
, int n
)
102 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
105 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
106 gfc_current_intrinsic
, &e
->where
);
114 /* Check that an expression is real or complex. */
117 real_or_complex_check (gfc_expr
*e
, int n
)
119 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
121 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
122 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
123 gfc_current_intrinsic
, &e
->where
);
131 /* Check that an expression is INTEGER or PROCEDURE. */
134 int_or_proc_check (gfc_expr
*e
, int n
)
136 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
138 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
139 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
140 gfc_current_intrinsic
, &e
->where
);
148 /* Check that the expression is an optional constant integer
149 and that it specifies a valid kind for that type. */
152 kind_check (gfc_expr
*k
, int n
, bt type
)
159 if (!type_check (k
, n
, BT_INTEGER
))
162 if (!scalar_check (k
, n
))
165 if (!gfc_check_init_expr (k
))
167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
168 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
173 if (gfc_extract_int (k
, &kind
) != NULL
174 || gfc_validate_kind (type
, kind
, true) < 0)
176 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
185 /* Make sure the expression is a double precision real. */
188 double_check (gfc_expr
*d
, int n
)
190 if (!type_check (d
, n
, BT_REAL
))
193 if (d
->ts
.kind
!= gfc_default_double_kind
)
195 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
196 "precision", gfc_current_intrinsic_arg
[n
]->name
,
197 gfc_current_intrinsic
, &d
->where
);
206 coarray_check (gfc_expr
*e
, int n
)
208 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
209 && CLASS_DATA (e
)->attr
.codimension
210 && CLASS_DATA (e
)->as
->corank
)
212 gfc_add_class_array_ref (e
);
216 if (!gfc_is_coarray (e
))
218 gfc_error ("Expected coarray variable as '%s' argument to the %s "
219 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
220 gfc_current_intrinsic
, &e
->where
);
228 /* Make sure the expression is a logical array. */
231 logical_array_check (gfc_expr
*array
, int n
)
233 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
235 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
236 "array", gfc_current_intrinsic_arg
[n
]->name
,
237 gfc_current_intrinsic
, &array
->where
);
245 /* Make sure an expression is an array. */
248 array_check (gfc_expr
*e
, int n
)
250 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
251 && CLASS_DATA (e
)->attr
.dimension
252 && CLASS_DATA (e
)->as
->rank
)
254 gfc_add_class_array_ref (e
);
258 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
261 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
262 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
269 /* If expr is a constant, then check to ensure that it is greater than
273 nonnegative_check (const char *arg
, gfc_expr
*expr
)
277 if (expr
->expr_type
== EXPR_CONSTANT
)
279 gfc_extract_int (expr
, &i
);
282 gfc_error ("'%s' at %L must be nonnegative", arg
, &expr
->where
);
291 /* If expr2 is constant, then check that the value is less than
292 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
295 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
296 gfc_expr
*expr2
, bool or_equal
)
300 if (expr2
->expr_type
== EXPR_CONSTANT
)
302 gfc_extract_int (expr2
, &i2
);
303 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
305 /* For ISHFT[C], check that |shift| <= bit_size(i). */
311 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
313 gfc_error ("The absolute value of SHIFT at %L must be less "
314 "than or equal to BIT_SIZE('%s')",
315 &expr2
->where
, arg1
);
322 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
324 gfc_error ("'%s' at %L must be less than "
325 "or equal to BIT_SIZE('%s')",
326 arg2
, &expr2
->where
, arg1
);
332 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
334 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
335 arg2
, &expr2
->where
, arg1
);
345 /* If expr is constant, then check that the value is less than or equal
346 to the bit_size of the kind k. */
349 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
353 if (expr
->expr_type
!= EXPR_CONSTANT
)
356 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
357 gfc_extract_int (expr
, &val
);
359 if (val
> gfc_integer_kinds
[i
].bit_size
)
361 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
362 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
370 /* If expr2 and expr3 are constants, then check that the value is less than
371 or equal to bit_size(expr1). */
374 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
375 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
379 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
381 gfc_extract_int (expr2
, &i2
);
382 gfc_extract_int (expr3
, &i3
);
384 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
385 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
387 gfc_error ("'%s + %s' at %L must be less than or equal "
389 arg2
, arg3
, &expr2
->where
, arg1
);
397 /* Make sure two expressions have the same type. */
400 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
402 if (gfc_compare_types (&e
->ts
, &f
->ts
))
405 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
406 "and kind as '%s'", gfc_current_intrinsic_arg
[m
]->name
,
407 gfc_current_intrinsic
, &f
->where
,
408 gfc_current_intrinsic_arg
[n
]->name
);
414 /* Make sure that an expression has a certain (nonzero) rank. */
417 rank_check (gfc_expr
*e
, int n
, int rank
)
422 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
423 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
430 /* Make sure a variable expression is not an optional dummy argument. */
433 nonoptional_check (gfc_expr
*e
, int n
)
435 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
437 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
438 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
442 /* TODO: Recursive check on nonoptional variables? */
448 /* Check for ALLOCATABLE attribute. */
451 allocatable_check (gfc_expr
*e
, int n
)
453 symbol_attribute attr
;
455 attr
= gfc_variable_attr (e
, NULL
);
456 if (!attr
.allocatable
|| attr
.associate_var
)
458 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
459 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
468 /* Check that an expression has a particular kind. */
471 kind_value_check (gfc_expr
*e
, int n
, int k
)
476 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
477 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
484 /* Make sure an expression is a variable. */
487 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
489 if (e
->expr_type
== EXPR_VARIABLE
490 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
491 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
492 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
495 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
496 && CLASS_DATA (e
->symtree
->n
.sym
)
497 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
498 : e
->symtree
->n
.sym
->attr
.pointer
;
500 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
502 if (pointer
&& ref
->type
== REF_COMPONENT
)
504 if (ref
->type
== REF_COMPONENT
505 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
506 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
507 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
508 && ref
->u
.c
.component
->attr
.pointer
)))
514 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
515 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
516 gfc_current_intrinsic
, &e
->where
);
521 if (e
->expr_type
== EXPR_VARIABLE
522 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
523 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
526 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
527 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
530 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
531 if (ns
->proc_name
== e
->symtree
->n
.sym
)
535 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
536 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
542 /* Check the common DIM parameter for correctness. */
545 dim_check (gfc_expr
*dim
, int n
, bool optional
)
550 if (!type_check (dim
, n
, BT_INTEGER
))
553 if (!scalar_check (dim
, n
))
556 if (!optional
&& !nonoptional_check (dim
, n
))
563 /* If a coarray DIM parameter is a constant, make sure that it is greater than
564 zero and less than or equal to the corank of the given array. */
567 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
571 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
573 if (dim
->expr_type
!= EXPR_CONSTANT
)
576 if (array
->ts
.type
== BT_CLASS
)
579 corank
= gfc_get_corank (array
);
581 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
582 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
584 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
585 "codimension index", gfc_current_intrinsic
, &dim
->where
);
594 /* If a DIM parameter is a constant, make sure that it is greater than
595 zero and less than or equal to the rank of the given array. If
596 allow_assumed is zero then dim must be less than the rank of the array
597 for assumed size arrays. */
600 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
608 if (dim
->expr_type
!= EXPR_CONSTANT
)
611 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
612 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
613 rank
= array
->rank
+ 1;
617 /* Assumed-rank array. */
619 rank
= GFC_MAX_DIMENSIONS
;
621 if (array
->expr_type
== EXPR_VARIABLE
)
623 ar
= gfc_find_array_ref (array
);
624 if (ar
->as
->type
== AS_ASSUMED_SIZE
626 && ar
->type
!= AR_ELEMENT
627 && ar
->type
!= AR_SECTION
)
631 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
632 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
634 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
635 "dimension index", gfc_current_intrinsic
, &dim
->where
);
644 /* Compare the size of a along dimension ai with the size of b along
645 dimension bi, returning 0 if they are known not to be identical,
646 and 1 if they are identical, or if this cannot be determined. */
649 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
651 mpz_t a_size
, b_size
;
654 gcc_assert (a
->rank
> ai
);
655 gcc_assert (b
->rank
> bi
);
659 if (gfc_array_dimen_size (a
, ai
, &a_size
))
661 if (gfc_array_dimen_size (b
, bi
, &b_size
))
663 if (mpz_cmp (a_size
, b_size
) != 0)
673 /* Calculate the length of a character variable, including substrings.
674 Strip away parentheses if necessary. Return -1 if no length could
678 gfc_var_strlen (const gfc_expr
*a
)
682 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
685 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
695 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
696 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
698 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
700 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
701 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
703 else if (ra
->u
.ss
.start
704 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
710 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
711 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
712 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
713 else if (a
->expr_type
== EXPR_CONSTANT
714 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
715 return a
->value
.character
.length
;
721 /* Check whether two character expressions have the same length;
722 returns true if they have or if the length cannot be determined,
723 otherwise return false and raise a gfc_error. */
726 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
730 len_a
= gfc_var_strlen(a
);
731 len_b
= gfc_var_strlen(b
);
733 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
737 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
738 len_a
, len_b
, name
, &a
->where
);
744 /***** Check functions *****/
746 /* Check subroutine suitable for intrinsics taking a real argument and
747 a kind argument for the result. */
750 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
752 if (!type_check (a
, 0, BT_REAL
))
754 if (!kind_check (kind
, 1, type
))
761 /* Check subroutine suitable for ceiling, floor and nint. */
764 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
766 return check_a_kind (a
, kind
, BT_INTEGER
);
770 /* Check subroutine suitable for aint, anint. */
773 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
775 return check_a_kind (a
, kind
, BT_REAL
);
780 gfc_check_abs (gfc_expr
*a
)
782 if (!numeric_check (a
, 0))
790 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
792 if (!type_check (a
, 0, BT_INTEGER
))
794 if (!kind_check (kind
, 1, BT_CHARACTER
))
802 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
804 if (!type_check (name
, 0, BT_CHARACTER
)
805 || !scalar_check (name
, 0))
807 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
810 if (!type_check (mode
, 1, BT_CHARACTER
)
811 || !scalar_check (mode
, 1))
813 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
821 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
823 if (!logical_array_check (mask
, 0))
826 if (!dim_check (dim
, 1, false))
829 if (!dim_rank_check (dim
, mask
, 0))
837 gfc_check_allocated (gfc_expr
*array
)
839 if (!variable_check (array
, 0, false))
841 if (!allocatable_check (array
, 0))
848 /* Common check function where the first argument must be real or
849 integer and the second argument must be the same as the first. */
852 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
854 if (!int_or_real_check (a
, 0))
857 if (a
->ts
.type
!= p
->ts
.type
)
859 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
860 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
861 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
866 if (a
->ts
.kind
!= p
->ts
.kind
)
868 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
878 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
880 if (!double_check (x
, 0) || !double_check (y
, 1))
888 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
890 symbol_attribute attr1
, attr2
;
895 where
= &pointer
->where
;
897 if (pointer
->expr_type
== EXPR_NULL
)
900 attr1
= gfc_expr_attr (pointer
);
902 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
904 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
905 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
911 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
913 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
914 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
915 gfc_current_intrinsic
, &pointer
->where
);
919 /* Target argument is optional. */
923 where
= &target
->where
;
924 if (target
->expr_type
== EXPR_NULL
)
927 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
928 attr2
= gfc_expr_attr (target
);
931 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
932 "or target VARIABLE or FUNCTION",
933 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
938 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
940 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
941 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
942 gfc_current_intrinsic
, &target
->where
);
947 if (attr1
.pointer
&& gfc_is_coindexed (target
))
949 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
950 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
951 gfc_current_intrinsic
, &target
->where
);
956 if (!same_type_check (pointer
, 0, target
, 1))
958 if (!rank_check (target
, 0, pointer
->rank
))
960 if (target
->rank
> 0)
962 for (i
= 0; i
< target
->rank
; i
++)
963 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
965 gfc_error ("Array section with a vector subscript at %L shall not "
966 "be the target of a pointer",
976 gfc_error ("NULL pointer at %L is not permitted as actual argument "
977 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
984 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
986 /* gfc_notify_std would be a waste of time as the return value
987 is seemingly used only for the generic resolution. The error
988 will be: Too many arguments. */
989 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
992 return gfc_check_atan2 (y
, x
);
997 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
999 if (!type_check (y
, 0, BT_REAL
))
1001 if (!same_type_check (y
, 0, x
, 1))
1009 gfc_check_atomic (gfc_expr
*atom
, gfc_expr
*value
)
1011 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1012 && !(atom
->ts
.type
== BT_LOGICAL
1013 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1015 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1016 "integer of ATOMIC_INT_KIND or a logical of "
1017 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1021 if (!gfc_expr_attr (atom
).codimension
)
1023 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1024 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1028 if (atom
->ts
.type
!= value
->ts
.type
)
1030 gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
1031 "have the same type at %L", gfc_current_intrinsic
,
1041 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
)
1043 if (!scalar_check (atom
, 0) || !scalar_check (value
, 1))
1046 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1048 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1049 "definable", gfc_current_intrinsic
, &atom
->where
);
1053 return gfc_check_atomic (atom
, value
);
1058 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
)
1060 if (!scalar_check (value
, 0) || !scalar_check (atom
, 1))
1063 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1065 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1066 "definable", gfc_current_intrinsic
, &value
->where
);
1070 return gfc_check_atomic (atom
, value
);
1074 /* BESJN and BESYN functions. */
1077 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1079 if (!type_check (n
, 0, BT_INTEGER
))
1081 if (n
->expr_type
== EXPR_CONSTANT
)
1084 gfc_extract_int (n
, &i
);
1085 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1086 "N at %L", &n
->where
))
1090 if (!type_check (x
, 1, BT_REAL
))
1097 /* Transformational version of the Bessel JN and YN functions. */
1100 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1102 if (!type_check (n1
, 0, BT_INTEGER
))
1104 if (!scalar_check (n1
, 0))
1106 if (!nonnegative_check ("N1", n1
))
1109 if (!type_check (n2
, 1, BT_INTEGER
))
1111 if (!scalar_check (n2
, 1))
1113 if (!nonnegative_check ("N2", n2
))
1116 if (!type_check (x
, 2, BT_REAL
))
1118 if (!scalar_check (x
, 2))
1126 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1128 if (!type_check (i
, 0, BT_INTEGER
))
1131 if (!type_check (j
, 1, BT_INTEGER
))
1139 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1141 if (!type_check (i
, 0, BT_INTEGER
))
1144 if (!type_check (pos
, 1, BT_INTEGER
))
1147 if (!nonnegative_check ("pos", pos
))
1150 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1158 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1160 if (!type_check (i
, 0, BT_INTEGER
))
1162 if (!kind_check (kind
, 1, BT_CHARACTER
))
1170 gfc_check_chdir (gfc_expr
*dir
)
1172 if (!type_check (dir
, 0, BT_CHARACTER
))
1174 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1182 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1184 if (!type_check (dir
, 0, BT_CHARACTER
))
1186 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1192 if (!type_check (status
, 1, BT_INTEGER
))
1194 if (!scalar_check (status
, 1))
1202 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1204 if (!type_check (name
, 0, BT_CHARACTER
))
1206 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1209 if (!type_check (mode
, 1, BT_CHARACTER
))
1211 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1219 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1221 if (!type_check (name
, 0, BT_CHARACTER
))
1223 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1226 if (!type_check (mode
, 1, BT_CHARACTER
))
1228 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1234 if (!type_check (status
, 2, BT_INTEGER
))
1237 if (!scalar_check (status
, 2))
1245 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1247 if (!numeric_check (x
, 0))
1252 if (!numeric_check (y
, 1))
1255 if (x
->ts
.type
== BT_COMPLEX
)
1257 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1258 "present if 'x' is COMPLEX",
1259 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1264 if (y
->ts
.type
== BT_COMPLEX
)
1266 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1267 "of either REAL or INTEGER",
1268 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1275 if (!kind_check (kind
, 2, BT_COMPLEX
))
1278 if (!kind
&& gfc_option
.gfc_warn_conversion
1279 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1280 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1281 "might loose precision, consider using the KIND argument",
1282 gfc_typename (&x
->ts
), gfc_default_real_kind
, &x
->where
);
1283 else if (y
&& !kind
&& gfc_option
.gfc_warn_conversion
1284 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1285 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1286 "might loose precision, consider using the KIND argument",
1287 gfc_typename (&y
->ts
), gfc_default_real_kind
, &y
->where
);
1294 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1296 if (!int_or_real_check (x
, 0))
1298 if (!scalar_check (x
, 0))
1301 if (!int_or_real_check (y
, 1))
1303 if (!scalar_check (y
, 1))
1311 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1313 if (!logical_array_check (mask
, 0))
1315 if (!dim_check (dim
, 1, false))
1317 if (!dim_rank_check (dim
, mask
, 0))
1319 if (!kind_check (kind
, 2, BT_INTEGER
))
1321 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1322 "with KIND argument at %L",
1323 gfc_current_intrinsic
, &kind
->where
))
1331 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1333 if (!array_check (array
, 0))
1336 if (!type_check (shift
, 1, BT_INTEGER
))
1339 if (!dim_check (dim
, 2, true))
1342 if (!dim_rank_check (dim
, array
, false))
1345 if (array
->rank
== 1 || shift
->rank
== 0)
1347 if (!scalar_check (shift
, 1))
1350 else if (shift
->rank
== array
->rank
- 1)
1355 else if (dim
->expr_type
== EXPR_CONSTANT
)
1356 gfc_extract_int (dim
, &d
);
1363 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1366 if (!identical_dimen_shape (array
, i
, shift
, j
))
1368 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1369 "invalid shape in dimension %d (%ld/%ld)",
1370 gfc_current_intrinsic_arg
[1]->name
,
1371 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1372 mpz_get_si (array
->shape
[i
]),
1373 mpz_get_si (shift
->shape
[j
]));
1383 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1384 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1385 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1394 gfc_check_ctime (gfc_expr
*time
)
1396 if (!scalar_check (time
, 0))
1399 if (!type_check (time
, 0, BT_INTEGER
))
1406 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1408 if (!double_check (y
, 0) || !double_check (x
, 1))
1415 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1417 if (!numeric_check (x
, 0))
1422 if (!numeric_check (y
, 1))
1425 if (x
->ts
.type
== BT_COMPLEX
)
1427 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1428 "present if 'x' is COMPLEX",
1429 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1434 if (y
->ts
.type
== BT_COMPLEX
)
1436 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1437 "of either REAL or INTEGER",
1438 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1449 gfc_check_dble (gfc_expr
*x
)
1451 if (!numeric_check (x
, 0))
1459 gfc_check_digits (gfc_expr
*x
)
1461 if (!int_or_real_check (x
, 0))
1469 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1471 switch (vector_a
->ts
.type
)
1474 if (!type_check (vector_b
, 1, BT_LOGICAL
))
1481 if (!numeric_check (vector_b
, 1))
1486 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1487 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1488 gfc_current_intrinsic
, &vector_a
->where
);
1492 if (!rank_check (vector_a
, 0, 1))
1495 if (!rank_check (vector_b
, 1, 1))
1498 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1500 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1501 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0]->name
,
1502 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1511 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1513 if (!type_check (x
, 0, BT_REAL
)
1514 || !type_check (y
, 1, BT_REAL
))
1517 if (x
->ts
.kind
!= gfc_default_real_kind
)
1519 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1520 "real", gfc_current_intrinsic_arg
[0]->name
,
1521 gfc_current_intrinsic
, &x
->where
);
1525 if (y
->ts
.kind
!= gfc_default_real_kind
)
1527 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1528 "real", gfc_current_intrinsic_arg
[1]->name
,
1529 gfc_current_intrinsic
, &y
->where
);
1538 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1540 if (!type_check (i
, 0, BT_INTEGER
))
1543 if (!type_check (j
, 1, BT_INTEGER
))
1546 if (i
->is_boz
&& j
->is_boz
)
1548 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1549 "constants", &i
->where
, &j
->where
);
1553 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
1556 if (!type_check (shift
, 2, BT_INTEGER
))
1559 if (!nonnegative_check ("SHIFT", shift
))
1564 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
1566 i
->ts
.kind
= j
->ts
.kind
;
1570 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
1572 j
->ts
.kind
= i
->ts
.kind
;
1580 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1583 if (!array_check (array
, 0))
1586 if (!type_check (shift
, 1, BT_INTEGER
))
1589 if (!dim_check (dim
, 3, true))
1592 if (!dim_rank_check (dim
, array
, false))
1595 if (array
->rank
== 1 || shift
->rank
== 0)
1597 if (!scalar_check (shift
, 1))
1600 else if (shift
->rank
== array
->rank
- 1)
1605 else if (dim
->expr_type
== EXPR_CONSTANT
)
1606 gfc_extract_int (dim
, &d
);
1613 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1616 if (!identical_dimen_shape (array
, i
, shift
, j
))
1618 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1619 "invalid shape in dimension %d (%ld/%ld)",
1620 gfc_current_intrinsic_arg
[1]->name
,
1621 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1622 mpz_get_si (array
->shape
[i
]),
1623 mpz_get_si (shift
->shape
[j
]));
1633 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1634 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1635 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1639 if (boundary
!= NULL
)
1641 if (!same_type_check (array
, 0, boundary
, 2))
1644 if (array
->rank
== 1 || boundary
->rank
== 0)
1646 if (!scalar_check (boundary
, 2))
1649 else if (boundary
->rank
== array
->rank
- 1)
1651 if (!gfc_check_conformance (shift
, boundary
,
1652 "arguments '%s' and '%s' for "
1654 gfc_current_intrinsic_arg
[1]->name
,
1655 gfc_current_intrinsic_arg
[2]->name
,
1656 gfc_current_intrinsic
))
1661 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1662 "rank %d or be a scalar",
1663 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1664 &shift
->where
, array
->rank
- 1);
1673 gfc_check_float (gfc_expr
*a
)
1675 if (!type_check (a
, 0, BT_INTEGER
))
1678 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
1679 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
1680 "kind argument to %s intrinsic at %L",
1681 gfc_current_intrinsic
, &a
->where
))
1687 /* A single complex argument. */
1690 gfc_check_fn_c (gfc_expr
*a
)
1692 if (!type_check (a
, 0, BT_COMPLEX
))
1698 /* A single real argument. */
1701 gfc_check_fn_r (gfc_expr
*a
)
1703 if (!type_check (a
, 0, BT_REAL
))
1709 /* A single double argument. */
1712 gfc_check_fn_d (gfc_expr
*a
)
1714 if (!double_check (a
, 0))
1720 /* A single real or complex argument. */
1723 gfc_check_fn_rc (gfc_expr
*a
)
1725 if (!real_or_complex_check (a
, 0))
1733 gfc_check_fn_rc2008 (gfc_expr
*a
)
1735 if (!real_or_complex_check (a
, 0))
1738 if (a
->ts
.type
== BT_COMPLEX
1739 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument '%s' "
1740 "argument of '%s' intrinsic at %L",
1741 gfc_current_intrinsic_arg
[0]->name
,
1742 gfc_current_intrinsic
, &a
->where
))
1750 gfc_check_fnum (gfc_expr
*unit
)
1752 if (!type_check (unit
, 0, BT_INTEGER
))
1755 if (!scalar_check (unit
, 0))
1763 gfc_check_huge (gfc_expr
*x
)
1765 if (!int_or_real_check (x
, 0))
1773 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
1775 if (!type_check (x
, 0, BT_REAL
))
1777 if (!same_type_check (x
, 0, y
, 1))
1784 /* Check that the single argument is an integer. */
1787 gfc_check_i (gfc_expr
*i
)
1789 if (!type_check (i
, 0, BT_INTEGER
))
1797 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1799 if (!type_check (i
, 0, BT_INTEGER
))
1802 if (!type_check (j
, 1, BT_INTEGER
))
1805 if (i
->ts
.kind
!= j
->ts
.kind
)
1807 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1817 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1819 if (!type_check (i
, 0, BT_INTEGER
))
1822 if (!type_check (pos
, 1, BT_INTEGER
))
1825 if (!type_check (len
, 2, BT_INTEGER
))
1828 if (!nonnegative_check ("pos", pos
))
1831 if (!nonnegative_check ("len", len
))
1834 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
1842 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1846 if (!type_check (c
, 0, BT_CHARACTER
))
1849 if (!kind_check (kind
, 1, BT_INTEGER
))
1852 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1853 "with KIND argument at %L",
1854 gfc_current_intrinsic
, &kind
->where
))
1857 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1863 /* Substring references don't have the charlength set. */
1865 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1868 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1872 /* Check that the argument is length one. Non-constant lengths
1873 can't be checked here, so assume they are ok. */
1874 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
1876 /* If we already have a length for this expression then use it. */
1877 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1879 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1886 start
= ref
->u
.ss
.start
;
1887 end
= ref
->u
.ss
.end
;
1890 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1891 || start
->expr_type
!= EXPR_CONSTANT
)
1894 i
= mpz_get_si (end
->value
.integer
) + 1
1895 - mpz_get_si (start
->value
.integer
);
1903 gfc_error ("Argument of %s at %L must be of length one",
1904 gfc_current_intrinsic
, &c
->where
);
1913 gfc_check_idnint (gfc_expr
*a
)
1915 if (!double_check (a
, 0))
1923 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
1925 if (!type_check (i
, 0, BT_INTEGER
))
1928 if (!type_check (j
, 1, BT_INTEGER
))
1931 if (i
->ts
.kind
!= j
->ts
.kind
)
1933 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1943 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
1946 if (!type_check (string
, 0, BT_CHARACTER
)
1947 || !type_check (substring
, 1, BT_CHARACTER
))
1950 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
1953 if (!kind_check (kind
, 3, BT_INTEGER
))
1955 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1956 "with KIND argument at %L",
1957 gfc_current_intrinsic
, &kind
->where
))
1960 if (string
->ts
.kind
!= substring
->ts
.kind
)
1962 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1963 "kind as '%s'", gfc_current_intrinsic_arg
[1]->name
,
1964 gfc_current_intrinsic
, &substring
->where
,
1965 gfc_current_intrinsic_arg
[0]->name
);
1974 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
1976 if (!numeric_check (x
, 0))
1979 if (!kind_check (kind
, 1, BT_INTEGER
))
1987 gfc_check_intconv (gfc_expr
*x
)
1989 if (!numeric_check (x
, 0))
1997 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
1999 if (!type_check (i
, 0, BT_INTEGER
))
2002 if (!type_check (j
, 1, BT_INTEGER
))
2005 if (i
->ts
.kind
!= j
->ts
.kind
)
2007 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2017 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2019 if (!type_check (i
, 0, BT_INTEGER
)
2020 || !type_check (shift
, 1, BT_INTEGER
))
2023 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2031 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2033 if (!type_check (i
, 0, BT_INTEGER
)
2034 || !type_check (shift
, 1, BT_INTEGER
))
2041 if (!type_check (size
, 2, BT_INTEGER
))
2044 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2047 if (size
->expr_type
== EXPR_CONSTANT
)
2049 gfc_extract_int (size
, &i3
);
2052 gfc_error ("SIZE at %L must be positive", &size
->where
);
2056 if (shift
->expr_type
== EXPR_CONSTANT
)
2058 gfc_extract_int (shift
, &i2
);
2064 gfc_error ("The absolute value of SHIFT at %L must be less "
2065 "than or equal to SIZE at %L", &shift
->where
,
2072 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2080 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2082 if (!type_check (pid
, 0, BT_INTEGER
))
2085 if (!type_check (sig
, 1, BT_INTEGER
))
2093 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2095 if (!type_check (pid
, 0, BT_INTEGER
))
2098 if (!scalar_check (pid
, 0))
2101 if (!type_check (sig
, 1, BT_INTEGER
))
2104 if (!scalar_check (sig
, 1))
2110 if (!type_check (status
, 2, BT_INTEGER
))
2113 if (!scalar_check (status
, 2))
2121 gfc_check_kind (gfc_expr
*x
)
2123 if (x
->ts
.type
== BT_DERIVED
)
2125 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2126 "non-derived type", gfc_current_intrinsic_arg
[0]->name
,
2127 gfc_current_intrinsic
, &x
->where
);
2136 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2138 if (!array_check (array
, 0))
2141 if (!dim_check (dim
, 1, false))
2144 if (!dim_rank_check (dim
, array
, 1))
2147 if (!kind_check (kind
, 2, BT_INTEGER
))
2149 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2150 "with KIND argument at %L",
2151 gfc_current_intrinsic
, &kind
->where
))
2159 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2161 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2163 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2167 if (!coarray_check (coarray
, 0))
2172 if (!dim_check (dim
, 1, false))
2175 if (!dim_corank_check (dim
, coarray
))
2179 if (!kind_check (kind
, 2, BT_INTEGER
))
2187 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2189 if (!type_check (s
, 0, BT_CHARACTER
))
2192 if (!kind_check (kind
, 1, BT_INTEGER
))
2194 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2195 "with KIND argument at %L",
2196 gfc_current_intrinsic
, &kind
->where
))
2204 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2206 if (!type_check (a
, 0, BT_CHARACTER
))
2208 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2211 if (!type_check (b
, 1, BT_CHARACTER
))
2213 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2221 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2223 if (!type_check (path1
, 0, BT_CHARACTER
))
2225 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2228 if (!type_check (path2
, 1, BT_CHARACTER
))
2230 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2238 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2240 if (!type_check (path1
, 0, BT_CHARACTER
))
2242 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2245 if (!type_check (path2
, 1, BT_CHARACTER
))
2247 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2253 if (!type_check (status
, 2, BT_INTEGER
))
2256 if (!scalar_check (status
, 2))
2264 gfc_check_loc (gfc_expr
*expr
)
2266 return variable_check (expr
, 0, true);
2271 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2273 if (!type_check (path1
, 0, BT_CHARACTER
))
2275 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2278 if (!type_check (path2
, 1, BT_CHARACTER
))
2280 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2288 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2290 if (!type_check (path1
, 0, BT_CHARACTER
))
2292 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2295 if (!type_check (path2
, 1, BT_CHARACTER
))
2297 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2303 if (!type_check (status
, 2, BT_INTEGER
))
2306 if (!scalar_check (status
, 2))
2314 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2316 if (!type_check (a
, 0, BT_LOGICAL
))
2318 if (!kind_check (kind
, 1, BT_LOGICAL
))
2325 /* Min/max family. */
2328 min_max_args (gfc_actual_arglist
*args
)
2330 gfc_actual_arglist
*arg
;
2331 int i
, j
, nargs
, *nlabels
, nlabelless
;
2332 bool a1
= false, a2
= false;
2334 if (args
== NULL
|| args
->next
== NULL
)
2336 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2337 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2344 if (!args
->next
->name
)
2348 for (arg
= args
; arg
; arg
= arg
->next
)
2355 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2357 nlabels
= XALLOCAVEC (int, nargs
);
2358 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2364 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2366 n
= strtol (&arg
->name
[1], &endp
, 10);
2367 if (endp
[0] != '\0')
2371 if (n
<= nlabelless
)
2384 gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
2385 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2386 gfc_current_intrinsic_where
);
2390 /* Check for duplicates. */
2391 for (i
= 0; i
< nargs
; i
++)
2392 for (j
= i
+ 1; j
< nargs
; j
++)
2393 if (nlabels
[i
] == nlabels
[j
])
2399 gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg
->name
,
2400 &arg
->expr
->where
, gfc_current_intrinsic
);
2404 gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg
->name
,
2405 &arg
->expr
->where
, gfc_current_intrinsic
);
2411 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2413 gfc_actual_arglist
*arg
, *tmp
;
2417 if (!min_max_args (arglist
))
2420 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2423 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2425 if (x
->ts
.type
== type
)
2427 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
2428 "kinds at %L", &x
->where
))
2433 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2434 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2435 gfc_basic_typename (type
), kind
);
2440 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2441 if (!gfc_check_conformance (tmp
->expr
, x
,
2442 "arguments 'a%d' and 'a%d' for "
2443 "intrinsic '%s'", m
, n
,
2444 gfc_current_intrinsic
))
2453 gfc_check_min_max (gfc_actual_arglist
*arg
)
2457 if (!min_max_args (arg
))
2462 if (x
->ts
.type
== BT_CHARACTER
)
2464 if (!gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2465 "with CHARACTER argument at %L",
2466 gfc_current_intrinsic
, &x
->where
))
2469 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2471 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2472 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2476 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2481 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2483 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2488 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2490 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2495 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2497 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2501 /* End of min/max family. */
2504 gfc_check_malloc (gfc_expr
*size
)
2506 if (!type_check (size
, 0, BT_INTEGER
))
2509 if (!scalar_check (size
, 0))
2517 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2519 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2521 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2522 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2523 gfc_current_intrinsic
, &matrix_a
->where
);
2527 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2529 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2530 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2531 gfc_current_intrinsic
, &matrix_b
->where
);
2535 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2536 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2538 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2539 gfc_current_intrinsic
, &matrix_a
->where
,
2540 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2544 switch (matrix_a
->rank
)
2547 if (!rank_check (matrix_b
, 1, 2))
2549 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2550 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2552 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2553 "and '%s' at %L for intrinsic matmul",
2554 gfc_current_intrinsic_arg
[0]->name
,
2555 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2561 if (matrix_b
->rank
!= 2)
2563 if (!rank_check (matrix_b
, 1, 1))
2566 /* matrix_b has rank 1 or 2 here. Common check for the cases
2567 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2568 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2569 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2571 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2572 "dimension 1 for argument '%s' at %L for intrinsic "
2573 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2574 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2580 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2581 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
2582 gfc_current_intrinsic
, &matrix_a
->where
);
2590 /* Whoever came up with this interface was probably on something.
2591 The possibilities for the occupation of the second and third
2598 NULL MASK minloc(array, mask=m)
2601 I.e. in the case of minloc(array,mask), mask will be in the second
2602 position of the argument list and we'll have to fix that up. */
2605 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
2607 gfc_expr
*a
, *m
, *d
;
2610 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
2614 m
= ap
->next
->next
->expr
;
2616 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2617 && ap
->next
->name
== NULL
)
2621 ap
->next
->expr
= NULL
;
2622 ap
->next
->next
->expr
= m
;
2625 if (!dim_check (d
, 1, false))
2628 if (!dim_rank_check (d
, a
, 0))
2631 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
2635 && !gfc_check_conformance (a
, m
,
2636 "arguments '%s' and '%s' for intrinsic %s",
2637 gfc_current_intrinsic_arg
[0]->name
,
2638 gfc_current_intrinsic_arg
[2]->name
,
2639 gfc_current_intrinsic
))
2646 /* Similar to minloc/maxloc, the argument list might need to be
2647 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2648 difference is that MINLOC/MAXLOC take an additional KIND argument.
2649 The possibilities are:
2655 NULL MASK minval(array, mask=m)
2658 I.e. in the case of minval(array,mask), mask will be in the second
2659 position of the argument list and we'll have to fix that up. */
2662 check_reduction (gfc_actual_arglist
*ap
)
2664 gfc_expr
*a
, *m
, *d
;
2668 m
= ap
->next
->next
->expr
;
2670 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2671 && ap
->next
->name
== NULL
)
2675 ap
->next
->expr
= NULL
;
2676 ap
->next
->next
->expr
= m
;
2679 if (!dim_check (d
, 1, false))
2682 if (!dim_rank_check (d
, a
, 0))
2685 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
2689 && !gfc_check_conformance (a
, m
,
2690 "arguments '%s' and '%s' for intrinsic %s",
2691 gfc_current_intrinsic_arg
[0]->name
,
2692 gfc_current_intrinsic_arg
[2]->name
,
2693 gfc_current_intrinsic
))
2701 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
2703 if (!int_or_real_check (ap
->expr
, 0)
2704 || !array_check (ap
->expr
, 0))
2707 return check_reduction (ap
);
2712 gfc_check_product_sum (gfc_actual_arglist
*ap
)
2714 if (!numeric_check (ap
->expr
, 0)
2715 || !array_check (ap
->expr
, 0))
2718 return check_reduction (ap
);
2722 /* For IANY, IALL and IPARITY. */
2725 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
2729 if (!type_check (i
, 0, BT_INTEGER
))
2732 if (!nonnegative_check ("I", i
))
2735 if (!kind_check (kind
, 1, BT_INTEGER
))
2739 gfc_extract_int (kind
, &k
);
2741 k
= gfc_default_integer_kind
;
2743 if (!less_than_bitsizekind ("I", i
, k
))
2751 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
2753 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
2755 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2756 gfc_current_intrinsic_arg
[0]->name
,
2757 gfc_current_intrinsic
, &ap
->expr
->where
);
2761 if (!array_check (ap
->expr
, 0))
2764 return check_reduction (ap
);
2769 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
2771 if (!same_type_check (tsource
, 0, fsource
, 1))
2774 if (!type_check (mask
, 2, BT_LOGICAL
))
2777 if (tsource
->ts
.type
== BT_CHARACTER
)
2778 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
2785 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
2787 if (!type_check (i
, 0, BT_INTEGER
))
2790 if (!type_check (j
, 1, BT_INTEGER
))
2793 if (!type_check (mask
, 2, BT_INTEGER
))
2796 if (!same_type_check (i
, 0, j
, 1))
2799 if (!same_type_check (i
, 0, mask
, 2))
2807 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
2809 if (!variable_check (from
, 0, false))
2811 if (!allocatable_check (from
, 0))
2813 if (gfc_is_coindexed (from
))
2815 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
2816 "coindexed", &from
->where
);
2820 if (!variable_check (to
, 1, false))
2822 if (!allocatable_check (to
, 1))
2824 if (gfc_is_coindexed (to
))
2826 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
2827 "coindexed", &to
->where
);
2831 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
2833 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2834 "polymorphic if FROM is polymorphic",
2839 if (!same_type_check (to
, 1, from
, 0))
2842 if (to
->rank
!= from
->rank
)
2844 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2845 "must have the same rank %d/%d", &to
->where
, from
->rank
,
2850 /* IR F08/0040; cf. 12-006A. */
2851 if (gfc_get_corank (to
) != gfc_get_corank (from
))
2853 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2854 "must have the same corank %d/%d", &to
->where
,
2855 gfc_get_corank (from
), gfc_get_corank (to
));
2859 /* CLASS arguments: Make sure the vtab of from is present. */
2860 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
2862 if (from
->ts
.type
== BT_CLASS
|| from
->ts
.type
== BT_DERIVED
)
2863 gfc_find_derived_vtab (from
->ts
.u
.derived
);
2865 gfc_find_intrinsic_vtab (&from
->ts
);
2873 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
2875 if (!type_check (x
, 0, BT_REAL
))
2878 if (!type_check (s
, 1, BT_REAL
))
2881 if (s
->expr_type
== EXPR_CONSTANT
)
2883 if (mpfr_sgn (s
->value
.real
) == 0)
2885 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2896 gfc_check_new_line (gfc_expr
*a
)
2898 if (!type_check (a
, 0, BT_CHARACTER
))
2906 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
2908 if (!type_check (array
, 0, BT_REAL
))
2911 if (!array_check (array
, 0))
2914 if (!dim_rank_check (dim
, array
, false))
2921 gfc_check_null (gfc_expr
*mold
)
2923 symbol_attribute attr
;
2928 if (!variable_check (mold
, 0, true))
2931 attr
= gfc_variable_attr (mold
, NULL
);
2933 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
2935 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2936 "ALLOCATABLE or procedure pointer",
2937 gfc_current_intrinsic_arg
[0]->name
,
2938 gfc_current_intrinsic
, &mold
->where
);
2942 if (attr
.allocatable
2943 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
2944 "allocatable MOLD at %L", &mold
->where
))
2948 if (gfc_is_coindexed (mold
))
2950 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2951 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
2952 gfc_current_intrinsic
, &mold
->where
);
2961 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
2963 if (!array_check (array
, 0))
2966 if (!type_check (mask
, 1, BT_LOGICAL
))
2969 if (!gfc_check_conformance (array
, mask
,
2970 "arguments '%s' and '%s' for intrinsic '%s'",
2971 gfc_current_intrinsic_arg
[0]->name
,
2972 gfc_current_intrinsic_arg
[1]->name
,
2973 gfc_current_intrinsic
))
2978 mpz_t array_size
, vector_size
;
2979 bool have_array_size
, have_vector_size
;
2981 if (!same_type_check (array
, 0, vector
, 2))
2984 if (!rank_check (vector
, 2, 1))
2987 /* VECTOR requires at least as many elements as MASK
2988 has .TRUE. values. */
2989 have_array_size
= gfc_array_size(array
, &array_size
);
2990 have_vector_size
= gfc_array_size(vector
, &vector_size
);
2992 if (have_vector_size
2993 && (mask
->expr_type
== EXPR_ARRAY
2994 || (mask
->expr_type
== EXPR_CONSTANT
2995 && have_array_size
)))
2997 int mask_true_values
= 0;
2999 if (mask
->expr_type
== EXPR_ARRAY
)
3001 gfc_constructor
*mask_ctor
;
3002 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3005 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3007 mask_true_values
= 0;
3011 if (mask_ctor
->expr
->value
.logical
)
3014 mask_ctor
= gfc_constructor_next (mask_ctor
);
3017 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3018 mask_true_values
= mpz_get_si (array_size
);
3020 if (mpz_get_si (vector_size
) < mask_true_values
)
3022 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3023 "provide at least as many elements as there "
3024 "are .TRUE. values in '%s' (%ld/%d)",
3025 gfc_current_intrinsic_arg
[2]->name
,
3026 gfc_current_intrinsic
, &vector
->where
,
3027 gfc_current_intrinsic_arg
[1]->name
,
3028 mpz_get_si (vector_size
), mask_true_values
);
3033 if (have_array_size
)
3034 mpz_clear (array_size
);
3035 if (have_vector_size
)
3036 mpz_clear (vector_size
);
3044 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3046 if (!type_check (mask
, 0, BT_LOGICAL
))
3049 if (!array_check (mask
, 0))
3052 if (!dim_rank_check (dim
, mask
, false))
3060 gfc_check_precision (gfc_expr
*x
)
3062 if (!real_or_complex_check (x
, 0))
3070 gfc_check_present (gfc_expr
*a
)
3074 if (!variable_check (a
, 0, true))
3077 sym
= a
->symtree
->n
.sym
;
3078 if (!sym
->attr
.dummy
)
3080 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3081 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3082 gfc_current_intrinsic
, &a
->where
);
3086 if (!sym
->attr
.optional
)
3088 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3089 "an OPTIONAL dummy variable",
3090 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3095 /* 13.14.82 PRESENT(A)
3097 Argument. A shall be the name of an optional dummy argument that is
3098 accessible in the subprogram in which the PRESENT function reference
3102 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3103 && (a
->ref
->u
.ar
.type
== AR_FULL
3104 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3105 && a
->ref
->u
.ar
.as
->rank
== 0))))
3107 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3108 "subobject of '%s'", gfc_current_intrinsic_arg
[0]->name
,
3109 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3118 gfc_check_radix (gfc_expr
*x
)
3120 if (!int_or_real_check (x
, 0))
3128 gfc_check_range (gfc_expr
*x
)
3130 if (!numeric_check (x
, 0))
3138 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3140 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3141 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3143 bool is_variable
= true;
3145 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3146 if (a
->expr_type
== EXPR_FUNCTION
)
3147 is_variable
= a
->value
.function
.esym
3148 ? a
->value
.function
.esym
->result
->attr
.pointer
3149 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3151 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3152 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3155 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3156 "object", &a
->where
);
3164 /* real, float, sngl. */
3166 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3168 if (!numeric_check (a
, 0))
3171 if (!kind_check (kind
, 1, BT_REAL
))
3179 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3181 if (!type_check (path1
, 0, BT_CHARACTER
))
3183 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3186 if (!type_check (path2
, 1, BT_CHARACTER
))
3188 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3196 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3198 if (!type_check (path1
, 0, BT_CHARACTER
))
3200 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3203 if (!type_check (path2
, 1, BT_CHARACTER
))
3205 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3211 if (!type_check (status
, 2, BT_INTEGER
))
3214 if (!scalar_check (status
, 2))
3222 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3224 if (!type_check (x
, 0, BT_CHARACTER
))
3227 if (!scalar_check (x
, 0))
3230 if (!type_check (y
, 0, BT_INTEGER
))
3233 if (!scalar_check (y
, 1))
3241 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3242 gfc_expr
*pad
, gfc_expr
*order
)
3248 if (!array_check (source
, 0))
3251 if (!rank_check (shape
, 1, 1))
3254 if (!type_check (shape
, 1, BT_INTEGER
))
3257 if (!gfc_array_size (shape
, &size
))
3259 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3260 "array of constant size", &shape
->where
);
3264 shape_size
= mpz_get_ui (size
);
3267 if (shape_size
<= 0)
3269 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3270 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3274 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3276 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3277 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3280 else if (shape
->expr_type
== EXPR_ARRAY
)
3284 for (i
= 0; i
< shape_size
; ++i
)
3286 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3287 if (e
->expr_type
!= EXPR_CONSTANT
)
3290 gfc_extract_int (e
, &extent
);
3293 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3294 "negative element (%d)",
3295 gfc_current_intrinsic_arg
[1]->name
,
3296 gfc_current_intrinsic
, &e
->where
, extent
);
3304 if (!same_type_check (source
, 0, pad
, 2))
3307 if (!array_check (pad
, 2))
3313 if (!array_check (order
, 3))
3316 if (!type_check (order
, 3, BT_INTEGER
))
3319 if (order
->expr_type
== EXPR_ARRAY
)
3321 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3324 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3327 gfc_array_size (order
, &size
);
3328 order_size
= mpz_get_ui (size
);
3331 if (order_size
!= shape_size
)
3333 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3334 "has wrong number of elements (%d/%d)",
3335 gfc_current_intrinsic_arg
[3]->name
,
3336 gfc_current_intrinsic
, &order
->where
,
3337 order_size
, shape_size
);
3341 for (i
= 1; i
<= order_size
; ++i
)
3343 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3344 if (e
->expr_type
!= EXPR_CONSTANT
)
3347 gfc_extract_int (e
, &dim
);
3349 if (dim
< 1 || dim
> order_size
)
3351 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3352 "has out-of-range dimension (%d)",
3353 gfc_current_intrinsic_arg
[3]->name
,
3354 gfc_current_intrinsic
, &e
->where
, dim
);
3358 if (perm
[dim
-1] != 0)
3360 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3361 "invalid permutation of dimensions (dimension "
3363 gfc_current_intrinsic_arg
[3]->name
,
3364 gfc_current_intrinsic
, &e
->where
, dim
);
3373 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3374 && gfc_is_constant_expr (shape
)
3375 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3376 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3378 /* Check the match in size between source and destination. */
3379 if (gfc_array_size (source
, &nelems
))
3385 mpz_init_set_ui (size
, 1);
3386 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3387 c
; c
= gfc_constructor_next (c
))
3388 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3390 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3396 gfc_error ("Without padding, there are not enough elements "
3397 "in the intrinsic RESHAPE source at %L to match "
3398 "the shape", &source
->where
);
3409 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3411 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3413 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3414 "cannot be of type %s",
3415 gfc_current_intrinsic_arg
[0]->name
,
3416 gfc_current_intrinsic
,
3417 &a
->where
, gfc_typename (&a
->ts
));
3421 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3423 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3424 "must be of an extensible type",
3425 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3430 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3432 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3433 "cannot be of type %s",
3434 gfc_current_intrinsic_arg
[0]->name
,
3435 gfc_current_intrinsic
,
3436 &b
->where
, gfc_typename (&b
->ts
));
3440 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3442 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3443 "must be of an extensible type",
3444 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3454 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3456 if (!type_check (x
, 0, BT_REAL
))
3459 if (!type_check (i
, 1, BT_INTEGER
))
3467 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3469 if (!type_check (x
, 0, BT_CHARACTER
))
3472 if (!type_check (y
, 1, BT_CHARACTER
))
3475 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
3478 if (!kind_check (kind
, 3, BT_INTEGER
))
3480 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3481 "with KIND argument at %L",
3482 gfc_current_intrinsic
, &kind
->where
))
3485 if (!same_type_check (x
, 0, y
, 1))
3493 gfc_check_secnds (gfc_expr
*r
)
3495 if (!type_check (r
, 0, BT_REAL
))
3498 if (!kind_value_check (r
, 0, 4))
3501 if (!scalar_check (r
, 0))
3509 gfc_check_selected_char_kind (gfc_expr
*name
)
3511 if (!type_check (name
, 0, BT_CHARACTER
))
3514 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
3517 if (!scalar_check (name
, 0))
3525 gfc_check_selected_int_kind (gfc_expr
*r
)
3527 if (!type_check (r
, 0, BT_INTEGER
))
3530 if (!scalar_check (r
, 0))
3538 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3540 if (p
== NULL
&& r
== NULL
3541 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
3542 " neither 'P' nor 'R' argument at %L",
3543 gfc_current_intrinsic_where
))
3548 if (!type_check (p
, 0, BT_INTEGER
))
3551 if (!scalar_check (p
, 0))
3557 if (!type_check (r
, 1, BT_INTEGER
))
3560 if (!scalar_check (r
, 1))
3566 if (!type_check (radix
, 1, BT_INTEGER
))
3569 if (!scalar_check (radix
, 1))
3572 if (!gfc_notify_std (GFC_STD_F2008
, "'%s' intrinsic with "
3573 "RADIX argument at %L", gfc_current_intrinsic
,
3583 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3585 if (!type_check (x
, 0, BT_REAL
))
3588 if (!type_check (i
, 1, BT_INTEGER
))
3596 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
3600 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3603 ar
= gfc_find_array_ref (source
);
3605 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
3607 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3608 "an assumed size array", &source
->where
);
3612 if (!kind_check (kind
, 1, BT_INTEGER
))
3614 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3615 "with KIND argument at %L",
3616 gfc_current_intrinsic
, &kind
->where
))
3624 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
3626 if (!type_check (i
, 0, BT_INTEGER
))
3629 if (!type_check (shift
, 0, BT_INTEGER
))
3632 if (!nonnegative_check ("SHIFT", shift
))
3635 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
3643 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
3645 if (!int_or_real_check (a
, 0))
3648 if (!same_type_check (a
, 0, b
, 1))
3656 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3658 if (!array_check (array
, 0))
3661 if (!dim_check (dim
, 1, true))
3664 if (!dim_rank_check (dim
, array
, 0))
3667 if (!kind_check (kind
, 2, BT_INTEGER
))
3669 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3670 "with KIND argument at %L",
3671 gfc_current_intrinsic
, &kind
->where
))
3680 gfc_check_sizeof (gfc_expr
*arg
)
3682 if (arg
->ts
.type
== BT_PROCEDURE
)
3684 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
3685 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3690 if (arg
->ts
.type
== BT_ASSUMED
)
3692 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
3693 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3698 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
3699 && arg
->symtree
->n
.sym
->as
!= NULL
3700 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
3701 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
3703 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3704 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
3705 gfc_current_intrinsic
, &arg
->where
);
3713 /* Check whether an expression is interoperable. When returning false,
3714 msg is set to a string telling why the expression is not interoperable,
3715 otherwise, it is set to NULL. The msg string can be used in diagnostics.
3716 If c_loc is true, character with len > 1 are allowed (cf. Fortran
3717 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
3718 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
3722 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
3726 if (expr
->ts
.type
== BT_CLASS
)
3728 *msg
= "Expression is polymorphic";
3732 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
3733 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
3735 *msg
= "Expression is a noninteroperable derived type";
3739 if (expr
->ts
.type
== BT_PROCEDURE
)
3741 *msg
= "Procedure unexpected as argument";
3745 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
3748 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
3749 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
3751 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
3755 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
3756 && expr
->ts
.kind
!= 1)
3758 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
3762 if (expr
->ts
.type
== BT_CHARACTER
) {
3763 if (expr
->ts
.deferred
)
3765 /* TS 29113 allows deferred-length strings as dummy arguments,
3766 but it is not an interoperable type. */
3767 *msg
= "Expression shall not be a deferred-length string";
3771 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
3772 && !gfc_simplify_expr (expr
, 0))
3773 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
3775 if (!c_loc
&& expr
->ts
.u
.cl
3776 && (!expr
->ts
.u
.cl
->length
3777 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3778 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
3780 *msg
= "Type shall have a character length of 1";
3785 /* Note: The following checks are about interoperatable variables, Fortran
3786 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
3787 is allowed, e.g. assumed-shape arrays with TS 29113. */
3789 if (gfc_is_coarray (expr
))
3791 *msg
= "Coarrays are not interoperable";
3795 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
3797 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
3798 if (ar
->type
!= AR_FULL
)
3800 *msg
= "Only whole-arrays are interoperable";
3803 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
3804 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
3806 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
3816 gfc_check_c_sizeof (gfc_expr
*arg
)
3820 if (!is_c_interoperable (arg
, &msg
, false, false))
3822 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3823 "interoperable data entity: %s",
3824 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3829 if (arg
->ts
.type
== BT_ASSUMED
)
3831 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
3833 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3838 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
3839 && arg
->symtree
->n
.sym
->as
!= NULL
3840 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
3841 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
3843 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3844 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
3845 gfc_current_intrinsic
, &arg
->where
);
3854 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
3856 if (c_ptr_1
->ts
.type
!= BT_DERIVED
3857 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3858 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
3859 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
3861 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
3862 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
3866 if (!scalar_check (c_ptr_1
, 0))
3870 && (c_ptr_2
->ts
.type
!= BT_DERIVED
3871 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3872 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
3873 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
3875 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
3876 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
3877 gfc_typename (&c_ptr_1
->ts
),
3878 gfc_typename (&c_ptr_2
->ts
));
3882 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
3890 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
3892 symbol_attribute attr
;
3895 if (cptr
->ts
.type
!= BT_DERIVED
3896 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3897 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
3899 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
3900 "type TYPE(C_PTR)", &cptr
->where
);
3904 if (!scalar_check (cptr
, 0))
3907 attr
= gfc_expr_attr (fptr
);
3911 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
3916 if (fptr
->ts
.type
== BT_CLASS
)
3918 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
3923 if (gfc_is_coindexed (fptr
))
3925 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
3926 "coindexed", &fptr
->where
);
3930 if (fptr
->rank
== 0 && shape
)
3932 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
3933 "FPTR", &fptr
->where
);
3936 else if (fptr
->rank
&& !shape
)
3938 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
3939 "FPTR at %L", &fptr
->where
);
3943 if (shape
&& !rank_check (shape
, 2, 1))
3946 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
3953 if (gfc_array_size (shape
, &size
)
3954 && mpz_cmp_ui (size
, fptr
->rank
) != 0)
3957 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
3958 "size as the RANK of FPTR", &shape
->where
);
3964 if (fptr
->ts
.type
== BT_CLASS
)
3966 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
3970 if (!is_c_interoperable (fptr
, &msg
, false, true))
3971 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
3972 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
3979 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
3981 symbol_attribute attr
;
3983 if (cptr
->ts
.type
!= BT_DERIVED
3984 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3985 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
3987 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
3988 "type TYPE(C_FUNPTR)", &cptr
->where
);
3992 if (!scalar_check (cptr
, 0))
3995 attr
= gfc_expr_attr (fptr
);
3997 if (!attr
.proc_pointer
)
3999 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4000 "pointer", &fptr
->where
);
4004 if (gfc_is_coindexed (fptr
))
4006 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4007 "coindexed", &fptr
->where
);
4011 if (!attr
.is_bind_c
)
4012 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4013 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4020 gfc_check_c_funloc (gfc_expr
*x
)
4022 symbol_attribute attr
;
4024 if (gfc_is_coindexed (x
))
4026 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4027 "coindexed", &x
->where
);
4031 attr
= gfc_expr_attr (x
);
4033 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4034 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4036 gfc_namespace
*ns
= gfc_current_ns
;
4038 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4039 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4041 gfc_error ("Function result '%s' at %L is invalid as X argument "
4042 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4047 if (attr
.flavor
!= FL_PROCEDURE
)
4049 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4050 "or a procedure pointer", &x
->where
);
4054 if (!attr
.is_bind_c
)
4055 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4056 "at %L to C_FUNLOC", &x
->where
);
4062 gfc_check_c_loc (gfc_expr
*x
)
4064 symbol_attribute attr
;
4067 if (gfc_is_coindexed (x
))
4069 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4073 if (x
->ts
.type
== BT_CLASS
)
4075 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4080 attr
= gfc_expr_attr (x
);
4083 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4084 || attr
.flavor
== FL_PARAMETER
))
4086 gfc_error ("Argument X at %L to C_LOC shall have either "
4087 "the POINTER or the TARGET attribute", &x
->where
);
4091 if (x
->ts
.type
== BT_CHARACTER
4092 && gfc_var_strlen (x
) == 0)
4094 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4095 "string", &x
->where
);
4099 if (!is_c_interoperable (x
, &msg
, true, false))
4101 if (x
->ts
.type
== BT_CLASS
)
4103 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4109 && !gfc_notify_std (GFC_STD_F2008_TS
,
4110 "Noninteroperable array at %L as"
4111 " argument to C_LOC: %s", &x
->where
, msg
))
4114 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4116 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4118 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4119 && !attr
.allocatable
4120 && !gfc_notify_std (GFC_STD_F2008
,
4121 "Array of interoperable type at %L "
4122 "to C_LOC which is nonallocatable and neither "
4123 "assumed size nor explicit size", &x
->where
))
4125 else if (ar
->type
!= AR_FULL
4126 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4127 "to C_LOC", &x
->where
))
4136 gfc_check_sleep_sub (gfc_expr
*seconds
)
4138 if (!type_check (seconds
, 0, BT_INTEGER
))
4141 if (!scalar_check (seconds
, 0))
4148 gfc_check_sngl (gfc_expr
*a
)
4150 if (!type_check (a
, 0, BT_REAL
))
4153 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4154 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4155 "REAL argument to %s intrinsic at %L",
4156 gfc_current_intrinsic
, &a
->where
))
4163 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4165 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
4168 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4169 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4177 if (!dim_check (dim
, 1, false))
4180 /* dim_rank_check() does not apply here. */
4182 && dim
->expr_type
== EXPR_CONSTANT
4183 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4184 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4186 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
4187 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4188 gfc_current_intrinsic
, &dim
->where
);
4192 if (!type_check (ncopies
, 2, BT_INTEGER
))
4195 if (!scalar_check (ncopies
, 2))
4202 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4206 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4208 if (!type_check (unit
, 0, BT_INTEGER
))
4211 if (!scalar_check (unit
, 0))
4214 if (!type_check (c
, 1, BT_CHARACTER
))
4216 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4222 if (!type_check (status
, 2, BT_INTEGER
)
4223 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4224 || !scalar_check (status
, 2))
4232 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4234 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4239 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4241 if (!type_check (c
, 0, BT_CHARACTER
))
4243 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4249 if (!type_check (status
, 1, BT_INTEGER
)
4250 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4251 || !scalar_check (status
, 1))
4259 gfc_check_fgetput (gfc_expr
*c
)
4261 return gfc_check_fgetput_sub (c
, NULL
);
4266 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4268 if (!type_check (unit
, 0, BT_INTEGER
))
4271 if (!scalar_check (unit
, 0))
4274 if (!type_check (offset
, 1, BT_INTEGER
))
4277 if (!scalar_check (offset
, 1))
4280 if (!type_check (whence
, 2, BT_INTEGER
))
4283 if (!scalar_check (whence
, 2))
4289 if (!type_check (status
, 3, BT_INTEGER
))
4292 if (!kind_value_check (status
, 3, 4))
4295 if (!scalar_check (status
, 3))
4304 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4306 if (!type_check (unit
, 0, BT_INTEGER
))
4309 if (!scalar_check (unit
, 0))
4312 if (!type_check (array
, 1, BT_INTEGER
)
4313 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4316 if (!array_check (array
, 1))
4324 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4326 if (!type_check (unit
, 0, BT_INTEGER
))
4329 if (!scalar_check (unit
, 0))
4332 if (!type_check (array
, 1, BT_INTEGER
)
4333 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4336 if (!array_check (array
, 1))
4342 if (!type_check (status
, 2, BT_INTEGER
)
4343 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4346 if (!scalar_check (status
, 2))
4354 gfc_check_ftell (gfc_expr
*unit
)
4356 if (!type_check (unit
, 0, BT_INTEGER
))
4359 if (!scalar_check (unit
, 0))
4367 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4369 if (!type_check (unit
, 0, BT_INTEGER
))
4372 if (!scalar_check (unit
, 0))
4375 if (!type_check (offset
, 1, BT_INTEGER
))
4378 if (!scalar_check (offset
, 1))
4386 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4388 if (!type_check (name
, 0, BT_CHARACTER
))
4390 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4393 if (!type_check (array
, 1, BT_INTEGER
)
4394 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4397 if (!array_check (array
, 1))
4405 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4407 if (!type_check (name
, 0, BT_CHARACTER
))
4409 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4412 if (!type_check (array
, 1, BT_INTEGER
)
4413 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4416 if (!array_check (array
, 1))
4422 if (!type_check (status
, 2, BT_INTEGER
)
4423 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4426 if (!scalar_check (status
, 2))
4434 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4438 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4440 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4444 if (!coarray_check (coarray
, 0))
4449 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4450 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
4454 if (gfc_array_size (sub
, &nelems
))
4456 int corank
= gfc_get_corank (coarray
);
4458 if (mpz_cmp_ui (nelems
, corank
) != 0)
4460 gfc_error ("The number of array elements of the SUB argument to "
4461 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4462 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
4474 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
)
4476 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4478 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4482 if (dim
!= NULL
&& coarray
== NULL
)
4484 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
4485 "intrinsic at %L", &dim
->where
);
4489 if (coarray
== NULL
)
4492 if (!coarray_check (coarray
, 0))
4497 if (!dim_check (dim
, 1, false))
4500 if (!dim_corank_check (dim
, coarray
))
4507 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4508 by gfc_simplify_transfer. Return false if we cannot do so. */
4511 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
4512 size_t *source_size
, size_t *result_size
,
4513 size_t *result_length_p
)
4515 size_t result_elt_size
;
4517 if (source
->expr_type
== EXPR_FUNCTION
)
4520 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
4523 /* Calculate the size of the source. */
4524 *source_size
= gfc_target_expr_size (source
);
4525 if (*source_size
== 0)
4528 /* Determine the size of the element. */
4529 result_elt_size
= gfc_element_size (mold
);
4530 if (result_elt_size
== 0)
4533 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
4538 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
4541 result_length
= *source_size
/ result_elt_size
;
4542 if (result_length
* result_elt_size
< *source_size
)
4546 *result_size
= result_length
* result_elt_size
;
4547 if (result_length_p
)
4548 *result_length_p
= result_length
;
4551 *result_size
= result_elt_size
;
4558 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
4563 if (mold
->ts
.type
== BT_HOLLERITH
)
4565 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4566 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
4572 if (!type_check (size
, 2, BT_INTEGER
))
4575 if (!scalar_check (size
, 2))
4578 if (!nonoptional_check (size
, 2))
4582 if (!gfc_option
.warn_surprising
)
4585 /* If we can't calculate the sizes, we cannot check any more.
4586 Return true for that case. */
4588 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
4589 &result_size
, NULL
))
4592 if (source_size
< result_size
)
4593 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4594 "source size %ld < result size %ld", &source
->where
,
4595 (long) source_size
, (long) result_size
);
4602 gfc_check_transpose (gfc_expr
*matrix
)
4604 if (!rank_check (matrix
, 0, 2))
4612 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4614 if (!array_check (array
, 0))
4617 if (!dim_check (dim
, 1, false))
4620 if (!dim_rank_check (dim
, array
, 0))
4623 if (!kind_check (kind
, 2, BT_INTEGER
))
4625 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4626 "with KIND argument at %L",
4627 gfc_current_intrinsic
, &kind
->where
))
4635 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
4637 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4639 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4643 if (!coarray_check (coarray
, 0))
4648 if (!dim_check (dim
, 1, false))
4651 if (!dim_corank_check (dim
, coarray
))
4655 if (!kind_check (kind
, 2, BT_INTEGER
))
4663 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
4667 if (!rank_check (vector
, 0, 1))
4670 if (!array_check (mask
, 1))
4673 if (!type_check (mask
, 1, BT_LOGICAL
))
4676 if (!same_type_check (vector
, 0, field
, 2))
4679 if (mask
->expr_type
== EXPR_ARRAY
4680 && gfc_array_size (vector
, &vector_size
))
4682 int mask_true_count
= 0;
4683 gfc_constructor
*mask_ctor
;
4684 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4687 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4689 mask_true_count
= 0;
4693 if (mask_ctor
->expr
->value
.logical
)
4696 mask_ctor
= gfc_constructor_next (mask_ctor
);
4699 if (mpz_get_si (vector_size
) < mask_true_count
)
4701 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4702 "provide at least as many elements as there "
4703 "are .TRUE. values in '%s' (%ld/%d)",
4704 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4705 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
4706 mpz_get_si (vector_size
), mask_true_count
);
4710 mpz_clear (vector_size
);
4713 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
4715 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4716 "the same rank as '%s' or be a scalar",
4717 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
4718 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
4722 if (mask
->rank
== field
->rank
)
4725 for (i
= 0; i
< field
->rank
; i
++)
4726 if (! identical_dimen_shape (mask
, i
, field
, i
))
4728 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4729 "must have identical shape.",
4730 gfc_current_intrinsic_arg
[2]->name
,
4731 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4741 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4743 if (!type_check (x
, 0, BT_CHARACTER
))
4746 if (!same_type_check (x
, 0, y
, 1))
4749 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4752 if (!kind_check (kind
, 3, BT_INTEGER
))
4754 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4755 "with KIND argument at %L",
4756 gfc_current_intrinsic
, &kind
->where
))
4764 gfc_check_trim (gfc_expr
*x
)
4766 if (!type_check (x
, 0, BT_CHARACTER
))
4769 if (!scalar_check (x
, 0))
4777 gfc_check_ttynam (gfc_expr
*unit
)
4779 if (!scalar_check (unit
, 0))
4782 if (!type_check (unit
, 0, BT_INTEGER
))
4789 /* Common check function for the half a dozen intrinsics that have a
4790 single real argument. */
4793 gfc_check_x (gfc_expr
*x
)
4795 if (!type_check (x
, 0, BT_REAL
))
4802 /************* Check functions for intrinsic subroutines *************/
4805 gfc_check_cpu_time (gfc_expr
*time
)
4807 if (!scalar_check (time
, 0))
4810 if (!type_check (time
, 0, BT_REAL
))
4813 if (!variable_check (time
, 0, false))
4821 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
4822 gfc_expr
*zone
, gfc_expr
*values
)
4826 if (!type_check (date
, 0, BT_CHARACTER
))
4828 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
4830 if (!scalar_check (date
, 0))
4832 if (!variable_check (date
, 0, false))
4838 if (!type_check (time
, 1, BT_CHARACTER
))
4840 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
4842 if (!scalar_check (time
, 1))
4844 if (!variable_check (time
, 1, false))
4850 if (!type_check (zone
, 2, BT_CHARACTER
))
4852 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
4854 if (!scalar_check (zone
, 2))
4856 if (!variable_check (zone
, 2, false))
4862 if (!type_check (values
, 3, BT_INTEGER
))
4864 if (!array_check (values
, 3))
4866 if (!rank_check (values
, 3, 1))
4868 if (!variable_check (values
, 3, false))
4877 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
4878 gfc_expr
*to
, gfc_expr
*topos
)
4880 if (!type_check (from
, 0, BT_INTEGER
))
4883 if (!type_check (frompos
, 1, BT_INTEGER
))
4886 if (!type_check (len
, 2, BT_INTEGER
))
4889 if (!same_type_check (from
, 0, to
, 3))
4892 if (!variable_check (to
, 3, false))
4895 if (!type_check (topos
, 4, BT_INTEGER
))
4898 if (!nonnegative_check ("frompos", frompos
))
4901 if (!nonnegative_check ("topos", topos
))
4904 if (!nonnegative_check ("len", len
))
4907 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
4910 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
4918 gfc_check_random_number (gfc_expr
*harvest
)
4920 if (!type_check (harvest
, 0, BT_REAL
))
4923 if (!variable_check (harvest
, 0, false))
4931 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
4933 unsigned int nargs
= 0, kiss_size
;
4934 locus
*where
= NULL
;
4935 mpz_t put_size
, get_size
;
4936 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4938 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
4940 /* Keep the number of bytes in sync with kiss_size in
4941 libgfortran/intrinsics/random.c. */
4942 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
4946 if (size
->expr_type
!= EXPR_VARIABLE
4947 || !size
->symtree
->n
.sym
->attr
.optional
)
4950 if (!scalar_check (size
, 0))
4953 if (!type_check (size
, 0, BT_INTEGER
))
4956 if (!variable_check (size
, 0, false))
4959 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
4965 if (put
->expr_type
!= EXPR_VARIABLE
4966 || !put
->symtree
->n
.sym
->attr
.optional
)
4969 where
= &put
->where
;
4972 if (!array_check (put
, 1))
4975 if (!rank_check (put
, 1, 1))
4978 if (!type_check (put
, 1, BT_INTEGER
))
4981 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
4984 if (gfc_array_size (put
, &put_size
)
4985 && mpz_get_ui (put_size
) < kiss_size
)
4986 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4987 "too small (%i/%i)",
4988 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4989 where
, (int) mpz_get_ui (put_size
), kiss_size
);
4994 if (get
->expr_type
!= EXPR_VARIABLE
4995 || !get
->symtree
->n
.sym
->attr
.optional
)
4998 where
= &get
->where
;
5001 if (!array_check (get
, 2))
5004 if (!rank_check (get
, 2, 1))
5007 if (!type_check (get
, 2, BT_INTEGER
))
5010 if (!variable_check (get
, 2, false))
5013 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5016 if (gfc_array_size (get
, &get_size
)
5017 && mpz_get_ui (get_size
) < kiss_size
)
5018 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5019 "too small (%i/%i)",
5020 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5021 where
, (int) mpz_get_ui (get_size
), kiss_size
);
5024 /* RANDOM_SEED may not have more than one non-optional argument. */
5026 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5033 gfc_check_second_sub (gfc_expr
*time
)
5035 if (!scalar_check (time
, 0))
5038 if (!type_check (time
, 0, BT_REAL
))
5041 if (!kind_value_check (time
, 0, 4))
5048 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
5049 count, count_rate, and count_max are all optional arguments */
5052 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5053 gfc_expr
*count_max
)
5057 if (!scalar_check (count
, 0))
5060 if (!type_check (count
, 0, BT_INTEGER
))
5063 if (!variable_check (count
, 0, false))
5067 if (count_rate
!= NULL
)
5069 if (!scalar_check (count_rate
, 1))
5072 if (!type_check (count_rate
, 1, BT_INTEGER
))
5075 if (!variable_check (count_rate
, 1, false))
5079 && !same_type_check (count
, 0, count_rate
, 1))
5084 if (count_max
!= NULL
)
5086 if (!scalar_check (count_max
, 2))
5089 if (!type_check (count_max
, 2, BT_INTEGER
))
5092 if (!variable_check (count_max
, 2, false))
5096 && !same_type_check (count
, 0, count_max
, 2))
5099 if (count_rate
!= NULL
5100 && !same_type_check (count_rate
, 1, count_max
, 2))
5109 gfc_check_irand (gfc_expr
*x
)
5114 if (!scalar_check (x
, 0))
5117 if (!type_check (x
, 0, BT_INTEGER
))
5120 if (!kind_value_check (x
, 0, 4))
5128 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5130 if (!scalar_check (seconds
, 0))
5132 if (!type_check (seconds
, 0, BT_INTEGER
))
5135 if (!int_or_proc_check (handler
, 1))
5137 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5143 if (!scalar_check (status
, 2))
5145 if (!type_check (status
, 2, BT_INTEGER
))
5147 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5155 gfc_check_rand (gfc_expr
*x
)
5160 if (!scalar_check (x
, 0))
5163 if (!type_check (x
, 0, BT_INTEGER
))
5166 if (!kind_value_check (x
, 0, 4))
5174 gfc_check_srand (gfc_expr
*x
)
5176 if (!scalar_check (x
, 0))
5179 if (!type_check (x
, 0, BT_INTEGER
))
5182 if (!kind_value_check (x
, 0, 4))
5190 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5192 if (!scalar_check (time
, 0))
5194 if (!type_check (time
, 0, BT_INTEGER
))
5197 if (!type_check (result
, 1, BT_CHARACTER
))
5199 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5207 gfc_check_dtime_etime (gfc_expr
*x
)
5209 if (!array_check (x
, 0))
5212 if (!rank_check (x
, 0, 1))
5215 if (!variable_check (x
, 0, false))
5218 if (!type_check (x
, 0, BT_REAL
))
5221 if (!kind_value_check (x
, 0, 4))
5229 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5231 if (!array_check (values
, 0))
5234 if (!rank_check (values
, 0, 1))
5237 if (!variable_check (values
, 0, false))
5240 if (!type_check (values
, 0, BT_REAL
))
5243 if (!kind_value_check (values
, 0, 4))
5246 if (!scalar_check (time
, 1))
5249 if (!type_check (time
, 1, BT_REAL
))
5252 if (!kind_value_check (time
, 1, 4))
5260 gfc_check_fdate_sub (gfc_expr
*date
)
5262 if (!type_check (date
, 0, BT_CHARACTER
))
5264 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5272 gfc_check_gerror (gfc_expr
*msg
)
5274 if (!type_check (msg
, 0, BT_CHARACTER
))
5276 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5284 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5286 if (!type_check (cwd
, 0, BT_CHARACTER
))
5288 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5294 if (!scalar_check (status
, 1))
5297 if (!type_check (status
, 1, BT_INTEGER
))
5305 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5307 if (!type_check (pos
, 0, BT_INTEGER
))
5310 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5312 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
5313 "not wider than the default kind (%d)",
5314 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5315 &pos
->where
, gfc_default_integer_kind
);
5319 if (!type_check (value
, 1, BT_CHARACTER
))
5321 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
5329 gfc_check_getlog (gfc_expr
*msg
)
5331 if (!type_check (msg
, 0, BT_CHARACTER
))
5333 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5341 gfc_check_exit (gfc_expr
*status
)
5346 if (!type_check (status
, 0, BT_INTEGER
))
5349 if (!scalar_check (status
, 0))
5357 gfc_check_flush (gfc_expr
*unit
)
5362 if (!type_check (unit
, 0, BT_INTEGER
))
5365 if (!scalar_check (unit
, 0))
5373 gfc_check_free (gfc_expr
*i
)
5375 if (!type_check (i
, 0, BT_INTEGER
))
5378 if (!scalar_check (i
, 0))
5386 gfc_check_hostnm (gfc_expr
*name
)
5388 if (!type_check (name
, 0, BT_CHARACTER
))
5390 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5398 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
5400 if (!type_check (name
, 0, BT_CHARACTER
))
5402 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5408 if (!scalar_check (status
, 1))
5411 if (!type_check (status
, 1, BT_INTEGER
))
5419 gfc_check_itime_idate (gfc_expr
*values
)
5421 if (!array_check (values
, 0))
5424 if (!rank_check (values
, 0, 1))
5427 if (!variable_check (values
, 0, false))
5430 if (!type_check (values
, 0, BT_INTEGER
))
5433 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
5441 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
5443 if (!type_check (time
, 0, BT_INTEGER
))
5446 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
5449 if (!scalar_check (time
, 0))
5452 if (!array_check (values
, 1))
5455 if (!rank_check (values
, 1, 1))
5458 if (!variable_check (values
, 1, false))
5461 if (!type_check (values
, 1, BT_INTEGER
))
5464 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
5472 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
5474 if (!scalar_check (unit
, 0))
5477 if (!type_check (unit
, 0, BT_INTEGER
))
5480 if (!type_check (name
, 1, BT_CHARACTER
))
5482 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
5490 gfc_check_isatty (gfc_expr
*unit
)
5495 if (!type_check (unit
, 0, BT_INTEGER
))
5498 if (!scalar_check (unit
, 0))
5506 gfc_check_isnan (gfc_expr
*x
)
5508 if (!type_check (x
, 0, BT_REAL
))
5516 gfc_check_perror (gfc_expr
*string
)
5518 if (!type_check (string
, 0, BT_CHARACTER
))
5520 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
5528 gfc_check_umask (gfc_expr
*mask
)
5530 if (!type_check (mask
, 0, BT_INTEGER
))
5533 if (!scalar_check (mask
, 0))
5541 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
5543 if (!type_check (mask
, 0, BT_INTEGER
))
5546 if (!scalar_check (mask
, 0))
5552 if (!scalar_check (old
, 1))
5555 if (!type_check (old
, 1, BT_INTEGER
))
5563 gfc_check_unlink (gfc_expr
*name
)
5565 if (!type_check (name
, 0, BT_CHARACTER
))
5567 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5575 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
5577 if (!type_check (name
, 0, BT_CHARACTER
))
5579 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5585 if (!scalar_check (status
, 1))
5588 if (!type_check (status
, 1, BT_INTEGER
))
5596 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
5598 if (!scalar_check (number
, 0))
5600 if (!type_check (number
, 0, BT_INTEGER
))
5603 if (!int_or_proc_check (handler
, 1))
5605 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5613 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
5615 if (!scalar_check (number
, 0))
5617 if (!type_check (number
, 0, BT_INTEGER
))
5620 if (!int_or_proc_check (handler
, 1))
5622 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5628 if (!type_check (status
, 2, BT_INTEGER
))
5630 if (!scalar_check (status
, 2))
5638 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
5640 if (!type_check (cmd
, 0, BT_CHARACTER
))
5642 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
5645 if (!scalar_check (status
, 1))
5648 if (!type_check (status
, 1, BT_INTEGER
))
5651 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
5658 /* This is used for the GNU intrinsics AND, OR and XOR. */
5660 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
5662 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
5664 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5665 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
5666 gfc_current_intrinsic
, &i
->where
);
5670 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
5672 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5673 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
5674 gfc_current_intrinsic
, &j
->where
);
5678 if (i
->ts
.type
!= j
->ts
.type
)
5680 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5681 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
5682 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5687 if (!scalar_check (i
, 0))
5690 if (!scalar_check (j
, 1))
5698 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
5700 if (a
->ts
.type
== BT_ASSUMED
)
5702 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
5703 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5708 if (a
->ts
.type
== BT_PROCEDURE
)
5710 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
5711 "procedure", gfc_current_intrinsic_arg
[0]->name
,
5712 gfc_current_intrinsic
, &a
->where
);
5719 if (!type_check (kind
, 1, BT_INTEGER
))
5722 if (!scalar_check (kind
, 1))
5725 if (kind
->expr_type
!= EXPR_CONSTANT
)
5727 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5728 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,