2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs 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(%qs)",
315 &expr2
->where
, arg1
);
322 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
324 gfc_error ("%qs at %L must be less than "
325 "or equal to BIT_SIZE(%qs)",
326 arg2
, &expr2
->where
, arg1
);
332 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
334 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
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 ("%qs 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 ("%qs argument of %qs intrinsic at %L must be the same type "
406 "and kind as %qs", 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 %qs 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 %qs 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 ("%qs and %qs arguments of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 ("%qs argument of %qs 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 %qs 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
, int atom_no
, gfc_expr
*value
, int val_no
,
1010 gfc_expr
*stat
, int stat_no
)
1012 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1015 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1016 && !(atom
->ts
.type
== BT_LOGICAL
1017 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1019 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1020 "integer of ATOMIC_INT_KIND or a logical of "
1021 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1025 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1027 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1028 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1032 if (atom
->ts
.type
!= value
->ts
.type
)
1034 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1035 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1036 gfc_current_intrinsic
, &value
->where
,
1037 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1043 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1045 if (!scalar_check (stat
, stat_no
))
1047 if (!variable_check (stat
, stat_no
, false))
1049 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1052 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1053 gfc_current_intrinsic
, &stat
->where
))
1062 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1064 if (atom
->expr_type
== EXPR_FUNCTION
1065 && atom
->value
.function
.isym
1066 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1067 atom
= atom
->value
.function
.actual
->expr
;
1069 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1071 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1072 "definable", gfc_current_intrinsic
, &atom
->where
);
1076 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1081 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1083 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1085 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1086 "integer of ATOMIC_INT_KIND", &atom
->where
,
1087 gfc_current_intrinsic
);
1091 return gfc_check_atomic_def (atom
, value
, stat
);
1096 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1098 if (atom
->expr_type
== EXPR_FUNCTION
1099 && atom
->value
.function
.isym
1100 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1101 atom
= atom
->value
.function
.actual
->expr
;
1103 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1105 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1106 "definable", gfc_current_intrinsic
, &value
->where
);
1110 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1115 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1116 gfc_expr
*new_val
, gfc_expr
*stat
)
1118 if (atom
->expr_type
== EXPR_FUNCTION
1119 && atom
->value
.function
.isym
1120 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1121 atom
= atom
->value
.function
.actual
->expr
;
1123 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1126 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1129 if (!same_type_check (atom
, 0, old
, 1))
1132 if (!same_type_check (atom
, 0, compare
, 2))
1135 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1137 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1138 "definable", gfc_current_intrinsic
, &atom
->where
);
1142 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1144 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1145 "definable", gfc_current_intrinsic
, &old
->where
);
1154 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1157 if (atom
->expr_type
== EXPR_FUNCTION
1158 && atom
->value
.function
.isym
1159 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1160 atom
= atom
->value
.function
.actual
->expr
;
1162 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1164 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1165 "integer of ATOMIC_INT_KIND", &atom
->where
,
1166 gfc_current_intrinsic
);
1170 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1173 if (!scalar_check (old
, 2))
1176 if (!same_type_check (atom
, 0, old
, 2))
1179 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1181 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1182 "definable", gfc_current_intrinsic
, &atom
->where
);
1186 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1188 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1189 "definable", gfc_current_intrinsic
, &old
->where
);
1197 /* BESJN and BESYN functions. */
1200 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1202 if (!type_check (n
, 0, BT_INTEGER
))
1204 if (n
->expr_type
== EXPR_CONSTANT
)
1207 gfc_extract_int (n
, &i
);
1208 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1209 "N at %L", &n
->where
))
1213 if (!type_check (x
, 1, BT_REAL
))
1220 /* Transformational version of the Bessel JN and YN functions. */
1223 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1225 if (!type_check (n1
, 0, BT_INTEGER
))
1227 if (!scalar_check (n1
, 0))
1229 if (!nonnegative_check ("N1", n1
))
1232 if (!type_check (n2
, 1, BT_INTEGER
))
1234 if (!scalar_check (n2
, 1))
1236 if (!nonnegative_check ("N2", n2
))
1239 if (!type_check (x
, 2, BT_REAL
))
1241 if (!scalar_check (x
, 2))
1249 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1251 if (!type_check (i
, 0, BT_INTEGER
))
1254 if (!type_check (j
, 1, BT_INTEGER
))
1262 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1264 if (!type_check (i
, 0, BT_INTEGER
))
1267 if (!type_check (pos
, 1, BT_INTEGER
))
1270 if (!nonnegative_check ("pos", pos
))
1273 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1281 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1283 if (!type_check (i
, 0, BT_INTEGER
))
1285 if (!kind_check (kind
, 1, BT_CHARACTER
))
1293 gfc_check_chdir (gfc_expr
*dir
)
1295 if (!type_check (dir
, 0, BT_CHARACTER
))
1297 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1305 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1307 if (!type_check (dir
, 0, BT_CHARACTER
))
1309 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1315 if (!type_check (status
, 1, BT_INTEGER
))
1317 if (!scalar_check (status
, 1))
1325 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1327 if (!type_check (name
, 0, BT_CHARACTER
))
1329 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1332 if (!type_check (mode
, 1, BT_CHARACTER
))
1334 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1342 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1344 if (!type_check (name
, 0, BT_CHARACTER
))
1346 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1349 if (!type_check (mode
, 1, BT_CHARACTER
))
1351 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1357 if (!type_check (status
, 2, BT_INTEGER
))
1360 if (!scalar_check (status
, 2))
1368 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1370 if (!numeric_check (x
, 0))
1375 if (!numeric_check (y
, 1))
1378 if (x
->ts
.type
== BT_COMPLEX
)
1380 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1381 "present if %<x%> is COMPLEX",
1382 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1387 if (y
->ts
.type
== BT_COMPLEX
)
1389 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1390 "of either REAL or INTEGER",
1391 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1398 if (!kind_check (kind
, 2, BT_COMPLEX
))
1401 if (!kind
&& warn_conversion
1402 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1403 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1404 "COMPLEX(%d) at %L might lose precision, consider using "
1405 "the KIND argument", gfc_typename (&x
->ts
),
1406 gfc_default_real_kind
, &x
->where
);
1407 else if (y
&& !kind
&& warn_conversion
1408 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1409 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1410 "COMPLEX(%d) at %L might lose precision, consider using "
1411 "the KIND argument", gfc_typename (&y
->ts
),
1412 gfc_default_real_kind
, &y
->where
);
1418 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1419 gfc_expr
*errmsg
, bool co_reduce
)
1421 if (!variable_check (a
, 0, false))
1424 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1428 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1429 if (gfc_has_vector_subscript (a
))
1431 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1432 "subroutine %s shall not have a vector subscript",
1433 &a
->where
, gfc_current_intrinsic
);
1437 if (gfc_is_coindexed (a
))
1439 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1440 "coindexed", &a
->where
, gfc_current_intrinsic
);
1444 if (image_idx
!= NULL
)
1446 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1448 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1454 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1456 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1458 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1460 if (stat
->ts
.kind
!= 4)
1462 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1463 "variable", &stat
->where
);
1470 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1472 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1474 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1476 if (errmsg
->ts
.kind
!= 1)
1478 gfc_error ("The errmsg= argument at %L must be a default-kind "
1479 "character variable", &errmsg
->where
);
1484 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1486 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1496 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1499 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1501 gfc_error ("Support for the A argument at %L which is polymorphic A "
1502 "argument or has allocatable components is not yet "
1503 "implemented", &a
->where
);
1506 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1511 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1512 gfc_expr
*stat
, gfc_expr
*errmsg
)
1514 symbol_attribute attr
;
1515 gfc_formal_arglist
*formal
;
1518 if (a
->ts
.type
== BT_CLASS
)
1520 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1525 if (gfc_expr_attr (a
).alloc_comp
)
1527 gfc_error ("Support for the A argument at %L with allocatable components"
1528 " is not yet implemented", &a
->where
);
1532 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1535 if (!gfc_resolve_expr (op
))
1538 attr
= gfc_expr_attr (op
);
1539 if (!attr
.pure
|| !attr
.function
)
1541 gfc_error ("OPERATOR argument at %L must be a PURE function",
1548 /* None of the intrinsics fulfills the criteria of taking two arguments,
1549 returning the same type and kind as the arguments and being permitted
1550 as actual argument. */
1551 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1552 op
->symtree
->n
.sym
->name
, &op
->where
);
1556 if (gfc_is_proc_ptr_comp (op
))
1558 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1559 sym
= comp
->ts
.interface
;
1562 sym
= op
->symtree
->n
.sym
;
1564 formal
= sym
->formal
;
1566 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1568 gfc_error ("The function passed as OPERATOR at %L shall have two "
1569 "arguments", &op
->where
);
1573 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1574 gfc_set_default_type (sym
->result
, 0, NULL
);
1576 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1578 gfc_error ("A argument at %L has type %s but the function passed as "
1579 "OPERATOR at %L returns %s",
1580 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1581 gfc_typename (&sym
->result
->ts
));
1584 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1585 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1587 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1588 "%s and %s but shall have type %s", &op
->where
,
1589 gfc_typename (&formal
->sym
->ts
),
1590 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1593 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1594 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1595 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1596 || formal
->next
->sym
->attr
.pointer
)
1598 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1599 "nonallocatable nonpointer arguments and return a "
1600 "nonallocatable nonpointer scalar", &op
->where
);
1604 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1606 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1607 "attribute either for none or both arguments", &op
->where
);
1611 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1613 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1614 "attribute either for none or both arguments", &op
->where
);
1618 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1620 gfc_error ("The function passed as OPERATOR at %L shall have the "
1621 "ASYNCHRONOUS attribute either for none or both arguments",
1626 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1628 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1629 "OPTIONAL attribute for either of the arguments", &op
->where
);
1633 if (a
->ts
.type
== BT_CHARACTER
)
1636 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1639 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1640 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1642 cl
= formal
->sym
->ts
.u
.cl
;
1643 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1644 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1646 cl
= formal
->next
->sym
->ts
.u
.cl
;
1647 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1648 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1651 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1652 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1655 && ((formal_size1
&& actual_size
!= formal_size1
)
1656 || (formal_size2
&& actual_size
!= formal_size2
)))
1658 gfc_error ("The character length of the A argument at %L and of the "
1659 "arguments of the OPERATOR at %L shall be the same",
1660 &a
->where
, &op
->where
);
1663 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1665 gfc_error ("The character length of the A argument at %L and of the "
1666 "function result of the OPERATOR at %L shall be the same",
1667 &a
->where
, &op
->where
);
1677 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1680 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1681 && a
->ts
.type
!= BT_CHARACTER
)
1683 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1684 "integer, real or character",
1685 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1689 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1694 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1697 if (!numeric_check (a
, 0))
1699 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1704 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1706 if (!int_or_real_check (x
, 0))
1708 if (!scalar_check (x
, 0))
1711 if (!int_or_real_check (y
, 1))
1713 if (!scalar_check (y
, 1))
1721 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1723 if (!logical_array_check (mask
, 0))
1725 if (!dim_check (dim
, 1, false))
1727 if (!dim_rank_check (dim
, mask
, 0))
1729 if (!kind_check (kind
, 2, BT_INTEGER
))
1731 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1732 "with KIND argument at %L",
1733 gfc_current_intrinsic
, &kind
->where
))
1741 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1743 if (!array_check (array
, 0))
1746 if (!type_check (shift
, 1, BT_INTEGER
))
1749 if (!dim_check (dim
, 2, true))
1752 if (!dim_rank_check (dim
, array
, false))
1755 if (array
->rank
== 1 || shift
->rank
== 0)
1757 if (!scalar_check (shift
, 1))
1760 else if (shift
->rank
== array
->rank
- 1)
1765 else if (dim
->expr_type
== EXPR_CONSTANT
)
1766 gfc_extract_int (dim
, &d
);
1773 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1776 if (!identical_dimen_shape (array
, i
, shift
, j
))
1778 gfc_error ("%qs argument of %qs intrinsic at %L has "
1779 "invalid shape in dimension %d (%ld/%ld)",
1780 gfc_current_intrinsic_arg
[1]->name
,
1781 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1782 mpz_get_si (array
->shape
[i
]),
1783 mpz_get_si (shift
->shape
[j
]));
1793 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
1794 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1795 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1804 gfc_check_ctime (gfc_expr
*time
)
1806 if (!scalar_check (time
, 0))
1809 if (!type_check (time
, 0, BT_INTEGER
))
1816 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1818 if (!double_check (y
, 0) || !double_check (x
, 1))
1825 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1827 if (!numeric_check (x
, 0))
1832 if (!numeric_check (y
, 1))
1835 if (x
->ts
.type
== BT_COMPLEX
)
1837 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1838 "present if %<x%> is COMPLEX",
1839 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1844 if (y
->ts
.type
== BT_COMPLEX
)
1846 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1847 "of either REAL or INTEGER",
1848 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1859 gfc_check_dble (gfc_expr
*x
)
1861 if (!numeric_check (x
, 0))
1869 gfc_check_digits (gfc_expr
*x
)
1871 if (!int_or_real_check (x
, 0))
1879 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1881 switch (vector_a
->ts
.type
)
1884 if (!type_check (vector_b
, 1, BT_LOGICAL
))
1891 if (!numeric_check (vector_b
, 1))
1896 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
1897 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1898 gfc_current_intrinsic
, &vector_a
->where
);
1902 if (!rank_check (vector_a
, 0, 1))
1905 if (!rank_check (vector_b
, 1, 1))
1908 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1910 gfc_error ("Different shape for arguments %qs and %qs at %L for "
1911 "intrinsic %<dot_product%>",
1912 gfc_current_intrinsic_arg
[0]->name
,
1913 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1922 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1924 if (!type_check (x
, 0, BT_REAL
)
1925 || !type_check (y
, 1, BT_REAL
))
1928 if (x
->ts
.kind
!= gfc_default_real_kind
)
1930 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
1931 "real", gfc_current_intrinsic_arg
[0]->name
,
1932 gfc_current_intrinsic
, &x
->where
);
1936 if (y
->ts
.kind
!= gfc_default_real_kind
)
1938 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
1939 "real", gfc_current_intrinsic_arg
[1]->name
,
1940 gfc_current_intrinsic
, &y
->where
);
1949 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1951 if (!type_check (i
, 0, BT_INTEGER
))
1954 if (!type_check (j
, 1, BT_INTEGER
))
1957 if (i
->is_boz
&& j
->is_boz
)
1959 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
1960 "constants", &i
->where
, &j
->where
);
1964 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
1967 if (!type_check (shift
, 2, BT_INTEGER
))
1970 if (!nonnegative_check ("SHIFT", shift
))
1975 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
1977 i
->ts
.kind
= j
->ts
.kind
;
1981 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
1983 j
->ts
.kind
= i
->ts
.kind
;
1991 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1994 if (!array_check (array
, 0))
1997 if (!type_check (shift
, 1, BT_INTEGER
))
2000 if (!dim_check (dim
, 3, true))
2003 if (!dim_rank_check (dim
, array
, false))
2006 if (array
->rank
== 1 || shift
->rank
== 0)
2008 if (!scalar_check (shift
, 1))
2011 else if (shift
->rank
== array
->rank
- 1)
2016 else if (dim
->expr_type
== EXPR_CONSTANT
)
2017 gfc_extract_int (dim
, &d
);
2024 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2027 if (!identical_dimen_shape (array
, i
, shift
, j
))
2029 gfc_error ("%qs argument of %qs intrinsic at %L has "
2030 "invalid shape in dimension %d (%ld/%ld)",
2031 gfc_current_intrinsic_arg
[1]->name
,
2032 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2033 mpz_get_si (array
->shape
[i
]),
2034 mpz_get_si (shift
->shape
[j
]));
2044 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2045 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2046 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2050 if (boundary
!= NULL
)
2052 if (!same_type_check (array
, 0, boundary
, 2))
2055 if (array
->rank
== 1 || boundary
->rank
== 0)
2057 if (!scalar_check (boundary
, 2))
2060 else if (boundary
->rank
== array
->rank
- 1)
2062 if (!gfc_check_conformance (shift
, boundary
,
2063 "arguments '%s' and '%s' for "
2065 gfc_current_intrinsic_arg
[1]->name
,
2066 gfc_current_intrinsic_arg
[2]->name
,
2067 gfc_current_intrinsic
))
2072 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2073 "rank %d or be a scalar",
2074 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2075 &shift
->where
, array
->rank
- 1);
2084 gfc_check_float (gfc_expr
*a
)
2086 if (!type_check (a
, 0, BT_INTEGER
))
2089 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2090 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2091 "kind argument to %s intrinsic at %L",
2092 gfc_current_intrinsic
, &a
->where
))
2098 /* A single complex argument. */
2101 gfc_check_fn_c (gfc_expr
*a
)
2103 if (!type_check (a
, 0, BT_COMPLEX
))
2109 /* A single real argument. */
2112 gfc_check_fn_r (gfc_expr
*a
)
2114 if (!type_check (a
, 0, BT_REAL
))
2120 /* A single double argument. */
2123 gfc_check_fn_d (gfc_expr
*a
)
2125 if (!double_check (a
, 0))
2131 /* A single real or complex argument. */
2134 gfc_check_fn_rc (gfc_expr
*a
)
2136 if (!real_or_complex_check (a
, 0))
2144 gfc_check_fn_rc2008 (gfc_expr
*a
)
2146 if (!real_or_complex_check (a
, 0))
2149 if (a
->ts
.type
== BT_COMPLEX
2150 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2151 "of %qs intrinsic at %L",
2152 gfc_current_intrinsic_arg
[0]->name
,
2153 gfc_current_intrinsic
, &a
->where
))
2161 gfc_check_fnum (gfc_expr
*unit
)
2163 if (!type_check (unit
, 0, BT_INTEGER
))
2166 if (!scalar_check (unit
, 0))
2174 gfc_check_huge (gfc_expr
*x
)
2176 if (!int_or_real_check (x
, 0))
2184 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2186 if (!type_check (x
, 0, BT_REAL
))
2188 if (!same_type_check (x
, 0, y
, 1))
2195 /* Check that the single argument is an integer. */
2198 gfc_check_i (gfc_expr
*i
)
2200 if (!type_check (i
, 0, BT_INTEGER
))
2208 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2210 if (!type_check (i
, 0, BT_INTEGER
))
2213 if (!type_check (j
, 1, BT_INTEGER
))
2216 if (i
->ts
.kind
!= j
->ts
.kind
)
2218 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2228 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2230 if (!type_check (i
, 0, BT_INTEGER
))
2233 if (!type_check (pos
, 1, BT_INTEGER
))
2236 if (!type_check (len
, 2, BT_INTEGER
))
2239 if (!nonnegative_check ("pos", pos
))
2242 if (!nonnegative_check ("len", len
))
2245 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2253 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2257 if (!type_check (c
, 0, BT_CHARACTER
))
2260 if (!kind_check (kind
, 1, BT_INTEGER
))
2263 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2264 "with KIND argument at %L",
2265 gfc_current_intrinsic
, &kind
->where
))
2268 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2274 /* Substring references don't have the charlength set. */
2276 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2279 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2283 /* Check that the argument is length one. Non-constant lengths
2284 can't be checked here, so assume they are ok. */
2285 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2287 /* If we already have a length for this expression then use it. */
2288 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2290 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2297 start
= ref
->u
.ss
.start
;
2298 end
= ref
->u
.ss
.end
;
2301 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2302 || start
->expr_type
!= EXPR_CONSTANT
)
2305 i
= mpz_get_si (end
->value
.integer
) + 1
2306 - mpz_get_si (start
->value
.integer
);
2314 gfc_error ("Argument of %s at %L must be of length one",
2315 gfc_current_intrinsic
, &c
->where
);
2324 gfc_check_idnint (gfc_expr
*a
)
2326 if (!double_check (a
, 0))
2334 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2336 if (!type_check (i
, 0, BT_INTEGER
))
2339 if (!type_check (j
, 1, BT_INTEGER
))
2342 if (i
->ts
.kind
!= j
->ts
.kind
)
2344 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2354 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2357 if (!type_check (string
, 0, BT_CHARACTER
)
2358 || !type_check (substring
, 1, BT_CHARACTER
))
2361 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2364 if (!kind_check (kind
, 3, BT_INTEGER
))
2366 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2367 "with KIND argument at %L",
2368 gfc_current_intrinsic
, &kind
->where
))
2371 if (string
->ts
.kind
!= substring
->ts
.kind
)
2373 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2374 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2375 gfc_current_intrinsic
, &substring
->where
,
2376 gfc_current_intrinsic_arg
[0]->name
);
2385 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2387 if (!numeric_check (x
, 0))
2390 if (!kind_check (kind
, 1, BT_INTEGER
))
2398 gfc_check_intconv (gfc_expr
*x
)
2400 if (!numeric_check (x
, 0))
2408 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2410 if (!type_check (i
, 0, BT_INTEGER
))
2413 if (!type_check (j
, 1, BT_INTEGER
))
2416 if (i
->ts
.kind
!= j
->ts
.kind
)
2418 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2428 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2430 if (!type_check (i
, 0, BT_INTEGER
)
2431 || !type_check (shift
, 1, BT_INTEGER
))
2434 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2442 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2444 if (!type_check (i
, 0, BT_INTEGER
)
2445 || !type_check (shift
, 1, BT_INTEGER
))
2452 if (!type_check (size
, 2, BT_INTEGER
))
2455 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2458 if (size
->expr_type
== EXPR_CONSTANT
)
2460 gfc_extract_int (size
, &i3
);
2463 gfc_error ("SIZE at %L must be positive", &size
->where
);
2467 if (shift
->expr_type
== EXPR_CONSTANT
)
2469 gfc_extract_int (shift
, &i2
);
2475 gfc_error ("The absolute value of SHIFT at %L must be less "
2476 "than or equal to SIZE at %L", &shift
->where
,
2483 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2491 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2493 if (!type_check (pid
, 0, BT_INTEGER
))
2496 if (!type_check (sig
, 1, BT_INTEGER
))
2504 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2506 if (!type_check (pid
, 0, BT_INTEGER
))
2509 if (!scalar_check (pid
, 0))
2512 if (!type_check (sig
, 1, BT_INTEGER
))
2515 if (!scalar_check (sig
, 1))
2521 if (!type_check (status
, 2, BT_INTEGER
))
2524 if (!scalar_check (status
, 2))
2532 gfc_check_kind (gfc_expr
*x
)
2534 if (x
->ts
.type
== BT_DERIVED
|| x
->ts
.type
== BT_CLASS
)
2536 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2537 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2538 gfc_current_intrinsic
, &x
->where
);
2541 if (x
->ts
.type
== BT_PROCEDURE
)
2543 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2544 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2554 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2556 if (!array_check (array
, 0))
2559 if (!dim_check (dim
, 1, false))
2562 if (!dim_rank_check (dim
, array
, 1))
2565 if (!kind_check (kind
, 2, BT_INTEGER
))
2567 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2568 "with KIND argument at %L",
2569 gfc_current_intrinsic
, &kind
->where
))
2577 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2579 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2581 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2585 if (!coarray_check (coarray
, 0))
2590 if (!dim_check (dim
, 1, false))
2593 if (!dim_corank_check (dim
, coarray
))
2597 if (!kind_check (kind
, 2, BT_INTEGER
))
2605 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2607 if (!type_check (s
, 0, BT_CHARACTER
))
2610 if (!kind_check (kind
, 1, BT_INTEGER
))
2612 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2613 "with KIND argument at %L",
2614 gfc_current_intrinsic
, &kind
->where
))
2622 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2624 if (!type_check (a
, 0, BT_CHARACTER
))
2626 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2629 if (!type_check (b
, 1, BT_CHARACTER
))
2631 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2639 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2641 if (!type_check (path1
, 0, BT_CHARACTER
))
2643 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2646 if (!type_check (path2
, 1, BT_CHARACTER
))
2648 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2656 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2658 if (!type_check (path1
, 0, BT_CHARACTER
))
2660 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2663 if (!type_check (path2
, 1, BT_CHARACTER
))
2665 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2671 if (!type_check (status
, 2, BT_INTEGER
))
2674 if (!scalar_check (status
, 2))
2682 gfc_check_loc (gfc_expr
*expr
)
2684 return variable_check (expr
, 0, true);
2689 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2691 if (!type_check (path1
, 0, BT_CHARACTER
))
2693 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2696 if (!type_check (path2
, 1, BT_CHARACTER
))
2698 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2706 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2708 if (!type_check (path1
, 0, BT_CHARACTER
))
2710 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2713 if (!type_check (path2
, 1, BT_CHARACTER
))
2715 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2721 if (!type_check (status
, 2, BT_INTEGER
))
2724 if (!scalar_check (status
, 2))
2732 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2734 if (!type_check (a
, 0, BT_LOGICAL
))
2736 if (!kind_check (kind
, 1, BT_LOGICAL
))
2743 /* Min/max family. */
2746 min_max_args (gfc_actual_arglist
*args
)
2748 gfc_actual_arglist
*arg
;
2749 int i
, j
, nargs
, *nlabels
, nlabelless
;
2750 bool a1
= false, a2
= false;
2752 if (args
== NULL
|| args
->next
== NULL
)
2754 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
2755 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2762 if (!args
->next
->name
)
2766 for (arg
= args
; arg
; arg
= arg
->next
)
2773 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2775 nlabels
= XALLOCAVEC (int, nargs
);
2776 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2782 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2784 n
= strtol (&arg
->name
[1], &endp
, 10);
2785 if (endp
[0] != '\0')
2789 if (n
<= nlabelless
)
2802 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
2803 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2804 gfc_current_intrinsic_where
);
2808 /* Check for duplicates. */
2809 for (i
= 0; i
< nargs
; i
++)
2810 for (j
= i
+ 1; j
< nargs
; j
++)
2811 if (nlabels
[i
] == nlabels
[j
])
2817 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
2818 &arg
->expr
->where
, gfc_current_intrinsic
);
2822 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
2823 &arg
->expr
->where
, gfc_current_intrinsic
);
2829 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2831 gfc_actual_arglist
*arg
, *tmp
;
2835 if (!min_max_args (arglist
))
2838 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2841 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2843 if (x
->ts
.type
== type
)
2845 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
2846 "kinds at %L", &x
->where
))
2851 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
2852 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2853 gfc_basic_typename (type
), kind
);
2858 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2859 if (!gfc_check_conformance (tmp
->expr
, x
,
2860 "arguments 'a%d' and 'a%d' for "
2861 "intrinsic '%s'", m
, n
,
2862 gfc_current_intrinsic
))
2871 gfc_check_min_max (gfc_actual_arglist
*arg
)
2875 if (!min_max_args (arg
))
2880 if (x
->ts
.type
== BT_CHARACTER
)
2882 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2883 "with CHARACTER argument at %L",
2884 gfc_current_intrinsic
, &x
->where
))
2887 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2889 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
2890 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2894 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2899 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2901 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2906 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2908 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2913 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2915 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2919 /* End of min/max family. */
2922 gfc_check_malloc (gfc_expr
*size
)
2924 if (!type_check (size
, 0, BT_INTEGER
))
2927 if (!scalar_check (size
, 0))
2935 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2937 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2939 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2940 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2941 gfc_current_intrinsic
, &matrix_a
->where
);
2945 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2947 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2948 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2949 gfc_current_intrinsic
, &matrix_b
->where
);
2953 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2954 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2956 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
2957 gfc_current_intrinsic
, &matrix_a
->where
,
2958 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2962 switch (matrix_a
->rank
)
2965 if (!rank_check (matrix_b
, 1, 2))
2967 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2968 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2970 gfc_error ("Different shape on dimension 1 for arguments %qs "
2971 "and %qs at %L for intrinsic matmul",
2972 gfc_current_intrinsic_arg
[0]->name
,
2973 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2979 if (matrix_b
->rank
!= 2)
2981 if (!rank_check (matrix_b
, 1, 1))
2984 /* matrix_b has rank 1 or 2 here. Common check for the cases
2985 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2986 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2987 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2989 gfc_error ("Different shape on dimension 2 for argument %qs and "
2990 "dimension 1 for argument %qs at %L for intrinsic "
2991 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2992 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2998 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
2999 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3000 gfc_current_intrinsic
, &matrix_a
->where
);
3008 /* Whoever came up with this interface was probably on something.
3009 The possibilities for the occupation of the second and third
3016 NULL MASK minloc(array, mask=m)
3019 I.e. in the case of minloc(array,mask), mask will be in the second
3020 position of the argument list and we'll have to fix that up. */
3023 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3025 gfc_expr
*a
, *m
, *d
;
3028 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
3032 m
= ap
->next
->next
->expr
;
3034 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3035 && ap
->next
->name
== NULL
)
3039 ap
->next
->expr
= NULL
;
3040 ap
->next
->next
->expr
= m
;
3043 if (!dim_check (d
, 1, false))
3046 if (!dim_rank_check (d
, a
, 0))
3049 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3053 && !gfc_check_conformance (a
, m
,
3054 "arguments '%s' and '%s' for intrinsic %s",
3055 gfc_current_intrinsic_arg
[0]->name
,
3056 gfc_current_intrinsic_arg
[2]->name
,
3057 gfc_current_intrinsic
))
3064 /* Similar to minloc/maxloc, the argument list might need to be
3065 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3066 difference is that MINLOC/MAXLOC take an additional KIND argument.
3067 The possibilities are:
3073 NULL MASK minval(array, mask=m)
3076 I.e. in the case of minval(array,mask), mask will be in the second
3077 position of the argument list and we'll have to fix that up. */
3080 check_reduction (gfc_actual_arglist
*ap
)
3082 gfc_expr
*a
, *m
, *d
;
3086 m
= ap
->next
->next
->expr
;
3088 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3089 && ap
->next
->name
== NULL
)
3093 ap
->next
->expr
= NULL
;
3094 ap
->next
->next
->expr
= m
;
3097 if (!dim_check (d
, 1, false))
3100 if (!dim_rank_check (d
, a
, 0))
3103 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3107 && !gfc_check_conformance (a
, m
,
3108 "arguments '%s' and '%s' for intrinsic %s",
3109 gfc_current_intrinsic_arg
[0]->name
,
3110 gfc_current_intrinsic_arg
[2]->name
,
3111 gfc_current_intrinsic
))
3119 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3121 if (!int_or_real_check (ap
->expr
, 0)
3122 || !array_check (ap
->expr
, 0))
3125 return check_reduction (ap
);
3130 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3132 if (!numeric_check (ap
->expr
, 0)
3133 || !array_check (ap
->expr
, 0))
3136 return check_reduction (ap
);
3140 /* For IANY, IALL and IPARITY. */
3143 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3147 if (!type_check (i
, 0, BT_INTEGER
))
3150 if (!nonnegative_check ("I", i
))
3153 if (!kind_check (kind
, 1, BT_INTEGER
))
3157 gfc_extract_int (kind
, &k
);
3159 k
= gfc_default_integer_kind
;
3161 if (!less_than_bitsizekind ("I", i
, k
))
3169 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3171 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3173 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3174 gfc_current_intrinsic_arg
[0]->name
,
3175 gfc_current_intrinsic
, &ap
->expr
->where
);
3179 if (!array_check (ap
->expr
, 0))
3182 return check_reduction (ap
);
3187 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3189 if (!same_type_check (tsource
, 0, fsource
, 1))
3192 if (!type_check (mask
, 2, BT_LOGICAL
))
3195 if (tsource
->ts
.type
== BT_CHARACTER
)
3196 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3203 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3205 if (!type_check (i
, 0, BT_INTEGER
))
3208 if (!type_check (j
, 1, BT_INTEGER
))
3211 if (!type_check (mask
, 2, BT_INTEGER
))
3214 if (!same_type_check (i
, 0, j
, 1))
3217 if (!same_type_check (i
, 0, mask
, 2))
3225 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3227 if (!variable_check (from
, 0, false))
3229 if (!allocatable_check (from
, 0))
3231 if (gfc_is_coindexed (from
))
3233 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3234 "coindexed", &from
->where
);
3238 if (!variable_check (to
, 1, false))
3240 if (!allocatable_check (to
, 1))
3242 if (gfc_is_coindexed (to
))
3244 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3245 "coindexed", &to
->where
);
3249 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3251 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3252 "polymorphic if FROM is polymorphic",
3257 if (!same_type_check (to
, 1, from
, 0))
3260 if (to
->rank
!= from
->rank
)
3262 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3263 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3268 /* IR F08/0040; cf. 12-006A. */
3269 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3271 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3272 "must have the same corank %d/%d", &to
->where
,
3273 gfc_get_corank (from
), gfc_get_corank (to
));
3277 /* CLASS arguments: Make sure the vtab of from is present. */
3278 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3279 gfc_find_vtab (&from
->ts
);
3286 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3288 if (!type_check (x
, 0, BT_REAL
))
3291 if (!type_check (s
, 1, BT_REAL
))
3294 if (s
->expr_type
== EXPR_CONSTANT
)
3296 if (mpfr_sgn (s
->value
.real
) == 0)
3298 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3309 gfc_check_new_line (gfc_expr
*a
)
3311 if (!type_check (a
, 0, BT_CHARACTER
))
3319 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3321 if (!type_check (array
, 0, BT_REAL
))
3324 if (!array_check (array
, 0))
3327 if (!dim_rank_check (dim
, array
, false))
3334 gfc_check_null (gfc_expr
*mold
)
3336 symbol_attribute attr
;
3341 if (!variable_check (mold
, 0, true))
3344 attr
= gfc_variable_attr (mold
, NULL
);
3346 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3348 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3349 "ALLOCATABLE or procedure pointer",
3350 gfc_current_intrinsic_arg
[0]->name
,
3351 gfc_current_intrinsic
, &mold
->where
);
3355 if (attr
.allocatable
3356 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3357 "allocatable MOLD at %L", &mold
->where
))
3361 if (gfc_is_coindexed (mold
))
3363 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3364 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3365 gfc_current_intrinsic
, &mold
->where
);
3374 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3376 if (!array_check (array
, 0))
3379 if (!type_check (mask
, 1, BT_LOGICAL
))
3382 if (!gfc_check_conformance (array
, mask
,
3383 "arguments '%s' and '%s' for intrinsic '%s'",
3384 gfc_current_intrinsic_arg
[0]->name
,
3385 gfc_current_intrinsic_arg
[1]->name
,
3386 gfc_current_intrinsic
))
3391 mpz_t array_size
, vector_size
;
3392 bool have_array_size
, have_vector_size
;
3394 if (!same_type_check (array
, 0, vector
, 2))
3397 if (!rank_check (vector
, 2, 1))
3400 /* VECTOR requires at least as many elements as MASK
3401 has .TRUE. values. */
3402 have_array_size
= gfc_array_size(array
, &array_size
);
3403 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3405 if (have_vector_size
3406 && (mask
->expr_type
== EXPR_ARRAY
3407 || (mask
->expr_type
== EXPR_CONSTANT
3408 && have_array_size
)))
3410 int mask_true_values
= 0;
3412 if (mask
->expr_type
== EXPR_ARRAY
)
3414 gfc_constructor
*mask_ctor
;
3415 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3418 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3420 mask_true_values
= 0;
3424 if (mask_ctor
->expr
->value
.logical
)
3427 mask_ctor
= gfc_constructor_next (mask_ctor
);
3430 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3431 mask_true_values
= mpz_get_si (array_size
);
3433 if (mpz_get_si (vector_size
) < mask_true_values
)
3435 gfc_error ("%qs argument of %qs intrinsic at %L must "
3436 "provide at least as many elements as there "
3437 "are .TRUE. values in %qs (%ld/%d)",
3438 gfc_current_intrinsic_arg
[2]->name
,
3439 gfc_current_intrinsic
, &vector
->where
,
3440 gfc_current_intrinsic_arg
[1]->name
,
3441 mpz_get_si (vector_size
), mask_true_values
);
3446 if (have_array_size
)
3447 mpz_clear (array_size
);
3448 if (have_vector_size
)
3449 mpz_clear (vector_size
);
3457 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3459 if (!type_check (mask
, 0, BT_LOGICAL
))
3462 if (!array_check (mask
, 0))
3465 if (!dim_rank_check (dim
, mask
, false))
3473 gfc_check_precision (gfc_expr
*x
)
3475 if (!real_or_complex_check (x
, 0))
3483 gfc_check_present (gfc_expr
*a
)
3487 if (!variable_check (a
, 0, true))
3490 sym
= a
->symtree
->n
.sym
;
3491 if (!sym
->attr
.dummy
)
3493 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3494 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3495 gfc_current_intrinsic
, &a
->where
);
3499 if (!sym
->attr
.optional
)
3501 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3502 "an OPTIONAL dummy variable",
3503 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3508 /* 13.14.82 PRESENT(A)
3510 Argument. A shall be the name of an optional dummy argument that is
3511 accessible in the subprogram in which the PRESENT function reference
3515 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3516 && (a
->ref
->u
.ar
.type
== AR_FULL
3517 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3518 && a
->ref
->u
.ar
.as
->rank
== 0))))
3520 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3521 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3522 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3531 gfc_check_radix (gfc_expr
*x
)
3533 if (!int_or_real_check (x
, 0))
3541 gfc_check_range (gfc_expr
*x
)
3543 if (!numeric_check (x
, 0))
3551 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3553 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3554 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3556 bool is_variable
= true;
3558 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3559 if (a
->expr_type
== EXPR_FUNCTION
)
3560 is_variable
= a
->value
.function
.esym
3561 ? a
->value
.function
.esym
->result
->attr
.pointer
3562 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3564 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3565 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3568 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3569 "object", &a
->where
);
3577 /* real, float, sngl. */
3579 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3581 if (!numeric_check (a
, 0))
3584 if (!kind_check (kind
, 1, BT_REAL
))
3592 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3594 if (!type_check (path1
, 0, BT_CHARACTER
))
3596 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3599 if (!type_check (path2
, 1, BT_CHARACTER
))
3601 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3609 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3611 if (!type_check (path1
, 0, BT_CHARACTER
))
3613 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3616 if (!type_check (path2
, 1, BT_CHARACTER
))
3618 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3624 if (!type_check (status
, 2, BT_INTEGER
))
3627 if (!scalar_check (status
, 2))
3635 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3637 if (!type_check (x
, 0, BT_CHARACTER
))
3640 if (!scalar_check (x
, 0))
3643 if (!type_check (y
, 0, BT_INTEGER
))
3646 if (!scalar_check (y
, 1))
3654 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3655 gfc_expr
*pad
, gfc_expr
*order
)
3661 if (!array_check (source
, 0))
3664 if (!rank_check (shape
, 1, 1))
3667 if (!type_check (shape
, 1, BT_INTEGER
))
3670 if (!gfc_array_size (shape
, &size
))
3672 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3673 "array of constant size", &shape
->where
);
3677 shape_size
= mpz_get_ui (size
);
3680 if (shape_size
<= 0)
3682 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3683 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3687 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3689 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
3690 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3693 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3697 for (i
= 0; i
< shape_size
; ++i
)
3699 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3700 if (e
->expr_type
!= EXPR_CONSTANT
)
3703 gfc_extract_int (e
, &extent
);
3706 gfc_error ("%qs argument of %qs intrinsic at %L has "
3707 "negative element (%d)",
3708 gfc_current_intrinsic_arg
[1]->name
,
3709 gfc_current_intrinsic
, &e
->where
, extent
);
3714 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
3715 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
3716 && shape
->ref
->u
.ar
.as
3717 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
3718 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
3719 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
3720 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
3721 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
3726 v
= shape
->symtree
->n
.sym
->value
;
3728 for (i
= 0; i
< shape_size
; i
++)
3730 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
3734 gfc_extract_int (e
, &extent
);
3738 gfc_error ("Element %d of actual argument of RESHAPE at %L "
3739 "cannot be negative", i
+ 1, &shape
->where
);
3747 if (!same_type_check (source
, 0, pad
, 2))
3750 if (!array_check (pad
, 2))
3756 if (!array_check (order
, 3))
3759 if (!type_check (order
, 3, BT_INTEGER
))
3762 if (order
->expr_type
== EXPR_ARRAY
)
3764 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3767 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3770 gfc_array_size (order
, &size
);
3771 order_size
= mpz_get_ui (size
);
3774 if (order_size
!= shape_size
)
3776 gfc_error ("%qs argument of %qs intrinsic at %L "
3777 "has wrong number of elements (%d/%d)",
3778 gfc_current_intrinsic_arg
[3]->name
,
3779 gfc_current_intrinsic
, &order
->where
,
3780 order_size
, shape_size
);
3784 for (i
= 1; i
<= order_size
; ++i
)
3786 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3787 if (e
->expr_type
!= EXPR_CONSTANT
)
3790 gfc_extract_int (e
, &dim
);
3792 if (dim
< 1 || dim
> order_size
)
3794 gfc_error ("%qs argument of %qs intrinsic at %L "
3795 "has out-of-range dimension (%d)",
3796 gfc_current_intrinsic_arg
[3]->name
,
3797 gfc_current_intrinsic
, &e
->where
, dim
);
3801 if (perm
[dim
-1] != 0)
3803 gfc_error ("%qs argument of %qs intrinsic at %L has "
3804 "invalid permutation of dimensions (dimension "
3805 "%<%d%> duplicated)",
3806 gfc_current_intrinsic_arg
[3]->name
,
3807 gfc_current_intrinsic
, &e
->where
, dim
);
3816 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3817 && gfc_is_constant_expr (shape
)
3818 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3819 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3821 /* Check the match in size between source and destination. */
3822 if (gfc_array_size (source
, &nelems
))
3828 mpz_init_set_ui (size
, 1);
3829 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3830 c
; c
= gfc_constructor_next (c
))
3831 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3833 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3839 gfc_error ("Without padding, there are not enough elements "
3840 "in the intrinsic RESHAPE source at %L to match "
3841 "the shape", &source
->where
);
3852 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3854 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3856 gfc_error ("%qs argument of %qs intrinsic at %L "
3857 "cannot be of type %s",
3858 gfc_current_intrinsic_arg
[0]->name
,
3859 gfc_current_intrinsic
,
3860 &a
->where
, gfc_typename (&a
->ts
));
3864 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3866 gfc_error ("%qs argument of %qs intrinsic at %L "
3867 "must be of an extensible type",
3868 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3873 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3875 gfc_error ("%qs argument of %qs intrinsic at %L "
3876 "cannot be of type %s",
3877 gfc_current_intrinsic_arg
[0]->name
,
3878 gfc_current_intrinsic
,
3879 &b
->where
, gfc_typename (&b
->ts
));
3883 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3885 gfc_error ("%qs argument of %qs intrinsic at %L "
3886 "must be of an extensible type",
3887 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3897 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3899 if (!type_check (x
, 0, BT_REAL
))
3902 if (!type_check (i
, 1, BT_INTEGER
))
3910 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3912 if (!type_check (x
, 0, BT_CHARACTER
))
3915 if (!type_check (y
, 1, BT_CHARACTER
))
3918 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
3921 if (!kind_check (kind
, 3, BT_INTEGER
))
3923 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3924 "with KIND argument at %L",
3925 gfc_current_intrinsic
, &kind
->where
))
3928 if (!same_type_check (x
, 0, y
, 1))
3936 gfc_check_secnds (gfc_expr
*r
)
3938 if (!type_check (r
, 0, BT_REAL
))
3941 if (!kind_value_check (r
, 0, 4))
3944 if (!scalar_check (r
, 0))
3952 gfc_check_selected_char_kind (gfc_expr
*name
)
3954 if (!type_check (name
, 0, BT_CHARACTER
))
3957 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
3960 if (!scalar_check (name
, 0))
3968 gfc_check_selected_int_kind (gfc_expr
*r
)
3970 if (!type_check (r
, 0, BT_INTEGER
))
3973 if (!scalar_check (r
, 0))
3981 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3983 if (p
== NULL
&& r
== NULL
3984 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
3985 " neither %<P%> nor %<R%> argument at %L",
3986 gfc_current_intrinsic_where
))
3991 if (!type_check (p
, 0, BT_INTEGER
))
3994 if (!scalar_check (p
, 0))
4000 if (!type_check (r
, 1, BT_INTEGER
))
4003 if (!scalar_check (r
, 1))
4009 if (!type_check (radix
, 1, BT_INTEGER
))
4012 if (!scalar_check (radix
, 1))
4015 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4016 "RADIX argument at %L", gfc_current_intrinsic
,
4026 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4028 if (!type_check (x
, 0, BT_REAL
))
4031 if (!type_check (i
, 1, BT_INTEGER
))
4039 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4043 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4046 ar
= gfc_find_array_ref (source
);
4048 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4050 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4051 "an assumed size array", &source
->where
);
4055 if (!kind_check (kind
, 1, BT_INTEGER
))
4057 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4058 "with KIND argument at %L",
4059 gfc_current_intrinsic
, &kind
->where
))
4067 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4069 if (!type_check (i
, 0, BT_INTEGER
))
4072 if (!type_check (shift
, 0, BT_INTEGER
))
4075 if (!nonnegative_check ("SHIFT", shift
))
4078 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4086 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4088 if (!int_or_real_check (a
, 0))
4091 if (!same_type_check (a
, 0, b
, 1))
4099 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4101 if (!array_check (array
, 0))
4104 if (!dim_check (dim
, 1, true))
4107 if (!dim_rank_check (dim
, array
, 0))
4110 if (!kind_check (kind
, 2, BT_INTEGER
))
4112 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4113 "with KIND argument at %L",
4114 gfc_current_intrinsic
, &kind
->where
))
4123 gfc_check_sizeof (gfc_expr
*arg
)
4125 if (arg
->ts
.type
== BT_PROCEDURE
)
4127 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4128 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4133 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4134 if (arg
->ts
.type
== BT_ASSUMED
4135 && (arg
->symtree
->n
.sym
->as
== NULL
4136 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4137 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4138 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4140 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4141 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4146 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4147 && arg
->symtree
->n
.sym
->as
!= NULL
4148 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4149 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4151 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4152 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4153 gfc_current_intrinsic
, &arg
->where
);
4161 /* Check whether an expression is interoperable. When returning false,
4162 msg is set to a string telling why the expression is not interoperable,
4163 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4164 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4165 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4166 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4170 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4174 if (expr
->ts
.type
== BT_CLASS
)
4176 *msg
= "Expression is polymorphic";
4180 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4181 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4183 *msg
= "Expression is a noninteroperable derived type";
4187 if (expr
->ts
.type
== BT_PROCEDURE
)
4189 *msg
= "Procedure unexpected as argument";
4193 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4196 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4197 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4199 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4203 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4204 && expr
->ts
.kind
!= 1)
4206 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4210 if (expr
->ts
.type
== BT_CHARACTER
) {
4211 if (expr
->ts
.deferred
)
4213 /* TS 29113 allows deferred-length strings as dummy arguments,
4214 but it is not an interoperable type. */
4215 *msg
= "Expression shall not be a deferred-length string";
4219 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4220 && !gfc_simplify_expr (expr
, 0))
4221 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4223 if (!c_loc
&& expr
->ts
.u
.cl
4224 && (!expr
->ts
.u
.cl
->length
4225 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4226 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4228 *msg
= "Type shall have a character length of 1";
4233 /* Note: The following checks are about interoperatable variables, Fortran
4234 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4235 is allowed, e.g. assumed-shape arrays with TS 29113. */
4237 if (gfc_is_coarray (expr
))
4239 *msg
= "Coarrays are not interoperable";
4243 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4245 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4246 if (ar
->type
!= AR_FULL
)
4248 *msg
= "Only whole-arrays are interoperable";
4251 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4252 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4254 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4264 gfc_check_c_sizeof (gfc_expr
*arg
)
4268 if (!is_c_interoperable (arg
, &msg
, false, false))
4270 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4271 "interoperable data entity: %s",
4272 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4277 if (arg
->ts
.type
== BT_ASSUMED
)
4279 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4281 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4286 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4287 && arg
->symtree
->n
.sym
->as
!= NULL
4288 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4289 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4291 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4292 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4293 gfc_current_intrinsic
, &arg
->where
);
4302 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4304 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4305 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4306 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4307 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4309 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4310 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4314 if (!scalar_check (c_ptr_1
, 0))
4318 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4319 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4320 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4321 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4323 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4324 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4325 gfc_typename (&c_ptr_1
->ts
),
4326 gfc_typename (&c_ptr_2
->ts
));
4330 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4338 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4340 symbol_attribute attr
;
4343 if (cptr
->ts
.type
!= BT_DERIVED
4344 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4345 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4347 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4348 "type TYPE(C_PTR)", &cptr
->where
);
4352 if (!scalar_check (cptr
, 0))
4355 attr
= gfc_expr_attr (fptr
);
4359 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4364 if (fptr
->ts
.type
== BT_CLASS
)
4366 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4371 if (gfc_is_coindexed (fptr
))
4373 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4374 "coindexed", &fptr
->where
);
4378 if (fptr
->rank
== 0 && shape
)
4380 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4381 "FPTR", &fptr
->where
);
4384 else if (fptr
->rank
&& !shape
)
4386 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4387 "FPTR at %L", &fptr
->where
);
4391 if (shape
&& !rank_check (shape
, 2, 1))
4394 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4400 if (gfc_array_size (shape
, &size
))
4402 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4405 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4406 "size as the RANK of FPTR", &shape
->where
);
4413 if (fptr
->ts
.type
== BT_CLASS
)
4415 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4419 if (!is_c_interoperable (fptr
, &msg
, false, true))
4420 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4421 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4428 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4430 symbol_attribute attr
;
4432 if (cptr
->ts
.type
!= BT_DERIVED
4433 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4434 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4436 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4437 "type TYPE(C_FUNPTR)", &cptr
->where
);
4441 if (!scalar_check (cptr
, 0))
4444 attr
= gfc_expr_attr (fptr
);
4446 if (!attr
.proc_pointer
)
4448 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4449 "pointer", &fptr
->where
);
4453 if (gfc_is_coindexed (fptr
))
4455 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4456 "coindexed", &fptr
->where
);
4460 if (!attr
.is_bind_c
)
4461 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4462 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4469 gfc_check_c_funloc (gfc_expr
*x
)
4471 symbol_attribute attr
;
4473 if (gfc_is_coindexed (x
))
4475 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4476 "coindexed", &x
->where
);
4480 attr
= gfc_expr_attr (x
);
4482 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4483 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4485 gfc_namespace
*ns
= gfc_current_ns
;
4487 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4488 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4490 gfc_error ("Function result %qs at %L is invalid as X argument "
4491 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4496 if (attr
.flavor
!= FL_PROCEDURE
)
4498 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4499 "or a procedure pointer", &x
->where
);
4503 if (!attr
.is_bind_c
)
4504 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4505 "at %L to C_FUNLOC", &x
->where
);
4511 gfc_check_c_loc (gfc_expr
*x
)
4513 symbol_attribute attr
;
4516 if (gfc_is_coindexed (x
))
4518 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4522 if (x
->ts
.type
== BT_CLASS
)
4524 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4529 attr
= gfc_expr_attr (x
);
4532 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4533 || attr
.flavor
== FL_PARAMETER
))
4535 gfc_error ("Argument X at %L to C_LOC shall have either "
4536 "the POINTER or the TARGET attribute", &x
->where
);
4540 if (x
->ts
.type
== BT_CHARACTER
4541 && gfc_var_strlen (x
) == 0)
4543 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4544 "string", &x
->where
);
4548 if (!is_c_interoperable (x
, &msg
, true, false))
4550 if (x
->ts
.type
== BT_CLASS
)
4552 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4558 && !gfc_notify_std (GFC_STD_F2008_TS
,
4559 "Noninteroperable array at %L as"
4560 " argument to C_LOC: %s", &x
->where
, msg
))
4563 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4565 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4567 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4568 && !attr
.allocatable
4569 && !gfc_notify_std (GFC_STD_F2008
,
4570 "Array of interoperable type at %L "
4571 "to C_LOC which is nonallocatable and neither "
4572 "assumed size nor explicit size", &x
->where
))
4574 else if (ar
->type
!= AR_FULL
4575 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4576 "to C_LOC", &x
->where
))
4585 gfc_check_sleep_sub (gfc_expr
*seconds
)
4587 if (!type_check (seconds
, 0, BT_INTEGER
))
4590 if (!scalar_check (seconds
, 0))
4597 gfc_check_sngl (gfc_expr
*a
)
4599 if (!type_check (a
, 0, BT_REAL
))
4602 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4603 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4604 "REAL argument to %s intrinsic at %L",
4605 gfc_current_intrinsic
, &a
->where
))
4612 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4614 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4616 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4617 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4618 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4626 if (!dim_check (dim
, 1, false))
4629 /* dim_rank_check() does not apply here. */
4631 && dim
->expr_type
== EXPR_CONSTANT
4632 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4633 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4635 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4636 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4637 gfc_current_intrinsic
, &dim
->where
);
4641 if (!type_check (ncopies
, 2, BT_INTEGER
))
4644 if (!scalar_check (ncopies
, 2))
4651 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4655 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4657 if (!type_check (unit
, 0, BT_INTEGER
))
4660 if (!scalar_check (unit
, 0))
4663 if (!type_check (c
, 1, BT_CHARACTER
))
4665 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4671 if (!type_check (status
, 2, BT_INTEGER
)
4672 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4673 || !scalar_check (status
, 2))
4681 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4683 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4688 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4690 if (!type_check (c
, 0, BT_CHARACTER
))
4692 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4698 if (!type_check (status
, 1, BT_INTEGER
)
4699 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4700 || !scalar_check (status
, 1))
4708 gfc_check_fgetput (gfc_expr
*c
)
4710 return gfc_check_fgetput_sub (c
, NULL
);
4715 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4717 if (!type_check (unit
, 0, BT_INTEGER
))
4720 if (!scalar_check (unit
, 0))
4723 if (!type_check (offset
, 1, BT_INTEGER
))
4726 if (!scalar_check (offset
, 1))
4729 if (!type_check (whence
, 2, BT_INTEGER
))
4732 if (!scalar_check (whence
, 2))
4738 if (!type_check (status
, 3, BT_INTEGER
))
4741 if (!kind_value_check (status
, 3, 4))
4744 if (!scalar_check (status
, 3))
4753 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4755 if (!type_check (unit
, 0, BT_INTEGER
))
4758 if (!scalar_check (unit
, 0))
4761 if (!type_check (array
, 1, BT_INTEGER
)
4762 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4765 if (!array_check (array
, 1))
4773 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4775 if (!type_check (unit
, 0, BT_INTEGER
))
4778 if (!scalar_check (unit
, 0))
4781 if (!type_check (array
, 1, BT_INTEGER
)
4782 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4785 if (!array_check (array
, 1))
4791 if (!type_check (status
, 2, BT_INTEGER
)
4792 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4795 if (!scalar_check (status
, 2))
4803 gfc_check_ftell (gfc_expr
*unit
)
4805 if (!type_check (unit
, 0, BT_INTEGER
))
4808 if (!scalar_check (unit
, 0))
4816 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4818 if (!type_check (unit
, 0, BT_INTEGER
))
4821 if (!scalar_check (unit
, 0))
4824 if (!type_check (offset
, 1, BT_INTEGER
))
4827 if (!scalar_check (offset
, 1))
4835 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4837 if (!type_check (name
, 0, BT_CHARACTER
))
4839 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4842 if (!type_check (array
, 1, BT_INTEGER
)
4843 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4846 if (!array_check (array
, 1))
4854 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4856 if (!type_check (name
, 0, BT_CHARACTER
))
4858 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4861 if (!type_check (array
, 1, BT_INTEGER
)
4862 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4865 if (!array_check (array
, 1))
4871 if (!type_check (status
, 2, BT_INTEGER
)
4872 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4875 if (!scalar_check (status
, 2))
4883 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4887 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4889 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4893 if (!coarray_check (coarray
, 0))
4898 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4899 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
4903 if (gfc_array_size (sub
, &nelems
))
4905 int corank
= gfc_get_corank (coarray
);
4907 if (mpz_cmp_ui (nelems
, corank
) != 0)
4909 gfc_error ("The number of array elements of the SUB argument to "
4910 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4911 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
4923 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
4925 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4927 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4933 if (!type_check (distance
, 0, BT_INTEGER
))
4936 if (!nonnegative_check ("DISTANCE", distance
))
4939 if (!scalar_check (distance
, 0))
4942 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
4943 "NUM_IMAGES at %L", &distance
->where
))
4949 if (!type_check (failed
, 1, BT_LOGICAL
))
4952 if (!scalar_check (failed
, 1))
4955 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
4956 "NUM_IMAGES at %L", &distance
->where
))
4965 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
4967 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4969 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4973 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
4976 if (dim
!= NULL
&& coarray
== NULL
)
4978 gfc_error ("DIM argument without COARRAY argument not allowed for "
4979 "THIS_IMAGE intrinsic at %L", &dim
->where
);
4983 if (distance
&& (coarray
|| dim
))
4985 gfc_error ("The DISTANCE argument may not be specified together with the "
4986 "COARRAY or DIM argument in intrinsic at %L",
4991 /* Assume that we have "this_image (distance)". */
4992 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
4996 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5005 if (!type_check (distance
, 2, BT_INTEGER
))
5008 if (!nonnegative_check ("DISTANCE", distance
))
5011 if (!scalar_check (distance
, 2))
5014 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5015 "THIS_IMAGE at %L", &distance
->where
))
5021 if (!coarray_check (coarray
, 0))
5026 if (!dim_check (dim
, 1, false))
5029 if (!dim_corank_check (dim
, coarray
))
5036 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5037 by gfc_simplify_transfer. Return false if we cannot do so. */
5040 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5041 size_t *source_size
, size_t *result_size
,
5042 size_t *result_length_p
)
5044 size_t result_elt_size
;
5046 if (source
->expr_type
== EXPR_FUNCTION
)
5049 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5052 /* Calculate the size of the source. */
5053 *source_size
= gfc_target_expr_size (source
);
5054 if (*source_size
== 0)
5057 /* Determine the size of the element. */
5058 result_elt_size
= gfc_element_size (mold
);
5059 if (result_elt_size
== 0)
5062 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5067 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5070 result_length
= *source_size
/ result_elt_size
;
5071 if (result_length
* result_elt_size
< *source_size
)
5075 *result_size
= result_length
* result_elt_size
;
5076 if (result_length_p
)
5077 *result_length_p
= result_length
;
5080 *result_size
= result_elt_size
;
5087 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5092 if (mold
->ts
.type
== BT_HOLLERITH
)
5094 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5095 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5101 if (!type_check (size
, 2, BT_INTEGER
))
5104 if (!scalar_check (size
, 2))
5107 if (!nonoptional_check (size
, 2))
5111 if (!warn_surprising
)
5114 /* If we can't calculate the sizes, we cannot check any more.
5115 Return true for that case. */
5117 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5118 &result_size
, NULL
))
5121 if (source_size
< result_size
)
5122 gfc_warning (0, "Intrinsic TRANSFER at %L has partly undefined result: "
5123 "source size %ld < result size %ld", &source
->where
,
5124 (long) source_size
, (long) result_size
);
5131 gfc_check_transpose (gfc_expr
*matrix
)
5133 if (!rank_check (matrix
, 0, 2))
5141 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5143 if (!array_check (array
, 0))
5146 if (!dim_check (dim
, 1, false))
5149 if (!dim_rank_check (dim
, array
, 0))
5152 if (!kind_check (kind
, 2, BT_INTEGER
))
5154 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5155 "with KIND argument at %L",
5156 gfc_current_intrinsic
, &kind
->where
))
5164 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5166 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5168 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5172 if (!coarray_check (coarray
, 0))
5177 if (!dim_check (dim
, 1, false))
5180 if (!dim_corank_check (dim
, coarray
))
5184 if (!kind_check (kind
, 2, BT_INTEGER
))
5192 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5196 if (!rank_check (vector
, 0, 1))
5199 if (!array_check (mask
, 1))
5202 if (!type_check (mask
, 1, BT_LOGICAL
))
5205 if (!same_type_check (vector
, 0, field
, 2))
5208 if (mask
->expr_type
== EXPR_ARRAY
5209 && gfc_array_size (vector
, &vector_size
))
5211 int mask_true_count
= 0;
5212 gfc_constructor
*mask_ctor
;
5213 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5216 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5218 mask_true_count
= 0;
5222 if (mask_ctor
->expr
->value
.logical
)
5225 mask_ctor
= gfc_constructor_next (mask_ctor
);
5228 if (mpz_get_si (vector_size
) < mask_true_count
)
5230 gfc_error ("%qs argument of %qs intrinsic at %L must "
5231 "provide at least as many elements as there "
5232 "are .TRUE. values in %qs (%ld/%d)",
5233 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5234 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5235 mpz_get_si (vector_size
), mask_true_count
);
5239 mpz_clear (vector_size
);
5242 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5244 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5245 "the same rank as %qs or be a scalar",
5246 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5247 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5251 if (mask
->rank
== field
->rank
)
5254 for (i
= 0; i
< field
->rank
; i
++)
5255 if (! identical_dimen_shape (mask
, i
, field
, i
))
5257 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5258 "must have identical shape.",
5259 gfc_current_intrinsic_arg
[2]->name
,
5260 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5270 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5272 if (!type_check (x
, 0, BT_CHARACTER
))
5275 if (!same_type_check (x
, 0, y
, 1))
5278 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5281 if (!kind_check (kind
, 3, BT_INTEGER
))
5283 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5284 "with KIND argument at %L",
5285 gfc_current_intrinsic
, &kind
->where
))
5293 gfc_check_trim (gfc_expr
*x
)
5295 if (!type_check (x
, 0, BT_CHARACTER
))
5298 if (!scalar_check (x
, 0))
5306 gfc_check_ttynam (gfc_expr
*unit
)
5308 if (!scalar_check (unit
, 0))
5311 if (!type_check (unit
, 0, BT_INTEGER
))
5318 /* Common check function for the half a dozen intrinsics that have a
5319 single real argument. */
5322 gfc_check_x (gfc_expr
*x
)
5324 if (!type_check (x
, 0, BT_REAL
))
5331 /************* Check functions for intrinsic subroutines *************/
5334 gfc_check_cpu_time (gfc_expr
*time
)
5336 if (!scalar_check (time
, 0))
5339 if (!type_check (time
, 0, BT_REAL
))
5342 if (!variable_check (time
, 0, false))
5350 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5351 gfc_expr
*zone
, gfc_expr
*values
)
5355 if (!type_check (date
, 0, BT_CHARACTER
))
5357 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5359 if (!scalar_check (date
, 0))
5361 if (!variable_check (date
, 0, false))
5367 if (!type_check (time
, 1, BT_CHARACTER
))
5369 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5371 if (!scalar_check (time
, 1))
5373 if (!variable_check (time
, 1, false))
5379 if (!type_check (zone
, 2, BT_CHARACTER
))
5381 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5383 if (!scalar_check (zone
, 2))
5385 if (!variable_check (zone
, 2, false))
5391 if (!type_check (values
, 3, BT_INTEGER
))
5393 if (!array_check (values
, 3))
5395 if (!rank_check (values
, 3, 1))
5397 if (!variable_check (values
, 3, false))
5406 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5407 gfc_expr
*to
, gfc_expr
*topos
)
5409 if (!type_check (from
, 0, BT_INTEGER
))
5412 if (!type_check (frompos
, 1, BT_INTEGER
))
5415 if (!type_check (len
, 2, BT_INTEGER
))
5418 if (!same_type_check (from
, 0, to
, 3))
5421 if (!variable_check (to
, 3, false))
5424 if (!type_check (topos
, 4, BT_INTEGER
))
5427 if (!nonnegative_check ("frompos", frompos
))
5430 if (!nonnegative_check ("topos", topos
))
5433 if (!nonnegative_check ("len", len
))
5436 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5439 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5447 gfc_check_random_number (gfc_expr
*harvest
)
5449 if (!type_check (harvest
, 0, BT_REAL
))
5452 if (!variable_check (harvest
, 0, false))
5460 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5462 unsigned int nargs
= 0, kiss_size
;
5463 locus
*where
= NULL
;
5464 mpz_t put_size
, get_size
;
5465 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
5467 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
5469 /* Keep the number of bytes in sync with kiss_size in
5470 libgfortran/intrinsics/random.c. */
5471 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
5475 if (size
->expr_type
!= EXPR_VARIABLE
5476 || !size
->symtree
->n
.sym
->attr
.optional
)
5479 if (!scalar_check (size
, 0))
5482 if (!type_check (size
, 0, BT_INTEGER
))
5485 if (!variable_check (size
, 0, false))
5488 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5494 if (put
->expr_type
!= EXPR_VARIABLE
5495 || !put
->symtree
->n
.sym
->attr
.optional
)
5498 where
= &put
->where
;
5501 if (!array_check (put
, 1))
5504 if (!rank_check (put
, 1, 1))
5507 if (!type_check (put
, 1, BT_INTEGER
))
5510 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5513 if (gfc_array_size (put
, &put_size
)
5514 && mpz_get_ui (put_size
) < kiss_size
)
5515 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5516 "too small (%i/%i)",
5517 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5518 where
, (int) mpz_get_ui (put_size
), kiss_size
);
5523 if (get
->expr_type
!= EXPR_VARIABLE
5524 || !get
->symtree
->n
.sym
->attr
.optional
)
5527 where
= &get
->where
;
5530 if (!array_check (get
, 2))
5533 if (!rank_check (get
, 2, 1))
5536 if (!type_check (get
, 2, BT_INTEGER
))
5539 if (!variable_check (get
, 2, false))
5542 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5545 if (gfc_array_size (get
, &get_size
)
5546 && mpz_get_ui (get_size
) < kiss_size
)
5547 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5548 "too small (%i/%i)",
5549 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5550 where
, (int) mpz_get_ui (get_size
), kiss_size
);
5553 /* RANDOM_SEED may not have more than one non-optional argument. */
5555 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5561 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5565 int num_percent
, nargs
;
5568 if (e
->expr_type
!= EXPR_CONSTANT
)
5571 len
= e
->value
.character
.length
;
5572 if (e
->value
.character
.string
[len
-1] != '\0')
5573 gfc_internal_error ("fe_runtime_error string must be null terminated");
5576 for (i
=0; i
<len
-1; i
++)
5577 if (e
->value
.character
.string
[i
] == '%')
5581 for (; a
; a
= a
->next
)
5584 if (nargs
-1 != num_percent
)
5585 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5586 nargs
, num_percent
++);
5592 gfc_check_second_sub (gfc_expr
*time
)
5594 if (!scalar_check (time
, 0))
5597 if (!type_check (time
, 0, BT_REAL
))
5600 if (!kind_value_check (time
, 0, 4))
5607 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5608 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5609 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5610 count_max are all optional arguments */
5613 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5614 gfc_expr
*count_max
)
5618 if (!scalar_check (count
, 0))
5621 if (!type_check (count
, 0, BT_INTEGER
))
5624 if (count
->ts
.kind
!= gfc_default_integer_kind
5625 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5626 "SYSTEM_CLOCK at %L has non-default kind",
5630 if (!variable_check (count
, 0, false))
5634 if (count_rate
!= NULL
)
5636 if (!scalar_check (count_rate
, 1))
5639 if (!variable_check (count_rate
, 1, false))
5642 if (count_rate
->ts
.type
== BT_REAL
)
5644 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5645 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5650 if (!type_check (count_rate
, 1, BT_INTEGER
))
5653 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5654 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5655 "SYSTEM_CLOCK at %L has non-default kind",
5656 &count_rate
->where
))
5662 if (count_max
!= NULL
)
5664 if (!scalar_check (count_max
, 2))
5667 if (!type_check (count_max
, 2, BT_INTEGER
))
5670 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5671 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5672 "SYSTEM_CLOCK at %L has non-default kind",
5676 if (!variable_check (count_max
, 2, false))
5685 gfc_check_irand (gfc_expr
*x
)
5690 if (!scalar_check (x
, 0))
5693 if (!type_check (x
, 0, BT_INTEGER
))
5696 if (!kind_value_check (x
, 0, 4))
5704 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5706 if (!scalar_check (seconds
, 0))
5708 if (!type_check (seconds
, 0, BT_INTEGER
))
5711 if (!int_or_proc_check (handler
, 1))
5713 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5719 if (!scalar_check (status
, 2))
5721 if (!type_check (status
, 2, BT_INTEGER
))
5723 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5731 gfc_check_rand (gfc_expr
*x
)
5736 if (!scalar_check (x
, 0))
5739 if (!type_check (x
, 0, BT_INTEGER
))
5742 if (!kind_value_check (x
, 0, 4))
5750 gfc_check_srand (gfc_expr
*x
)
5752 if (!scalar_check (x
, 0))
5755 if (!type_check (x
, 0, BT_INTEGER
))
5758 if (!kind_value_check (x
, 0, 4))
5766 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5768 if (!scalar_check (time
, 0))
5770 if (!type_check (time
, 0, BT_INTEGER
))
5773 if (!type_check (result
, 1, BT_CHARACTER
))
5775 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5783 gfc_check_dtime_etime (gfc_expr
*x
)
5785 if (!array_check (x
, 0))
5788 if (!rank_check (x
, 0, 1))
5791 if (!variable_check (x
, 0, false))
5794 if (!type_check (x
, 0, BT_REAL
))
5797 if (!kind_value_check (x
, 0, 4))
5805 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5807 if (!array_check (values
, 0))
5810 if (!rank_check (values
, 0, 1))
5813 if (!variable_check (values
, 0, false))
5816 if (!type_check (values
, 0, BT_REAL
))
5819 if (!kind_value_check (values
, 0, 4))
5822 if (!scalar_check (time
, 1))
5825 if (!type_check (time
, 1, BT_REAL
))
5828 if (!kind_value_check (time
, 1, 4))
5836 gfc_check_fdate_sub (gfc_expr
*date
)
5838 if (!type_check (date
, 0, BT_CHARACTER
))
5840 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5848 gfc_check_gerror (gfc_expr
*msg
)
5850 if (!type_check (msg
, 0, BT_CHARACTER
))
5852 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5860 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5862 if (!type_check (cwd
, 0, BT_CHARACTER
))
5864 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5870 if (!scalar_check (status
, 1))
5873 if (!type_check (status
, 1, BT_INTEGER
))
5881 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5883 if (!type_check (pos
, 0, BT_INTEGER
))
5886 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5888 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
5889 "not wider than the default kind (%d)",
5890 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5891 &pos
->where
, gfc_default_integer_kind
);
5895 if (!type_check (value
, 1, BT_CHARACTER
))
5897 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
5905 gfc_check_getlog (gfc_expr
*msg
)
5907 if (!type_check (msg
, 0, BT_CHARACTER
))
5909 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5917 gfc_check_exit (gfc_expr
*status
)
5922 if (!type_check (status
, 0, BT_INTEGER
))
5925 if (!scalar_check (status
, 0))
5933 gfc_check_flush (gfc_expr
*unit
)
5938 if (!type_check (unit
, 0, BT_INTEGER
))
5941 if (!scalar_check (unit
, 0))
5949 gfc_check_free (gfc_expr
*i
)
5951 if (!type_check (i
, 0, BT_INTEGER
))
5954 if (!scalar_check (i
, 0))
5962 gfc_check_hostnm (gfc_expr
*name
)
5964 if (!type_check (name
, 0, BT_CHARACTER
))
5966 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5974 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
5976 if (!type_check (name
, 0, BT_CHARACTER
))
5978 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5984 if (!scalar_check (status
, 1))
5987 if (!type_check (status
, 1, BT_INTEGER
))
5995 gfc_check_itime_idate (gfc_expr
*values
)
5997 if (!array_check (values
, 0))
6000 if (!rank_check (values
, 0, 1))
6003 if (!variable_check (values
, 0, false))
6006 if (!type_check (values
, 0, BT_INTEGER
))
6009 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6017 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6019 if (!type_check (time
, 0, BT_INTEGER
))
6022 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6025 if (!scalar_check (time
, 0))
6028 if (!array_check (values
, 1))
6031 if (!rank_check (values
, 1, 1))
6034 if (!variable_check (values
, 1, false))
6037 if (!type_check (values
, 1, BT_INTEGER
))
6040 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6048 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6050 if (!scalar_check (unit
, 0))
6053 if (!type_check (unit
, 0, BT_INTEGER
))
6056 if (!type_check (name
, 1, BT_CHARACTER
))
6058 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6066 gfc_check_isatty (gfc_expr
*unit
)
6071 if (!type_check (unit
, 0, BT_INTEGER
))
6074 if (!scalar_check (unit
, 0))
6082 gfc_check_isnan (gfc_expr
*x
)
6084 if (!type_check (x
, 0, BT_REAL
))
6092 gfc_check_perror (gfc_expr
*string
)
6094 if (!type_check (string
, 0, BT_CHARACTER
))
6096 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6104 gfc_check_umask (gfc_expr
*mask
)
6106 if (!type_check (mask
, 0, BT_INTEGER
))
6109 if (!scalar_check (mask
, 0))
6117 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6119 if (!type_check (mask
, 0, BT_INTEGER
))
6122 if (!scalar_check (mask
, 0))
6128 if (!scalar_check (old
, 1))
6131 if (!type_check (old
, 1, BT_INTEGER
))
6139 gfc_check_unlink (gfc_expr
*name
)
6141 if (!type_check (name
, 0, BT_CHARACTER
))
6143 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6151 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6153 if (!type_check (name
, 0, BT_CHARACTER
))
6155 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6161 if (!scalar_check (status
, 1))
6164 if (!type_check (status
, 1, BT_INTEGER
))
6172 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6174 if (!scalar_check (number
, 0))
6176 if (!type_check (number
, 0, BT_INTEGER
))
6179 if (!int_or_proc_check (handler
, 1))
6181 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6189 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6191 if (!scalar_check (number
, 0))
6193 if (!type_check (number
, 0, BT_INTEGER
))
6196 if (!int_or_proc_check (handler
, 1))
6198 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6204 if (!type_check (status
, 2, BT_INTEGER
))
6206 if (!scalar_check (status
, 2))
6214 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6216 if (!type_check (cmd
, 0, BT_CHARACTER
))
6218 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6221 if (!scalar_check (status
, 1))
6224 if (!type_check (status
, 1, BT_INTEGER
))
6227 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6234 /* This is used for the GNU intrinsics AND, OR and XOR. */
6236 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6238 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6240 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6241 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6242 gfc_current_intrinsic
, &i
->where
);
6246 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6248 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6249 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6250 gfc_current_intrinsic
, &j
->where
);
6254 if (i
->ts
.type
!= j
->ts
.type
)
6256 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6257 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6258 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6263 if (!scalar_check (i
, 0))
6266 if (!scalar_check (j
, 1))
6274 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6277 if (a
->expr_type
== EXPR_NULL
)
6279 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6280 "argument to STORAGE_SIZE, because it returns a "
6281 "disassociated pointer", &a
->where
);
6285 if (a
->ts
.type
== BT_ASSUMED
)
6287 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6288 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6293 if (a
->ts
.type
== BT_PROCEDURE
)
6295 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6296 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6297 gfc_current_intrinsic
, &a
->where
);
6304 if (!type_check (kind
, 1, BT_INTEGER
))
6307 if (!scalar_check (kind
, 1))
6310 if (kind
->expr_type
!= EXPR_CONSTANT
)
6312 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6313 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,