2 Copyright (C) 2002-2014 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 lose 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 lose precision, consider using the KIND argument",
1287 gfc_typename (&y
->ts
), gfc_default_real_kind
, &y
->where
);
1294 check_co_minmaxsum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1297 if (!variable_check (a
, 0, false))
1300 if (result_image
!= NULL
)
1302 if (!type_check (result_image
, 1, BT_INTEGER
))
1304 if (!scalar_check (result_image
, 1))
1310 if (!type_check (stat
, 2, BT_INTEGER
))
1312 if (!scalar_check (stat
, 2))
1314 if (!variable_check (stat
, 2, false))
1316 if (stat
->ts
.kind
!= 4)
1318 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1319 "variable", &stat
->where
);
1326 if (!type_check (errmsg
, 3, BT_CHARACTER
))
1328 if (!scalar_check (errmsg
, 3))
1330 if (!variable_check (errmsg
, 3, false))
1332 if (errmsg
->ts
.kind
!= 1)
1334 gfc_error ("The errmsg= argument at %L must be a default-kind "
1335 "character variable", &errmsg
->where
);
1340 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
1342 gfc_fatal_error ("Coarrays disabled at %L, use -fcoarray= to enable",
1352 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1355 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1356 && a
->ts
.type
!= BT_CHARACTER
)
1358 gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type "
1359 "integer, real or character",
1360 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1364 return check_co_minmaxsum (a
, result_image
, stat
, errmsg
);
1369 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1372 if (!numeric_check (a
, 0))
1374 return check_co_minmaxsum (a
, result_image
, stat
, errmsg
);
1379 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1381 if (!int_or_real_check (x
, 0))
1383 if (!scalar_check (x
, 0))
1386 if (!int_or_real_check (y
, 1))
1388 if (!scalar_check (y
, 1))
1396 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1398 if (!logical_array_check (mask
, 0))
1400 if (!dim_check (dim
, 1, false))
1402 if (!dim_rank_check (dim
, mask
, 0))
1404 if (!kind_check (kind
, 2, BT_INTEGER
))
1406 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1407 "with KIND argument at %L",
1408 gfc_current_intrinsic
, &kind
->where
))
1416 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1418 if (!array_check (array
, 0))
1421 if (!type_check (shift
, 1, BT_INTEGER
))
1424 if (!dim_check (dim
, 2, true))
1427 if (!dim_rank_check (dim
, array
, false))
1430 if (array
->rank
== 1 || shift
->rank
== 0)
1432 if (!scalar_check (shift
, 1))
1435 else if (shift
->rank
== array
->rank
- 1)
1440 else if (dim
->expr_type
== EXPR_CONSTANT
)
1441 gfc_extract_int (dim
, &d
);
1448 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1451 if (!identical_dimen_shape (array
, i
, shift
, j
))
1453 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1454 "invalid shape in dimension %d (%ld/%ld)",
1455 gfc_current_intrinsic_arg
[1]->name
,
1456 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1457 mpz_get_si (array
->shape
[i
]),
1458 mpz_get_si (shift
->shape
[j
]));
1468 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1469 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1470 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1479 gfc_check_ctime (gfc_expr
*time
)
1481 if (!scalar_check (time
, 0))
1484 if (!type_check (time
, 0, BT_INTEGER
))
1491 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1493 if (!double_check (y
, 0) || !double_check (x
, 1))
1500 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1502 if (!numeric_check (x
, 0))
1507 if (!numeric_check (y
, 1))
1510 if (x
->ts
.type
== BT_COMPLEX
)
1512 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1513 "present if 'x' is COMPLEX",
1514 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1519 if (y
->ts
.type
== BT_COMPLEX
)
1521 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1522 "of either REAL or INTEGER",
1523 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1534 gfc_check_dble (gfc_expr
*x
)
1536 if (!numeric_check (x
, 0))
1544 gfc_check_digits (gfc_expr
*x
)
1546 if (!int_or_real_check (x
, 0))
1554 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1556 switch (vector_a
->ts
.type
)
1559 if (!type_check (vector_b
, 1, BT_LOGICAL
))
1566 if (!numeric_check (vector_b
, 1))
1571 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1572 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1573 gfc_current_intrinsic
, &vector_a
->where
);
1577 if (!rank_check (vector_a
, 0, 1))
1580 if (!rank_check (vector_b
, 1, 1))
1583 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1585 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1586 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0]->name
,
1587 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1596 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1598 if (!type_check (x
, 0, BT_REAL
)
1599 || !type_check (y
, 1, BT_REAL
))
1602 if (x
->ts
.kind
!= gfc_default_real_kind
)
1604 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1605 "real", gfc_current_intrinsic_arg
[0]->name
,
1606 gfc_current_intrinsic
, &x
->where
);
1610 if (y
->ts
.kind
!= gfc_default_real_kind
)
1612 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1613 "real", gfc_current_intrinsic_arg
[1]->name
,
1614 gfc_current_intrinsic
, &y
->where
);
1623 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1625 if (!type_check (i
, 0, BT_INTEGER
))
1628 if (!type_check (j
, 1, BT_INTEGER
))
1631 if (i
->is_boz
&& j
->is_boz
)
1633 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1634 "constants", &i
->where
, &j
->where
);
1638 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
1641 if (!type_check (shift
, 2, BT_INTEGER
))
1644 if (!nonnegative_check ("SHIFT", shift
))
1649 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
1651 i
->ts
.kind
= j
->ts
.kind
;
1655 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
1657 j
->ts
.kind
= i
->ts
.kind
;
1665 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1668 if (!array_check (array
, 0))
1671 if (!type_check (shift
, 1, BT_INTEGER
))
1674 if (!dim_check (dim
, 3, true))
1677 if (!dim_rank_check (dim
, array
, false))
1680 if (array
->rank
== 1 || shift
->rank
== 0)
1682 if (!scalar_check (shift
, 1))
1685 else if (shift
->rank
== array
->rank
- 1)
1690 else if (dim
->expr_type
== EXPR_CONSTANT
)
1691 gfc_extract_int (dim
, &d
);
1698 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1701 if (!identical_dimen_shape (array
, i
, shift
, j
))
1703 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1704 "invalid shape in dimension %d (%ld/%ld)",
1705 gfc_current_intrinsic_arg
[1]->name
,
1706 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1707 mpz_get_si (array
->shape
[i
]),
1708 mpz_get_si (shift
->shape
[j
]));
1718 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1719 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1720 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1724 if (boundary
!= NULL
)
1726 if (!same_type_check (array
, 0, boundary
, 2))
1729 if (array
->rank
== 1 || boundary
->rank
== 0)
1731 if (!scalar_check (boundary
, 2))
1734 else if (boundary
->rank
== array
->rank
- 1)
1736 if (!gfc_check_conformance (shift
, boundary
,
1737 "arguments '%s' and '%s' for "
1739 gfc_current_intrinsic_arg
[1]->name
,
1740 gfc_current_intrinsic_arg
[2]->name
,
1741 gfc_current_intrinsic
))
1746 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1747 "rank %d or be a scalar",
1748 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1749 &shift
->where
, array
->rank
- 1);
1758 gfc_check_float (gfc_expr
*a
)
1760 if (!type_check (a
, 0, BT_INTEGER
))
1763 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
1764 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
1765 "kind argument to %s intrinsic at %L",
1766 gfc_current_intrinsic
, &a
->where
))
1772 /* A single complex argument. */
1775 gfc_check_fn_c (gfc_expr
*a
)
1777 if (!type_check (a
, 0, BT_COMPLEX
))
1783 /* A single real argument. */
1786 gfc_check_fn_r (gfc_expr
*a
)
1788 if (!type_check (a
, 0, BT_REAL
))
1794 /* A single double argument. */
1797 gfc_check_fn_d (gfc_expr
*a
)
1799 if (!double_check (a
, 0))
1805 /* A single real or complex argument. */
1808 gfc_check_fn_rc (gfc_expr
*a
)
1810 if (!real_or_complex_check (a
, 0))
1818 gfc_check_fn_rc2008 (gfc_expr
*a
)
1820 if (!real_or_complex_check (a
, 0))
1823 if (a
->ts
.type
== BT_COMPLEX
1824 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument '%s' "
1825 "of '%s' intrinsic at %L",
1826 gfc_current_intrinsic_arg
[0]->name
,
1827 gfc_current_intrinsic
, &a
->where
))
1835 gfc_check_fnum (gfc_expr
*unit
)
1837 if (!type_check (unit
, 0, BT_INTEGER
))
1840 if (!scalar_check (unit
, 0))
1848 gfc_check_huge (gfc_expr
*x
)
1850 if (!int_or_real_check (x
, 0))
1858 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
1860 if (!type_check (x
, 0, BT_REAL
))
1862 if (!same_type_check (x
, 0, y
, 1))
1869 /* Check that the single argument is an integer. */
1872 gfc_check_i (gfc_expr
*i
)
1874 if (!type_check (i
, 0, BT_INTEGER
))
1882 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1884 if (!type_check (i
, 0, BT_INTEGER
))
1887 if (!type_check (j
, 1, BT_INTEGER
))
1890 if (i
->ts
.kind
!= j
->ts
.kind
)
1892 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1902 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1904 if (!type_check (i
, 0, BT_INTEGER
))
1907 if (!type_check (pos
, 1, BT_INTEGER
))
1910 if (!type_check (len
, 2, BT_INTEGER
))
1913 if (!nonnegative_check ("pos", pos
))
1916 if (!nonnegative_check ("len", len
))
1919 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
1927 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1931 if (!type_check (c
, 0, BT_CHARACTER
))
1934 if (!kind_check (kind
, 1, BT_INTEGER
))
1937 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1938 "with KIND argument at %L",
1939 gfc_current_intrinsic
, &kind
->where
))
1942 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1948 /* Substring references don't have the charlength set. */
1950 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1953 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1957 /* Check that the argument is length one. Non-constant lengths
1958 can't be checked here, so assume they are ok. */
1959 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
1961 /* If we already have a length for this expression then use it. */
1962 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1964 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1971 start
= ref
->u
.ss
.start
;
1972 end
= ref
->u
.ss
.end
;
1975 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1976 || start
->expr_type
!= EXPR_CONSTANT
)
1979 i
= mpz_get_si (end
->value
.integer
) + 1
1980 - mpz_get_si (start
->value
.integer
);
1988 gfc_error ("Argument of %s at %L must be of length one",
1989 gfc_current_intrinsic
, &c
->where
);
1998 gfc_check_idnint (gfc_expr
*a
)
2000 if (!double_check (a
, 0))
2008 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2010 if (!type_check (i
, 0, BT_INTEGER
))
2013 if (!type_check (j
, 1, BT_INTEGER
))
2016 if (i
->ts
.kind
!= j
->ts
.kind
)
2018 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2028 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2031 if (!type_check (string
, 0, BT_CHARACTER
)
2032 || !type_check (substring
, 1, BT_CHARACTER
))
2035 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2038 if (!kind_check (kind
, 3, BT_INTEGER
))
2040 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2041 "with KIND argument at %L",
2042 gfc_current_intrinsic
, &kind
->where
))
2045 if (string
->ts
.kind
!= substring
->ts
.kind
)
2047 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
2048 "kind as '%s'", gfc_current_intrinsic_arg
[1]->name
,
2049 gfc_current_intrinsic
, &substring
->where
,
2050 gfc_current_intrinsic_arg
[0]->name
);
2059 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2061 if (!numeric_check (x
, 0))
2064 if (!kind_check (kind
, 1, BT_INTEGER
))
2072 gfc_check_intconv (gfc_expr
*x
)
2074 if (!numeric_check (x
, 0))
2082 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2084 if (!type_check (i
, 0, BT_INTEGER
))
2087 if (!type_check (j
, 1, BT_INTEGER
))
2090 if (i
->ts
.kind
!= j
->ts
.kind
)
2092 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2102 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2104 if (!type_check (i
, 0, BT_INTEGER
)
2105 || !type_check (shift
, 1, BT_INTEGER
))
2108 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2116 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2118 if (!type_check (i
, 0, BT_INTEGER
)
2119 || !type_check (shift
, 1, BT_INTEGER
))
2126 if (!type_check (size
, 2, BT_INTEGER
))
2129 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2132 if (size
->expr_type
== EXPR_CONSTANT
)
2134 gfc_extract_int (size
, &i3
);
2137 gfc_error ("SIZE at %L must be positive", &size
->where
);
2141 if (shift
->expr_type
== EXPR_CONSTANT
)
2143 gfc_extract_int (shift
, &i2
);
2149 gfc_error ("The absolute value of SHIFT at %L must be less "
2150 "than or equal to SIZE at %L", &shift
->where
,
2157 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2165 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2167 if (!type_check (pid
, 0, BT_INTEGER
))
2170 if (!type_check (sig
, 1, BT_INTEGER
))
2178 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2180 if (!type_check (pid
, 0, BT_INTEGER
))
2183 if (!scalar_check (pid
, 0))
2186 if (!type_check (sig
, 1, BT_INTEGER
))
2189 if (!scalar_check (sig
, 1))
2195 if (!type_check (status
, 2, BT_INTEGER
))
2198 if (!scalar_check (status
, 2))
2206 gfc_check_kind (gfc_expr
*x
)
2208 if (x
->ts
.type
== BT_DERIVED
)
2210 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2211 "non-derived type", gfc_current_intrinsic_arg
[0]->name
,
2212 gfc_current_intrinsic
, &x
->where
);
2221 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2223 if (!array_check (array
, 0))
2226 if (!dim_check (dim
, 1, false))
2229 if (!dim_rank_check (dim
, array
, 1))
2232 if (!kind_check (kind
, 2, BT_INTEGER
))
2234 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2235 "with KIND argument at %L",
2236 gfc_current_intrinsic
, &kind
->where
))
2244 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2246 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2248 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2252 if (!coarray_check (coarray
, 0))
2257 if (!dim_check (dim
, 1, false))
2260 if (!dim_corank_check (dim
, coarray
))
2264 if (!kind_check (kind
, 2, BT_INTEGER
))
2272 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2274 if (!type_check (s
, 0, BT_CHARACTER
))
2277 if (!kind_check (kind
, 1, BT_INTEGER
))
2279 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2280 "with KIND argument at %L",
2281 gfc_current_intrinsic
, &kind
->where
))
2289 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2291 if (!type_check (a
, 0, BT_CHARACTER
))
2293 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2296 if (!type_check (b
, 1, BT_CHARACTER
))
2298 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2306 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2308 if (!type_check (path1
, 0, BT_CHARACTER
))
2310 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2313 if (!type_check (path2
, 1, BT_CHARACTER
))
2315 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2323 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2325 if (!type_check (path1
, 0, BT_CHARACTER
))
2327 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2330 if (!type_check (path2
, 1, BT_CHARACTER
))
2332 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2338 if (!type_check (status
, 2, BT_INTEGER
))
2341 if (!scalar_check (status
, 2))
2349 gfc_check_loc (gfc_expr
*expr
)
2351 return variable_check (expr
, 0, true);
2356 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2358 if (!type_check (path1
, 0, BT_CHARACTER
))
2360 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2363 if (!type_check (path2
, 1, BT_CHARACTER
))
2365 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2373 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2375 if (!type_check (path1
, 0, BT_CHARACTER
))
2377 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2380 if (!type_check (path2
, 1, BT_CHARACTER
))
2382 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2388 if (!type_check (status
, 2, BT_INTEGER
))
2391 if (!scalar_check (status
, 2))
2399 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2401 if (!type_check (a
, 0, BT_LOGICAL
))
2403 if (!kind_check (kind
, 1, BT_LOGICAL
))
2410 /* Min/max family. */
2413 min_max_args (gfc_actual_arglist
*args
)
2415 gfc_actual_arglist
*arg
;
2416 int i
, j
, nargs
, *nlabels
, nlabelless
;
2417 bool a1
= false, a2
= false;
2419 if (args
== NULL
|| args
->next
== NULL
)
2421 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2422 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2429 if (!args
->next
->name
)
2433 for (arg
= args
; arg
; arg
= arg
->next
)
2440 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2442 nlabels
= XALLOCAVEC (int, nargs
);
2443 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2449 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2451 n
= strtol (&arg
->name
[1], &endp
, 10);
2452 if (endp
[0] != '\0')
2456 if (n
<= nlabelless
)
2469 gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
2470 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2471 gfc_current_intrinsic_where
);
2475 /* Check for duplicates. */
2476 for (i
= 0; i
< nargs
; i
++)
2477 for (j
= i
+ 1; j
< nargs
; j
++)
2478 if (nlabels
[i
] == nlabels
[j
])
2484 gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg
->name
,
2485 &arg
->expr
->where
, gfc_current_intrinsic
);
2489 gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg
->name
,
2490 &arg
->expr
->where
, gfc_current_intrinsic
);
2496 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2498 gfc_actual_arglist
*arg
, *tmp
;
2502 if (!min_max_args (arglist
))
2505 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2508 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2510 if (x
->ts
.type
== type
)
2512 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
2513 "kinds at %L", &x
->where
))
2518 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2519 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2520 gfc_basic_typename (type
), kind
);
2525 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2526 if (!gfc_check_conformance (tmp
->expr
, x
,
2527 "arguments 'a%d' and 'a%d' for "
2528 "intrinsic '%s'", m
, n
,
2529 gfc_current_intrinsic
))
2538 gfc_check_min_max (gfc_actual_arglist
*arg
)
2542 if (!min_max_args (arg
))
2547 if (x
->ts
.type
== BT_CHARACTER
)
2549 if (!gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2550 "with CHARACTER argument at %L",
2551 gfc_current_intrinsic
, &x
->where
))
2554 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2556 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2557 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2561 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2566 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2568 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2573 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2575 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2580 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2582 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2586 /* End of min/max family. */
2589 gfc_check_malloc (gfc_expr
*size
)
2591 if (!type_check (size
, 0, BT_INTEGER
))
2594 if (!scalar_check (size
, 0))
2602 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2604 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2606 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2607 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2608 gfc_current_intrinsic
, &matrix_a
->where
);
2612 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2614 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2615 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2616 gfc_current_intrinsic
, &matrix_b
->where
);
2620 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2621 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2623 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2624 gfc_current_intrinsic
, &matrix_a
->where
,
2625 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2629 switch (matrix_a
->rank
)
2632 if (!rank_check (matrix_b
, 1, 2))
2634 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2635 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2637 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2638 "and '%s' at %L for intrinsic matmul",
2639 gfc_current_intrinsic_arg
[0]->name
,
2640 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2646 if (matrix_b
->rank
!= 2)
2648 if (!rank_check (matrix_b
, 1, 1))
2651 /* matrix_b has rank 1 or 2 here. Common check for the cases
2652 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2653 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2654 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2656 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2657 "dimension 1 for argument '%s' at %L for intrinsic "
2658 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2659 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2665 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2666 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
2667 gfc_current_intrinsic
, &matrix_a
->where
);
2675 /* Whoever came up with this interface was probably on something.
2676 The possibilities for the occupation of the second and third
2683 NULL MASK minloc(array, mask=m)
2686 I.e. in the case of minloc(array,mask), mask will be in the second
2687 position of the argument list and we'll have to fix that up. */
2690 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
2692 gfc_expr
*a
, *m
, *d
;
2695 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
2699 m
= ap
->next
->next
->expr
;
2701 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2702 && ap
->next
->name
== NULL
)
2706 ap
->next
->expr
= NULL
;
2707 ap
->next
->next
->expr
= m
;
2710 if (!dim_check (d
, 1, false))
2713 if (!dim_rank_check (d
, a
, 0))
2716 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
2720 && !gfc_check_conformance (a
, m
,
2721 "arguments '%s' and '%s' for intrinsic %s",
2722 gfc_current_intrinsic_arg
[0]->name
,
2723 gfc_current_intrinsic_arg
[2]->name
,
2724 gfc_current_intrinsic
))
2731 /* Similar to minloc/maxloc, the argument list might need to be
2732 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2733 difference is that MINLOC/MAXLOC take an additional KIND argument.
2734 The possibilities are:
2740 NULL MASK minval(array, mask=m)
2743 I.e. in the case of minval(array,mask), mask will be in the second
2744 position of the argument list and we'll have to fix that up. */
2747 check_reduction (gfc_actual_arglist
*ap
)
2749 gfc_expr
*a
, *m
, *d
;
2753 m
= ap
->next
->next
->expr
;
2755 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2756 && ap
->next
->name
== NULL
)
2760 ap
->next
->expr
= NULL
;
2761 ap
->next
->next
->expr
= m
;
2764 if (!dim_check (d
, 1, false))
2767 if (!dim_rank_check (d
, a
, 0))
2770 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
2774 && !gfc_check_conformance (a
, m
,
2775 "arguments '%s' and '%s' for intrinsic %s",
2776 gfc_current_intrinsic_arg
[0]->name
,
2777 gfc_current_intrinsic_arg
[2]->name
,
2778 gfc_current_intrinsic
))
2786 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
2788 if (!int_or_real_check (ap
->expr
, 0)
2789 || !array_check (ap
->expr
, 0))
2792 return check_reduction (ap
);
2797 gfc_check_product_sum (gfc_actual_arglist
*ap
)
2799 if (!numeric_check (ap
->expr
, 0)
2800 || !array_check (ap
->expr
, 0))
2803 return check_reduction (ap
);
2807 /* For IANY, IALL and IPARITY. */
2810 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
2814 if (!type_check (i
, 0, BT_INTEGER
))
2817 if (!nonnegative_check ("I", i
))
2820 if (!kind_check (kind
, 1, BT_INTEGER
))
2824 gfc_extract_int (kind
, &k
);
2826 k
= gfc_default_integer_kind
;
2828 if (!less_than_bitsizekind ("I", i
, k
))
2836 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
2838 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
2840 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2841 gfc_current_intrinsic_arg
[0]->name
,
2842 gfc_current_intrinsic
, &ap
->expr
->where
);
2846 if (!array_check (ap
->expr
, 0))
2849 return check_reduction (ap
);
2854 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
2856 if (!same_type_check (tsource
, 0, fsource
, 1))
2859 if (!type_check (mask
, 2, BT_LOGICAL
))
2862 if (tsource
->ts
.type
== BT_CHARACTER
)
2863 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
2870 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
2872 if (!type_check (i
, 0, BT_INTEGER
))
2875 if (!type_check (j
, 1, BT_INTEGER
))
2878 if (!type_check (mask
, 2, BT_INTEGER
))
2881 if (!same_type_check (i
, 0, j
, 1))
2884 if (!same_type_check (i
, 0, mask
, 2))
2892 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
2894 if (!variable_check (from
, 0, false))
2896 if (!allocatable_check (from
, 0))
2898 if (gfc_is_coindexed (from
))
2900 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
2901 "coindexed", &from
->where
);
2905 if (!variable_check (to
, 1, false))
2907 if (!allocatable_check (to
, 1))
2909 if (gfc_is_coindexed (to
))
2911 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
2912 "coindexed", &to
->where
);
2916 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
2918 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2919 "polymorphic if FROM is polymorphic",
2924 if (!same_type_check (to
, 1, from
, 0))
2927 if (to
->rank
!= from
->rank
)
2929 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2930 "must have the same rank %d/%d", &to
->where
, from
->rank
,
2935 /* IR F08/0040; cf. 12-006A. */
2936 if (gfc_get_corank (to
) != gfc_get_corank (from
))
2938 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2939 "must have the same corank %d/%d", &to
->where
,
2940 gfc_get_corank (from
), gfc_get_corank (to
));
2944 /* CLASS arguments: Make sure the vtab of from is present. */
2945 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
2946 gfc_find_vtab (&from
->ts
);
2953 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
2955 if (!type_check (x
, 0, BT_REAL
))
2958 if (!type_check (s
, 1, BT_REAL
))
2961 if (s
->expr_type
== EXPR_CONSTANT
)
2963 if (mpfr_sgn (s
->value
.real
) == 0)
2965 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2976 gfc_check_new_line (gfc_expr
*a
)
2978 if (!type_check (a
, 0, BT_CHARACTER
))
2986 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
2988 if (!type_check (array
, 0, BT_REAL
))
2991 if (!array_check (array
, 0))
2994 if (!dim_rank_check (dim
, array
, false))
3001 gfc_check_null (gfc_expr
*mold
)
3003 symbol_attribute attr
;
3008 if (!variable_check (mold
, 0, true))
3011 attr
= gfc_variable_attr (mold
, NULL
);
3013 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3015 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
3016 "ALLOCATABLE or procedure pointer",
3017 gfc_current_intrinsic_arg
[0]->name
,
3018 gfc_current_intrinsic
, &mold
->where
);
3022 if (attr
.allocatable
3023 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3024 "allocatable MOLD at %L", &mold
->where
))
3028 if (gfc_is_coindexed (mold
))
3030 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
3031 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3032 gfc_current_intrinsic
, &mold
->where
);
3041 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3043 if (!array_check (array
, 0))
3046 if (!type_check (mask
, 1, BT_LOGICAL
))
3049 if (!gfc_check_conformance (array
, mask
,
3050 "arguments '%s' and '%s' for intrinsic '%s'",
3051 gfc_current_intrinsic_arg
[0]->name
,
3052 gfc_current_intrinsic_arg
[1]->name
,
3053 gfc_current_intrinsic
))
3058 mpz_t array_size
, vector_size
;
3059 bool have_array_size
, have_vector_size
;
3061 if (!same_type_check (array
, 0, vector
, 2))
3064 if (!rank_check (vector
, 2, 1))
3067 /* VECTOR requires at least as many elements as MASK
3068 has .TRUE. values. */
3069 have_array_size
= gfc_array_size(array
, &array_size
);
3070 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3072 if (have_vector_size
3073 && (mask
->expr_type
== EXPR_ARRAY
3074 || (mask
->expr_type
== EXPR_CONSTANT
3075 && have_array_size
)))
3077 int mask_true_values
= 0;
3079 if (mask
->expr_type
== EXPR_ARRAY
)
3081 gfc_constructor
*mask_ctor
;
3082 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3085 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3087 mask_true_values
= 0;
3091 if (mask_ctor
->expr
->value
.logical
)
3094 mask_ctor
= gfc_constructor_next (mask_ctor
);
3097 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3098 mask_true_values
= mpz_get_si (array_size
);
3100 if (mpz_get_si (vector_size
) < mask_true_values
)
3102 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3103 "provide at least as many elements as there "
3104 "are .TRUE. values in '%s' (%ld/%d)",
3105 gfc_current_intrinsic_arg
[2]->name
,
3106 gfc_current_intrinsic
, &vector
->where
,
3107 gfc_current_intrinsic_arg
[1]->name
,
3108 mpz_get_si (vector_size
), mask_true_values
);
3113 if (have_array_size
)
3114 mpz_clear (array_size
);
3115 if (have_vector_size
)
3116 mpz_clear (vector_size
);
3124 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3126 if (!type_check (mask
, 0, BT_LOGICAL
))
3129 if (!array_check (mask
, 0))
3132 if (!dim_rank_check (dim
, mask
, false))
3140 gfc_check_precision (gfc_expr
*x
)
3142 if (!real_or_complex_check (x
, 0))
3150 gfc_check_present (gfc_expr
*a
)
3154 if (!variable_check (a
, 0, true))
3157 sym
= a
->symtree
->n
.sym
;
3158 if (!sym
->attr
.dummy
)
3160 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3161 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3162 gfc_current_intrinsic
, &a
->where
);
3166 if (!sym
->attr
.optional
)
3168 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3169 "an OPTIONAL dummy variable",
3170 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3175 /* 13.14.82 PRESENT(A)
3177 Argument. A shall be the name of an optional dummy argument that is
3178 accessible in the subprogram in which the PRESENT function reference
3182 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3183 && (a
->ref
->u
.ar
.type
== AR_FULL
3184 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3185 && a
->ref
->u
.ar
.as
->rank
== 0))))
3187 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3188 "subobject of '%s'", gfc_current_intrinsic_arg
[0]->name
,
3189 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3198 gfc_check_radix (gfc_expr
*x
)
3200 if (!int_or_real_check (x
, 0))
3208 gfc_check_range (gfc_expr
*x
)
3210 if (!numeric_check (x
, 0))
3218 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3220 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3221 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3223 bool is_variable
= true;
3225 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3226 if (a
->expr_type
== EXPR_FUNCTION
)
3227 is_variable
= a
->value
.function
.esym
3228 ? a
->value
.function
.esym
->result
->attr
.pointer
3229 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3231 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3232 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3235 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3236 "object", &a
->where
);
3244 /* real, float, sngl. */
3246 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3248 if (!numeric_check (a
, 0))
3251 if (!kind_check (kind
, 1, BT_REAL
))
3259 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3261 if (!type_check (path1
, 0, BT_CHARACTER
))
3263 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3266 if (!type_check (path2
, 1, BT_CHARACTER
))
3268 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3276 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3278 if (!type_check (path1
, 0, BT_CHARACTER
))
3280 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3283 if (!type_check (path2
, 1, BT_CHARACTER
))
3285 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3291 if (!type_check (status
, 2, BT_INTEGER
))
3294 if (!scalar_check (status
, 2))
3302 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3304 if (!type_check (x
, 0, BT_CHARACTER
))
3307 if (!scalar_check (x
, 0))
3310 if (!type_check (y
, 0, BT_INTEGER
))
3313 if (!scalar_check (y
, 1))
3321 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3322 gfc_expr
*pad
, gfc_expr
*order
)
3328 if (!array_check (source
, 0))
3331 if (!rank_check (shape
, 1, 1))
3334 if (!type_check (shape
, 1, BT_INTEGER
))
3337 if (!gfc_array_size (shape
, &size
))
3339 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3340 "array of constant size", &shape
->where
);
3344 shape_size
= mpz_get_ui (size
);
3347 if (shape_size
<= 0)
3349 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3350 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3354 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3356 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3357 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3360 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3364 for (i
= 0; i
< shape_size
; ++i
)
3366 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3367 if (e
->expr_type
!= EXPR_CONSTANT
)
3370 gfc_extract_int (e
, &extent
);
3373 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3374 "negative element (%d)",
3375 gfc_current_intrinsic_arg
[1]->name
,
3376 gfc_current_intrinsic
, &e
->where
, extent
);
3384 if (!same_type_check (source
, 0, pad
, 2))
3387 if (!array_check (pad
, 2))
3393 if (!array_check (order
, 3))
3396 if (!type_check (order
, 3, BT_INTEGER
))
3399 if (order
->expr_type
== EXPR_ARRAY
)
3401 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3404 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3407 gfc_array_size (order
, &size
);
3408 order_size
= mpz_get_ui (size
);
3411 if (order_size
!= shape_size
)
3413 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3414 "has wrong number of elements (%d/%d)",
3415 gfc_current_intrinsic_arg
[3]->name
,
3416 gfc_current_intrinsic
, &order
->where
,
3417 order_size
, shape_size
);
3421 for (i
= 1; i
<= order_size
; ++i
)
3423 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3424 if (e
->expr_type
!= EXPR_CONSTANT
)
3427 gfc_extract_int (e
, &dim
);
3429 if (dim
< 1 || dim
> order_size
)
3431 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3432 "has out-of-range dimension (%d)",
3433 gfc_current_intrinsic_arg
[3]->name
,
3434 gfc_current_intrinsic
, &e
->where
, dim
);
3438 if (perm
[dim
-1] != 0)
3440 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3441 "invalid permutation of dimensions (dimension "
3443 gfc_current_intrinsic_arg
[3]->name
,
3444 gfc_current_intrinsic
, &e
->where
, dim
);
3453 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3454 && gfc_is_constant_expr (shape
)
3455 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3456 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3458 /* Check the match in size between source and destination. */
3459 if (gfc_array_size (source
, &nelems
))
3465 mpz_init_set_ui (size
, 1);
3466 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3467 c
; c
= gfc_constructor_next (c
))
3468 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3470 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3476 gfc_error ("Without padding, there are not enough elements "
3477 "in the intrinsic RESHAPE source at %L to match "
3478 "the shape", &source
->where
);
3489 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3491 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3493 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3494 "cannot be of type %s",
3495 gfc_current_intrinsic_arg
[0]->name
,
3496 gfc_current_intrinsic
,
3497 &a
->where
, gfc_typename (&a
->ts
));
3501 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3503 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3504 "must be of an extensible type",
3505 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3510 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3512 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3513 "cannot be of type %s",
3514 gfc_current_intrinsic_arg
[0]->name
,
3515 gfc_current_intrinsic
,
3516 &b
->where
, gfc_typename (&b
->ts
));
3520 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3522 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3523 "must be of an extensible type",
3524 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3534 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3536 if (!type_check (x
, 0, BT_REAL
))
3539 if (!type_check (i
, 1, BT_INTEGER
))
3547 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3549 if (!type_check (x
, 0, BT_CHARACTER
))
3552 if (!type_check (y
, 1, BT_CHARACTER
))
3555 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
3558 if (!kind_check (kind
, 3, BT_INTEGER
))
3560 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3561 "with KIND argument at %L",
3562 gfc_current_intrinsic
, &kind
->where
))
3565 if (!same_type_check (x
, 0, y
, 1))
3573 gfc_check_secnds (gfc_expr
*r
)
3575 if (!type_check (r
, 0, BT_REAL
))
3578 if (!kind_value_check (r
, 0, 4))
3581 if (!scalar_check (r
, 0))
3589 gfc_check_selected_char_kind (gfc_expr
*name
)
3591 if (!type_check (name
, 0, BT_CHARACTER
))
3594 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
3597 if (!scalar_check (name
, 0))
3605 gfc_check_selected_int_kind (gfc_expr
*r
)
3607 if (!type_check (r
, 0, BT_INTEGER
))
3610 if (!scalar_check (r
, 0))
3618 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3620 if (p
== NULL
&& r
== NULL
3621 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
3622 " neither 'P' nor 'R' argument at %L",
3623 gfc_current_intrinsic_where
))
3628 if (!type_check (p
, 0, BT_INTEGER
))
3631 if (!scalar_check (p
, 0))
3637 if (!type_check (r
, 1, BT_INTEGER
))
3640 if (!scalar_check (r
, 1))
3646 if (!type_check (radix
, 1, BT_INTEGER
))
3649 if (!scalar_check (radix
, 1))
3652 if (!gfc_notify_std (GFC_STD_F2008
, "'%s' intrinsic with "
3653 "RADIX argument at %L", gfc_current_intrinsic
,
3663 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3665 if (!type_check (x
, 0, BT_REAL
))
3668 if (!type_check (i
, 1, BT_INTEGER
))
3676 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
3680 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3683 ar
= gfc_find_array_ref (source
);
3685 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
3687 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3688 "an assumed size array", &source
->where
);
3692 if (!kind_check (kind
, 1, BT_INTEGER
))
3694 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3695 "with KIND argument at %L",
3696 gfc_current_intrinsic
, &kind
->where
))
3704 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
3706 if (!type_check (i
, 0, BT_INTEGER
))
3709 if (!type_check (shift
, 0, BT_INTEGER
))
3712 if (!nonnegative_check ("SHIFT", shift
))
3715 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
3723 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
3725 if (!int_or_real_check (a
, 0))
3728 if (!same_type_check (a
, 0, b
, 1))
3736 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3738 if (!array_check (array
, 0))
3741 if (!dim_check (dim
, 1, true))
3744 if (!dim_rank_check (dim
, array
, 0))
3747 if (!kind_check (kind
, 2, BT_INTEGER
))
3749 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3750 "with KIND argument at %L",
3751 gfc_current_intrinsic
, &kind
->where
))
3760 gfc_check_sizeof (gfc_expr
*arg
)
3762 if (arg
->ts
.type
== BT_PROCEDURE
)
3764 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
3765 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3770 if (arg
->ts
.type
== BT_ASSUMED
)
3772 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
3773 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3778 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
3779 && arg
->symtree
->n
.sym
->as
!= NULL
3780 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
3781 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
3783 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3784 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
3785 gfc_current_intrinsic
, &arg
->where
);
3793 /* Check whether an expression is interoperable. When returning false,
3794 msg is set to a string telling why the expression is not interoperable,
3795 otherwise, it is set to NULL. The msg string can be used in diagnostics.
3796 If c_loc is true, character with len > 1 are allowed (cf. Fortran
3797 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
3798 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
3802 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
3806 if (expr
->ts
.type
== BT_CLASS
)
3808 *msg
= "Expression is polymorphic";
3812 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
3813 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
3815 *msg
= "Expression is a noninteroperable derived type";
3819 if (expr
->ts
.type
== BT_PROCEDURE
)
3821 *msg
= "Procedure unexpected as argument";
3825 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
3828 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
3829 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
3831 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
3835 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
3836 && expr
->ts
.kind
!= 1)
3838 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
3842 if (expr
->ts
.type
== BT_CHARACTER
) {
3843 if (expr
->ts
.deferred
)
3845 /* TS 29113 allows deferred-length strings as dummy arguments,
3846 but it is not an interoperable type. */
3847 *msg
= "Expression shall not be a deferred-length string";
3851 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
3852 && !gfc_simplify_expr (expr
, 0))
3853 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
3855 if (!c_loc
&& expr
->ts
.u
.cl
3856 && (!expr
->ts
.u
.cl
->length
3857 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3858 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
3860 *msg
= "Type shall have a character length of 1";
3865 /* Note: The following checks are about interoperatable variables, Fortran
3866 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
3867 is allowed, e.g. assumed-shape arrays with TS 29113. */
3869 if (gfc_is_coarray (expr
))
3871 *msg
= "Coarrays are not interoperable";
3875 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
3877 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
3878 if (ar
->type
!= AR_FULL
)
3880 *msg
= "Only whole-arrays are interoperable";
3883 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
3884 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
3886 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
3896 gfc_check_c_sizeof (gfc_expr
*arg
)
3900 if (!is_c_interoperable (arg
, &msg
, false, false))
3902 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3903 "interoperable data entity: %s",
3904 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3909 if (arg
->ts
.type
== BT_ASSUMED
)
3911 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
3913 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3918 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
3919 && arg
->symtree
->n
.sym
->as
!= NULL
3920 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
3921 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
3923 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3924 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
3925 gfc_current_intrinsic
, &arg
->where
);
3934 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
3936 if (c_ptr_1
->ts
.type
!= BT_DERIVED
3937 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3938 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
3939 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
3941 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
3942 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
3946 if (!scalar_check (c_ptr_1
, 0))
3950 && (c_ptr_2
->ts
.type
!= BT_DERIVED
3951 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3952 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
3953 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
3955 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
3956 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
3957 gfc_typename (&c_ptr_1
->ts
),
3958 gfc_typename (&c_ptr_2
->ts
));
3962 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
3970 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
3972 symbol_attribute attr
;
3975 if (cptr
->ts
.type
!= BT_DERIVED
3976 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3977 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
3979 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
3980 "type TYPE(C_PTR)", &cptr
->where
);
3984 if (!scalar_check (cptr
, 0))
3987 attr
= gfc_expr_attr (fptr
);
3991 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
3996 if (fptr
->ts
.type
== BT_CLASS
)
3998 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4003 if (gfc_is_coindexed (fptr
))
4005 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4006 "coindexed", &fptr
->where
);
4010 if (fptr
->rank
== 0 && shape
)
4012 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4013 "FPTR", &fptr
->where
);
4016 else if (fptr
->rank
&& !shape
)
4018 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4019 "FPTR at %L", &fptr
->where
);
4023 if (shape
&& !rank_check (shape
, 2, 1))
4026 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4032 if (gfc_array_size (shape
, &size
))
4034 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4037 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4038 "size as the RANK of FPTR", &shape
->where
);
4045 if (fptr
->ts
.type
== BT_CLASS
)
4047 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4051 if (!is_c_interoperable (fptr
, &msg
, false, true))
4052 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4053 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4060 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4062 symbol_attribute attr
;
4064 if (cptr
->ts
.type
!= BT_DERIVED
4065 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4066 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4068 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4069 "type TYPE(C_FUNPTR)", &cptr
->where
);
4073 if (!scalar_check (cptr
, 0))
4076 attr
= gfc_expr_attr (fptr
);
4078 if (!attr
.proc_pointer
)
4080 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4081 "pointer", &fptr
->where
);
4085 if (gfc_is_coindexed (fptr
))
4087 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4088 "coindexed", &fptr
->where
);
4092 if (!attr
.is_bind_c
)
4093 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4094 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4101 gfc_check_c_funloc (gfc_expr
*x
)
4103 symbol_attribute attr
;
4105 if (gfc_is_coindexed (x
))
4107 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4108 "coindexed", &x
->where
);
4112 attr
= gfc_expr_attr (x
);
4114 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4115 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4117 gfc_namespace
*ns
= gfc_current_ns
;
4119 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4120 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4122 gfc_error ("Function result '%s' at %L is invalid as X argument "
4123 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4128 if (attr
.flavor
!= FL_PROCEDURE
)
4130 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4131 "or a procedure pointer", &x
->where
);
4135 if (!attr
.is_bind_c
)
4136 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4137 "at %L to C_FUNLOC", &x
->where
);
4143 gfc_check_c_loc (gfc_expr
*x
)
4145 symbol_attribute attr
;
4148 if (gfc_is_coindexed (x
))
4150 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4154 if (x
->ts
.type
== BT_CLASS
)
4156 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4161 attr
= gfc_expr_attr (x
);
4164 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4165 || attr
.flavor
== FL_PARAMETER
))
4167 gfc_error ("Argument X at %L to C_LOC shall have either "
4168 "the POINTER or the TARGET attribute", &x
->where
);
4172 if (x
->ts
.type
== BT_CHARACTER
4173 && gfc_var_strlen (x
) == 0)
4175 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4176 "string", &x
->where
);
4180 if (!is_c_interoperable (x
, &msg
, true, false))
4182 if (x
->ts
.type
== BT_CLASS
)
4184 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4190 && !gfc_notify_std (GFC_STD_F2008_TS
,
4191 "Noninteroperable array at %L as"
4192 " argument to C_LOC: %s", &x
->where
, msg
))
4195 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4197 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4199 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4200 && !attr
.allocatable
4201 && !gfc_notify_std (GFC_STD_F2008
,
4202 "Array of interoperable type at %L "
4203 "to C_LOC which is nonallocatable and neither "
4204 "assumed size nor explicit size", &x
->where
))
4206 else if (ar
->type
!= AR_FULL
4207 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4208 "to C_LOC", &x
->where
))
4217 gfc_check_sleep_sub (gfc_expr
*seconds
)
4219 if (!type_check (seconds
, 0, BT_INTEGER
))
4222 if (!scalar_check (seconds
, 0))
4229 gfc_check_sngl (gfc_expr
*a
)
4231 if (!type_check (a
, 0, BT_REAL
))
4234 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4235 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4236 "REAL argument to %s intrinsic at %L",
4237 gfc_current_intrinsic
, &a
->where
))
4244 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4246 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4248 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
4249 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4250 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4258 if (!dim_check (dim
, 1, false))
4261 /* dim_rank_check() does not apply here. */
4263 && dim
->expr_type
== EXPR_CONSTANT
4264 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4265 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4267 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
4268 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4269 gfc_current_intrinsic
, &dim
->where
);
4273 if (!type_check (ncopies
, 2, BT_INTEGER
))
4276 if (!scalar_check (ncopies
, 2))
4283 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4287 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4289 if (!type_check (unit
, 0, BT_INTEGER
))
4292 if (!scalar_check (unit
, 0))
4295 if (!type_check (c
, 1, BT_CHARACTER
))
4297 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4303 if (!type_check (status
, 2, BT_INTEGER
)
4304 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4305 || !scalar_check (status
, 2))
4313 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4315 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4320 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4322 if (!type_check (c
, 0, BT_CHARACTER
))
4324 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4330 if (!type_check (status
, 1, BT_INTEGER
)
4331 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4332 || !scalar_check (status
, 1))
4340 gfc_check_fgetput (gfc_expr
*c
)
4342 return gfc_check_fgetput_sub (c
, NULL
);
4347 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4349 if (!type_check (unit
, 0, BT_INTEGER
))
4352 if (!scalar_check (unit
, 0))
4355 if (!type_check (offset
, 1, BT_INTEGER
))
4358 if (!scalar_check (offset
, 1))
4361 if (!type_check (whence
, 2, BT_INTEGER
))
4364 if (!scalar_check (whence
, 2))
4370 if (!type_check (status
, 3, BT_INTEGER
))
4373 if (!kind_value_check (status
, 3, 4))
4376 if (!scalar_check (status
, 3))
4385 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4387 if (!type_check (unit
, 0, BT_INTEGER
))
4390 if (!scalar_check (unit
, 0))
4393 if (!type_check (array
, 1, BT_INTEGER
)
4394 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4397 if (!array_check (array
, 1))
4405 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4407 if (!type_check (unit
, 0, BT_INTEGER
))
4410 if (!scalar_check (unit
, 0))
4413 if (!type_check (array
, 1, BT_INTEGER
)
4414 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4417 if (!array_check (array
, 1))
4423 if (!type_check (status
, 2, BT_INTEGER
)
4424 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4427 if (!scalar_check (status
, 2))
4435 gfc_check_ftell (gfc_expr
*unit
)
4437 if (!type_check (unit
, 0, BT_INTEGER
))
4440 if (!scalar_check (unit
, 0))
4448 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4450 if (!type_check (unit
, 0, BT_INTEGER
))
4453 if (!scalar_check (unit
, 0))
4456 if (!type_check (offset
, 1, BT_INTEGER
))
4459 if (!scalar_check (offset
, 1))
4467 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4469 if (!type_check (name
, 0, BT_CHARACTER
))
4471 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4474 if (!type_check (array
, 1, BT_INTEGER
)
4475 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4478 if (!array_check (array
, 1))
4486 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4488 if (!type_check (name
, 0, BT_CHARACTER
))
4490 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4493 if (!type_check (array
, 1, BT_INTEGER
)
4494 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4497 if (!array_check (array
, 1))
4503 if (!type_check (status
, 2, BT_INTEGER
)
4504 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4507 if (!scalar_check (status
, 2))
4515 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4519 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4521 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4525 if (!coarray_check (coarray
, 0))
4530 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4531 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
4535 if (gfc_array_size (sub
, &nelems
))
4537 int corank
= gfc_get_corank (coarray
);
4539 if (mpz_cmp_ui (nelems
, corank
) != 0)
4541 gfc_error ("The number of array elements of the SUB argument to "
4542 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4543 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
4555 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
4557 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4559 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4565 if (!type_check (distance
, 0, BT_INTEGER
))
4568 if (!nonnegative_check ("DISTANCE", distance
))
4571 if (!scalar_check (distance
, 0))
4574 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
4575 "NUM_IMAGES at %L", &distance
->where
))
4581 if (!type_check (failed
, 1, BT_LOGICAL
))
4584 if (!scalar_check (failed
, 1))
4587 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
4588 "NUM_IMAGES at %L", &distance
->where
))
4597 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
4599 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4601 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4605 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
4608 if (dim
!= NULL
&& coarray
== NULL
)
4610 gfc_error ("DIM argument without COARRAY argument not allowed for "
4611 "THIS_IMAGE intrinsic at %L", &dim
->where
);
4615 if (distance
&& (coarray
|| dim
))
4617 gfc_error ("The DISTANCE argument may not be specified together with the "
4618 "COARRAY or DIM argument in intrinsic at %L",
4623 /* Assume that we have "this_image (distance)". */
4624 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
4628 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
4637 if (!type_check (distance
, 2, BT_INTEGER
))
4640 if (!nonnegative_check ("DISTANCE", distance
))
4643 if (!scalar_check (distance
, 2))
4646 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
4647 "THIS_IMAGE at %L", &distance
->where
))
4653 if (!coarray_check (coarray
, 0))
4658 if (!dim_check (dim
, 1, false))
4661 if (!dim_corank_check (dim
, coarray
))
4668 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4669 by gfc_simplify_transfer. Return false if we cannot do so. */
4672 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
4673 size_t *source_size
, size_t *result_size
,
4674 size_t *result_length_p
)
4676 size_t result_elt_size
;
4678 if (source
->expr_type
== EXPR_FUNCTION
)
4681 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
4684 /* Calculate the size of the source. */
4685 *source_size
= gfc_target_expr_size (source
);
4686 if (*source_size
== 0)
4689 /* Determine the size of the element. */
4690 result_elt_size
= gfc_element_size (mold
);
4691 if (result_elt_size
== 0)
4694 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
4699 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
4702 result_length
= *source_size
/ result_elt_size
;
4703 if (result_length
* result_elt_size
< *source_size
)
4707 *result_size
= result_length
* result_elt_size
;
4708 if (result_length_p
)
4709 *result_length_p
= result_length
;
4712 *result_size
= result_elt_size
;
4719 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
4724 if (mold
->ts
.type
== BT_HOLLERITH
)
4726 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4727 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
4733 if (!type_check (size
, 2, BT_INTEGER
))
4736 if (!scalar_check (size
, 2))
4739 if (!nonoptional_check (size
, 2))
4743 if (!gfc_option
.warn_surprising
)
4746 /* If we can't calculate the sizes, we cannot check any more.
4747 Return true for that case. */
4749 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
4750 &result_size
, NULL
))
4753 if (source_size
< result_size
)
4754 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4755 "source size %ld < result size %ld", &source
->where
,
4756 (long) source_size
, (long) result_size
);
4763 gfc_check_transpose (gfc_expr
*matrix
)
4765 if (!rank_check (matrix
, 0, 2))
4773 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4775 if (!array_check (array
, 0))
4778 if (!dim_check (dim
, 1, false))
4781 if (!dim_rank_check (dim
, array
, 0))
4784 if (!kind_check (kind
, 2, BT_INTEGER
))
4786 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4787 "with KIND argument at %L",
4788 gfc_current_intrinsic
, &kind
->where
))
4796 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
4798 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4800 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4804 if (!coarray_check (coarray
, 0))
4809 if (!dim_check (dim
, 1, false))
4812 if (!dim_corank_check (dim
, coarray
))
4816 if (!kind_check (kind
, 2, BT_INTEGER
))
4824 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
4828 if (!rank_check (vector
, 0, 1))
4831 if (!array_check (mask
, 1))
4834 if (!type_check (mask
, 1, BT_LOGICAL
))
4837 if (!same_type_check (vector
, 0, field
, 2))
4840 if (mask
->expr_type
== EXPR_ARRAY
4841 && gfc_array_size (vector
, &vector_size
))
4843 int mask_true_count
= 0;
4844 gfc_constructor
*mask_ctor
;
4845 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4848 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4850 mask_true_count
= 0;
4854 if (mask_ctor
->expr
->value
.logical
)
4857 mask_ctor
= gfc_constructor_next (mask_ctor
);
4860 if (mpz_get_si (vector_size
) < mask_true_count
)
4862 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4863 "provide at least as many elements as there "
4864 "are .TRUE. values in '%s' (%ld/%d)",
4865 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4866 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
4867 mpz_get_si (vector_size
), mask_true_count
);
4871 mpz_clear (vector_size
);
4874 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
4876 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4877 "the same rank as '%s' or be a scalar",
4878 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
4879 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
4883 if (mask
->rank
== field
->rank
)
4886 for (i
= 0; i
< field
->rank
; i
++)
4887 if (! identical_dimen_shape (mask
, i
, field
, i
))
4889 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4890 "must have identical shape.",
4891 gfc_current_intrinsic_arg
[2]->name
,
4892 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4902 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4904 if (!type_check (x
, 0, BT_CHARACTER
))
4907 if (!same_type_check (x
, 0, y
, 1))
4910 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4913 if (!kind_check (kind
, 3, BT_INTEGER
))
4915 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4916 "with KIND argument at %L",
4917 gfc_current_intrinsic
, &kind
->where
))
4925 gfc_check_trim (gfc_expr
*x
)
4927 if (!type_check (x
, 0, BT_CHARACTER
))
4930 if (!scalar_check (x
, 0))
4938 gfc_check_ttynam (gfc_expr
*unit
)
4940 if (!scalar_check (unit
, 0))
4943 if (!type_check (unit
, 0, BT_INTEGER
))
4950 /* Common check function for the half a dozen intrinsics that have a
4951 single real argument. */
4954 gfc_check_x (gfc_expr
*x
)
4956 if (!type_check (x
, 0, BT_REAL
))
4963 /************* Check functions for intrinsic subroutines *************/
4966 gfc_check_cpu_time (gfc_expr
*time
)
4968 if (!scalar_check (time
, 0))
4971 if (!type_check (time
, 0, BT_REAL
))
4974 if (!variable_check (time
, 0, false))
4982 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
4983 gfc_expr
*zone
, gfc_expr
*values
)
4987 if (!type_check (date
, 0, BT_CHARACTER
))
4989 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
4991 if (!scalar_check (date
, 0))
4993 if (!variable_check (date
, 0, false))
4999 if (!type_check (time
, 1, BT_CHARACTER
))
5001 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5003 if (!scalar_check (time
, 1))
5005 if (!variable_check (time
, 1, false))
5011 if (!type_check (zone
, 2, BT_CHARACTER
))
5013 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5015 if (!scalar_check (zone
, 2))
5017 if (!variable_check (zone
, 2, false))
5023 if (!type_check (values
, 3, BT_INTEGER
))
5025 if (!array_check (values
, 3))
5027 if (!rank_check (values
, 3, 1))
5029 if (!variable_check (values
, 3, false))
5038 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5039 gfc_expr
*to
, gfc_expr
*topos
)
5041 if (!type_check (from
, 0, BT_INTEGER
))
5044 if (!type_check (frompos
, 1, BT_INTEGER
))
5047 if (!type_check (len
, 2, BT_INTEGER
))
5050 if (!same_type_check (from
, 0, to
, 3))
5053 if (!variable_check (to
, 3, false))
5056 if (!type_check (topos
, 4, BT_INTEGER
))
5059 if (!nonnegative_check ("frompos", frompos
))
5062 if (!nonnegative_check ("topos", topos
))
5065 if (!nonnegative_check ("len", len
))
5068 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5071 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5079 gfc_check_random_number (gfc_expr
*harvest
)
5081 if (!type_check (harvest
, 0, BT_REAL
))
5084 if (!variable_check (harvest
, 0, false))
5092 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5094 unsigned int nargs
= 0, kiss_size
;
5095 locus
*where
= NULL
;
5096 mpz_t put_size
, get_size
;
5097 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
5099 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
5101 /* Keep the number of bytes in sync with kiss_size in
5102 libgfortran/intrinsics/random.c. */
5103 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
5107 if (size
->expr_type
!= EXPR_VARIABLE
5108 || !size
->symtree
->n
.sym
->attr
.optional
)
5111 if (!scalar_check (size
, 0))
5114 if (!type_check (size
, 0, BT_INTEGER
))
5117 if (!variable_check (size
, 0, false))
5120 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5126 if (put
->expr_type
!= EXPR_VARIABLE
5127 || !put
->symtree
->n
.sym
->attr
.optional
)
5130 where
= &put
->where
;
5133 if (!array_check (put
, 1))
5136 if (!rank_check (put
, 1, 1))
5139 if (!type_check (put
, 1, BT_INTEGER
))
5142 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5145 if (gfc_array_size (put
, &put_size
)
5146 && mpz_get_ui (put_size
) < kiss_size
)
5147 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5148 "too small (%i/%i)",
5149 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5150 where
, (int) mpz_get_ui (put_size
), kiss_size
);
5155 if (get
->expr_type
!= EXPR_VARIABLE
5156 || !get
->symtree
->n
.sym
->attr
.optional
)
5159 where
= &get
->where
;
5162 if (!array_check (get
, 2))
5165 if (!rank_check (get
, 2, 1))
5168 if (!type_check (get
, 2, BT_INTEGER
))
5171 if (!variable_check (get
, 2, false))
5174 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5177 if (gfc_array_size (get
, &get_size
)
5178 && mpz_get_ui (get_size
) < kiss_size
)
5179 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5180 "too small (%i/%i)",
5181 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5182 where
, (int) mpz_get_ui (get_size
), kiss_size
);
5185 /* RANDOM_SEED may not have more than one non-optional argument. */
5187 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5194 gfc_check_second_sub (gfc_expr
*time
)
5196 if (!scalar_check (time
, 0))
5199 if (!type_check (time
, 0, BT_REAL
))
5202 if (!kind_value_check (time
, 0, 4))
5209 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5210 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5211 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5212 count_max are all optional arguments */
5215 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5216 gfc_expr
*count_max
)
5220 if (!scalar_check (count
, 0))
5223 if (!type_check (count
, 0, BT_INTEGER
))
5226 if (count
->ts
.kind
!= gfc_default_integer_kind
5227 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5228 "SYSTEM_CLOCK at %L has non-default kind",
5232 if (!variable_check (count
, 0, false))
5236 if (count_rate
!= NULL
)
5238 if (!scalar_check (count_rate
, 1))
5241 if (!variable_check (count_rate
, 1, false))
5244 if (count_rate
->ts
.type
== BT_REAL
)
5246 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5247 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5252 if (!type_check (count_rate
, 1, BT_INTEGER
))
5255 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5256 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5257 "SYSTEM_CLOCK at %L has non-default kind",
5258 &count_rate
->where
))
5264 if (count_max
!= NULL
)
5266 if (!scalar_check (count_max
, 2))
5269 if (!type_check (count_max
, 2, BT_INTEGER
))
5272 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5273 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5274 "SYSTEM_CLOCK at %L has non-default kind",
5278 if (!variable_check (count_max
, 2, false))
5287 gfc_check_irand (gfc_expr
*x
)
5292 if (!scalar_check (x
, 0))
5295 if (!type_check (x
, 0, BT_INTEGER
))
5298 if (!kind_value_check (x
, 0, 4))
5306 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5308 if (!scalar_check (seconds
, 0))
5310 if (!type_check (seconds
, 0, BT_INTEGER
))
5313 if (!int_or_proc_check (handler
, 1))
5315 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5321 if (!scalar_check (status
, 2))
5323 if (!type_check (status
, 2, BT_INTEGER
))
5325 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5333 gfc_check_rand (gfc_expr
*x
)
5338 if (!scalar_check (x
, 0))
5341 if (!type_check (x
, 0, BT_INTEGER
))
5344 if (!kind_value_check (x
, 0, 4))
5352 gfc_check_srand (gfc_expr
*x
)
5354 if (!scalar_check (x
, 0))
5357 if (!type_check (x
, 0, BT_INTEGER
))
5360 if (!kind_value_check (x
, 0, 4))
5368 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5370 if (!scalar_check (time
, 0))
5372 if (!type_check (time
, 0, BT_INTEGER
))
5375 if (!type_check (result
, 1, BT_CHARACTER
))
5377 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5385 gfc_check_dtime_etime (gfc_expr
*x
)
5387 if (!array_check (x
, 0))
5390 if (!rank_check (x
, 0, 1))
5393 if (!variable_check (x
, 0, false))
5396 if (!type_check (x
, 0, BT_REAL
))
5399 if (!kind_value_check (x
, 0, 4))
5407 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5409 if (!array_check (values
, 0))
5412 if (!rank_check (values
, 0, 1))
5415 if (!variable_check (values
, 0, false))
5418 if (!type_check (values
, 0, BT_REAL
))
5421 if (!kind_value_check (values
, 0, 4))
5424 if (!scalar_check (time
, 1))
5427 if (!type_check (time
, 1, BT_REAL
))
5430 if (!kind_value_check (time
, 1, 4))
5438 gfc_check_fdate_sub (gfc_expr
*date
)
5440 if (!type_check (date
, 0, BT_CHARACTER
))
5442 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5450 gfc_check_gerror (gfc_expr
*msg
)
5452 if (!type_check (msg
, 0, BT_CHARACTER
))
5454 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5462 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5464 if (!type_check (cwd
, 0, BT_CHARACTER
))
5466 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5472 if (!scalar_check (status
, 1))
5475 if (!type_check (status
, 1, BT_INTEGER
))
5483 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5485 if (!type_check (pos
, 0, BT_INTEGER
))
5488 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5490 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
5491 "not wider than the default kind (%d)",
5492 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5493 &pos
->where
, gfc_default_integer_kind
);
5497 if (!type_check (value
, 1, BT_CHARACTER
))
5499 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
5507 gfc_check_getlog (gfc_expr
*msg
)
5509 if (!type_check (msg
, 0, BT_CHARACTER
))
5511 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5519 gfc_check_exit (gfc_expr
*status
)
5524 if (!type_check (status
, 0, BT_INTEGER
))
5527 if (!scalar_check (status
, 0))
5535 gfc_check_flush (gfc_expr
*unit
)
5540 if (!type_check (unit
, 0, BT_INTEGER
))
5543 if (!scalar_check (unit
, 0))
5551 gfc_check_free (gfc_expr
*i
)
5553 if (!type_check (i
, 0, BT_INTEGER
))
5556 if (!scalar_check (i
, 0))
5564 gfc_check_hostnm (gfc_expr
*name
)
5566 if (!type_check (name
, 0, BT_CHARACTER
))
5568 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5576 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
5578 if (!type_check (name
, 0, BT_CHARACTER
))
5580 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5586 if (!scalar_check (status
, 1))
5589 if (!type_check (status
, 1, BT_INTEGER
))
5597 gfc_check_itime_idate (gfc_expr
*values
)
5599 if (!array_check (values
, 0))
5602 if (!rank_check (values
, 0, 1))
5605 if (!variable_check (values
, 0, false))
5608 if (!type_check (values
, 0, BT_INTEGER
))
5611 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
5619 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
5621 if (!type_check (time
, 0, BT_INTEGER
))
5624 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
5627 if (!scalar_check (time
, 0))
5630 if (!array_check (values
, 1))
5633 if (!rank_check (values
, 1, 1))
5636 if (!variable_check (values
, 1, false))
5639 if (!type_check (values
, 1, BT_INTEGER
))
5642 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
5650 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
5652 if (!scalar_check (unit
, 0))
5655 if (!type_check (unit
, 0, BT_INTEGER
))
5658 if (!type_check (name
, 1, BT_CHARACTER
))
5660 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
5668 gfc_check_isatty (gfc_expr
*unit
)
5673 if (!type_check (unit
, 0, BT_INTEGER
))
5676 if (!scalar_check (unit
, 0))
5684 gfc_check_isnan (gfc_expr
*x
)
5686 if (!type_check (x
, 0, BT_REAL
))
5694 gfc_check_perror (gfc_expr
*string
)
5696 if (!type_check (string
, 0, BT_CHARACTER
))
5698 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
5706 gfc_check_umask (gfc_expr
*mask
)
5708 if (!type_check (mask
, 0, BT_INTEGER
))
5711 if (!scalar_check (mask
, 0))
5719 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
5721 if (!type_check (mask
, 0, BT_INTEGER
))
5724 if (!scalar_check (mask
, 0))
5730 if (!scalar_check (old
, 1))
5733 if (!type_check (old
, 1, BT_INTEGER
))
5741 gfc_check_unlink (gfc_expr
*name
)
5743 if (!type_check (name
, 0, BT_CHARACTER
))
5745 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5753 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
5755 if (!type_check (name
, 0, BT_CHARACTER
))
5757 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5763 if (!scalar_check (status
, 1))
5766 if (!type_check (status
, 1, BT_INTEGER
))
5774 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
5776 if (!scalar_check (number
, 0))
5778 if (!type_check (number
, 0, BT_INTEGER
))
5781 if (!int_or_proc_check (handler
, 1))
5783 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5791 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
5793 if (!scalar_check (number
, 0))
5795 if (!type_check (number
, 0, BT_INTEGER
))
5798 if (!int_or_proc_check (handler
, 1))
5800 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5806 if (!type_check (status
, 2, BT_INTEGER
))
5808 if (!scalar_check (status
, 2))
5816 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
5818 if (!type_check (cmd
, 0, BT_CHARACTER
))
5820 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
5823 if (!scalar_check (status
, 1))
5826 if (!type_check (status
, 1, BT_INTEGER
))
5829 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
5836 /* This is used for the GNU intrinsics AND, OR and XOR. */
5838 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
5840 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
5842 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5843 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
5844 gfc_current_intrinsic
, &i
->where
);
5848 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
5850 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5851 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
5852 gfc_current_intrinsic
, &j
->where
);
5856 if (i
->ts
.type
!= j
->ts
.type
)
5858 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5859 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
5860 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5865 if (!scalar_check (i
, 0))
5868 if (!scalar_check (j
, 1))
5876 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
5878 if (a
->ts
.type
== BT_ASSUMED
)
5880 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
5881 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5886 if (a
->ts
.type
== BT_PROCEDURE
)
5888 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
5889 "procedure", gfc_current_intrinsic_arg
[0]->name
,
5890 gfc_current_intrinsic
, &a
->where
);
5897 if (!type_check (kind
, 1, BT_INTEGER
))
5900 if (!scalar_check (kind
, 1))
5903 if (kind
->expr_type
!= EXPR_CONSTANT
)
5905 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5906 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,