2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 if (gfc_numeric_ts (&e
->ts
))
78 /* If the expression has not got a type, check if its namespace can
79 offer a default type. */
80 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
81 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
82 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
83 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
85 e
->ts
= e
->symtree
->n
.sym
->ts
;
89 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
90 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
97 /* Check that an expression is integer or real. */
100 int_or_real_check (gfc_expr
*e
, int n
)
102 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
105 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
106 gfc_current_intrinsic
, &e
->where
);
114 /* Check that an expression is real or complex. */
117 real_or_complex_check (gfc_expr
*e
, int n
)
119 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
121 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
122 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
123 gfc_current_intrinsic
, &e
->where
);
131 /* Check that an expression is INTEGER or PROCEDURE. */
134 int_or_proc_check (gfc_expr
*e
, int n
)
136 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
138 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
139 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
140 gfc_current_intrinsic
, &e
->where
);
148 /* Check that the expression is an optional constant integer
149 and that it specifies a valid kind for that type. */
152 kind_check (gfc_expr
*k
, int n
, bt type
)
159 if (!type_check (k
, n
, BT_INTEGER
))
162 if (!scalar_check (k
, n
))
165 if (!gfc_check_init_expr (k
))
167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
168 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
173 if (gfc_extract_int (k
, &kind
) != NULL
174 || gfc_validate_kind (type
, kind
, true) < 0)
176 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
185 /* Make sure the expression is a double precision real. */
188 double_check (gfc_expr
*d
, int n
)
190 if (!type_check (d
, n
, BT_REAL
))
193 if (d
->ts
.kind
!= gfc_default_double_kind
)
195 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
196 "precision", gfc_current_intrinsic_arg
[n
]->name
,
197 gfc_current_intrinsic
, &d
->where
);
206 coarray_check (gfc_expr
*e
, int n
)
208 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
209 && CLASS_DATA (e
)->attr
.codimension
210 && CLASS_DATA (e
)->as
->corank
)
212 gfc_add_class_array_ref (e
);
216 if (!gfc_is_coarray (e
))
218 gfc_error ("Expected coarray variable as '%s' argument to the %s "
219 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
220 gfc_current_intrinsic
, &e
->where
);
228 /* Make sure the expression is a logical array. */
231 logical_array_check (gfc_expr
*array
, int n
)
233 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
235 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
236 "array", gfc_current_intrinsic_arg
[n
]->name
,
237 gfc_current_intrinsic
, &array
->where
);
245 /* Make sure an expression is an array. */
248 array_check (gfc_expr
*e
, int n
)
250 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
251 && CLASS_DATA (e
)->attr
.dimension
252 && CLASS_DATA (e
)->as
->rank
)
254 gfc_add_class_array_ref (e
);
258 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
261 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
262 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
269 /* If expr is a constant, then check to ensure that it is greater than
273 nonnegative_check (const char *arg
, gfc_expr
*expr
)
277 if (expr
->expr_type
== EXPR_CONSTANT
)
279 gfc_extract_int (expr
, &i
);
282 gfc_error ("'%s' at %L must be nonnegative", arg
, &expr
->where
);
291 /* If expr2 is constant, then check that the value is less than
292 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
295 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
296 gfc_expr
*expr2
, bool or_equal
)
300 if (expr2
->expr_type
== EXPR_CONSTANT
)
302 gfc_extract_int (expr2
, &i2
);
303 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
305 /* For ISHFT[C], check that |shift| <= bit_size(i). */
311 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
313 gfc_error ("The absolute value of SHIFT at %L must be less "
314 "than or equal to BIT_SIZE('%s')",
315 &expr2
->where
, arg1
);
322 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
324 gfc_error ("'%s' at %L must be less than "
325 "or equal to BIT_SIZE('%s')",
326 arg2
, &expr2
->where
, arg1
);
332 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
334 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
335 arg2
, &expr2
->where
, arg1
);
345 /* If expr is constant, then check that the value is less than or equal
346 to the bit_size of the kind k. */
349 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
353 if (expr
->expr_type
!= EXPR_CONSTANT
)
356 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
357 gfc_extract_int (expr
, &val
);
359 if (val
> gfc_integer_kinds
[i
].bit_size
)
361 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
362 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
370 /* If expr2 and expr3 are constants, then check that the value is less than
371 or equal to bit_size(expr1). */
374 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
375 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
379 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
381 gfc_extract_int (expr2
, &i2
);
382 gfc_extract_int (expr3
, &i3
);
384 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
385 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
387 gfc_error ("'%s + %s' at %L must be less than or equal "
389 arg2
, arg3
, &expr2
->where
, arg1
);
397 /* Make sure two expressions have the same type. */
400 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
402 if (gfc_compare_types (&e
->ts
, &f
->ts
))
405 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
406 "and kind as '%s'", gfc_current_intrinsic_arg
[m
]->name
,
407 gfc_current_intrinsic
, &f
->where
,
408 gfc_current_intrinsic_arg
[n
]->name
);
414 /* Make sure that an expression has a certain (nonzero) rank. */
417 rank_check (gfc_expr
*e
, int n
, int rank
)
422 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
423 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
430 /* Make sure a variable expression is not an optional dummy argument. */
433 nonoptional_check (gfc_expr
*e
, int n
)
435 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
437 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
438 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
442 /* TODO: Recursive check on nonoptional variables? */
448 /* Check for ALLOCATABLE attribute. */
451 allocatable_check (gfc_expr
*e
, int n
)
453 symbol_attribute attr
;
455 attr
= gfc_variable_attr (e
, NULL
);
456 if (!attr
.allocatable
|| attr
.associate_var
)
458 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
459 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
468 /* Check that an expression has a particular kind. */
471 kind_value_check (gfc_expr
*e
, int n
, int k
)
476 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
477 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
484 /* Make sure an expression is a variable. */
487 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
489 if (e
->expr_type
== EXPR_VARIABLE
490 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
491 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
492 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
495 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
496 && CLASS_DATA (e
->symtree
->n
.sym
)
497 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
498 : e
->symtree
->n
.sym
->attr
.pointer
;
500 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
502 if (pointer
&& ref
->type
== REF_COMPONENT
)
504 if (ref
->type
== REF_COMPONENT
505 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
506 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
507 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
508 && ref
->u
.c
.component
->attr
.pointer
)))
514 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
515 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
516 gfc_current_intrinsic
, &e
->where
);
521 if (e
->expr_type
== EXPR_VARIABLE
522 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
523 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
526 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
527 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
530 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
531 if (ns
->proc_name
== e
->symtree
->n
.sym
)
535 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
536 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
542 /* Check the common DIM parameter for correctness. */
545 dim_check (gfc_expr
*dim
, int n
, bool optional
)
550 if (!type_check (dim
, n
, BT_INTEGER
))
553 if (!scalar_check (dim
, n
))
556 if (!optional
&& !nonoptional_check (dim
, n
))
563 /* If a coarray DIM parameter is a constant, make sure that it is greater than
564 zero and less than or equal to the corank of the given array. */
567 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
571 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
573 if (dim
->expr_type
!= EXPR_CONSTANT
)
576 if (array
->ts
.type
== BT_CLASS
)
579 corank
= gfc_get_corank (array
);
581 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
582 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
584 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
585 "codimension index", gfc_current_intrinsic
, &dim
->where
);
594 /* If a DIM parameter is a constant, make sure that it is greater than
595 zero and less than or equal to the rank of the given array. If
596 allow_assumed is zero then dim must be less than the rank of the array
597 for assumed size arrays. */
600 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
608 if (dim
->expr_type
!= EXPR_CONSTANT
)
611 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
612 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
613 rank
= array
->rank
+ 1;
617 /* Assumed-rank array. */
619 rank
= GFC_MAX_DIMENSIONS
;
621 if (array
->expr_type
== EXPR_VARIABLE
)
623 ar
= gfc_find_array_ref (array
);
624 if (ar
->as
->type
== AS_ASSUMED_SIZE
626 && ar
->type
!= AR_ELEMENT
627 && ar
->type
!= AR_SECTION
)
631 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
632 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
634 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
635 "dimension index", gfc_current_intrinsic
, &dim
->where
);
644 /* Compare the size of a along dimension ai with the size of b along
645 dimension bi, returning 0 if they are known not to be identical,
646 and 1 if they are identical, or if this cannot be determined. */
649 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
651 mpz_t a_size
, b_size
;
654 gcc_assert (a
->rank
> ai
);
655 gcc_assert (b
->rank
> bi
);
659 if (gfc_array_dimen_size (a
, ai
, &a_size
))
661 if (gfc_array_dimen_size (b
, bi
, &b_size
))
663 if (mpz_cmp (a_size
, b_size
) != 0)
673 /* Calculate the length of a character variable, including substrings.
674 Strip away parentheses if necessary. Return -1 if no length could
678 gfc_var_strlen (const gfc_expr
*a
)
682 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
685 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
695 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
696 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
698 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
700 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
701 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
703 else if (ra
->u
.ss
.start
704 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
710 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
711 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
712 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
713 else if (a
->expr_type
== EXPR_CONSTANT
714 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
715 return a
->value
.character
.length
;
721 /* Check whether two character expressions have the same length;
722 returns true if they have or if the length cannot be determined,
723 otherwise return false and raise a gfc_error. */
726 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
730 len_a
= gfc_var_strlen(a
);
731 len_b
= gfc_var_strlen(b
);
733 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
737 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
738 len_a
, len_b
, name
, &a
->where
);
744 /***** Check functions *****/
746 /* Check subroutine suitable for intrinsics taking a real argument and
747 a kind argument for the result. */
750 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
752 if (!type_check (a
, 0, BT_REAL
))
754 if (!kind_check (kind
, 1, type
))
761 /* Check subroutine suitable for ceiling, floor and nint. */
764 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
766 return check_a_kind (a
, kind
, BT_INTEGER
);
770 /* Check subroutine suitable for aint, anint. */
773 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
775 return check_a_kind (a
, kind
, BT_REAL
);
780 gfc_check_abs (gfc_expr
*a
)
782 if (!numeric_check (a
, 0))
790 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
792 if (!type_check (a
, 0, BT_INTEGER
))
794 if (!kind_check (kind
, 1, BT_CHARACTER
))
802 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
804 if (!type_check (name
, 0, BT_CHARACTER
)
805 || !scalar_check (name
, 0))
807 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
810 if (!type_check (mode
, 1, BT_CHARACTER
)
811 || !scalar_check (mode
, 1))
813 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
821 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
823 if (!logical_array_check (mask
, 0))
826 if (!dim_check (dim
, 1, false))
829 if (!dim_rank_check (dim
, mask
, 0))
837 gfc_check_allocated (gfc_expr
*array
)
839 if (!variable_check (array
, 0, false))
841 if (!allocatable_check (array
, 0))
848 /* Common check function where the first argument must be real or
849 integer and the second argument must be the same as the first. */
852 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
854 if (!int_or_real_check (a
, 0))
857 if (a
->ts
.type
!= p
->ts
.type
)
859 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
860 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
861 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
866 if (a
->ts
.kind
!= p
->ts
.kind
)
868 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
878 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
880 if (!double_check (x
, 0) || !double_check (y
, 1))
888 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
890 symbol_attribute attr1
, attr2
;
895 where
= &pointer
->where
;
897 if (pointer
->expr_type
== EXPR_NULL
)
900 attr1
= gfc_expr_attr (pointer
);
902 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
904 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
905 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
911 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
913 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
914 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
915 gfc_current_intrinsic
, &pointer
->where
);
919 /* Target argument is optional. */
923 where
= &target
->where
;
924 if (target
->expr_type
== EXPR_NULL
)
927 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
928 attr2
= gfc_expr_attr (target
);
931 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
932 "or target VARIABLE or FUNCTION",
933 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
938 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
940 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
941 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
942 gfc_current_intrinsic
, &target
->where
);
947 if (attr1
.pointer
&& gfc_is_coindexed (target
))
949 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
950 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
951 gfc_current_intrinsic
, &target
->where
);
956 if (!same_type_check (pointer
, 0, target
, 1))
958 if (!rank_check (target
, 0, pointer
->rank
))
960 if (target
->rank
> 0)
962 for (i
= 0; i
< target
->rank
; i
++)
963 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
965 gfc_error ("Array section with a vector subscript at %L shall not "
966 "be the target of a pointer",
976 gfc_error ("NULL pointer at %L is not permitted as actual argument "
977 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
984 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
986 /* gfc_notify_std would be a waste of time as the return value
987 is seemingly used only for the generic resolution. The error
988 will be: Too many arguments. */
989 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
992 return gfc_check_atan2 (y
, x
);
997 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
999 if (!type_check (y
, 0, BT_REAL
))
1001 if (!same_type_check (y
, 0, x
, 1))
1009 gfc_check_atomic (gfc_expr
*atom
, gfc_expr
*value
)
1011 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1012 && !(atom
->ts
.type
== BT_LOGICAL
1013 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1015 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1016 "integer of ATOMIC_INT_KIND or a logical of "
1017 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1021 if (!gfc_expr_attr (atom
).codimension
)
1023 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1024 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1028 if (atom
->ts
.type
!= value
->ts
.type
)
1030 gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
1031 "have the same type at %L", gfc_current_intrinsic
,
1041 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
)
1043 if (!scalar_check (atom
, 0) || !scalar_check (value
, 1))
1046 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1048 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1049 "definable", gfc_current_intrinsic
, &atom
->where
);
1053 return gfc_check_atomic (atom
, value
);
1058 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
)
1060 if (!scalar_check (value
, 0) || !scalar_check (atom
, 1))
1063 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1065 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1066 "definable", gfc_current_intrinsic
, &value
->where
);
1070 return gfc_check_atomic (atom
, value
);
1074 /* BESJN and BESYN functions. */
1077 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1079 if (!type_check (n
, 0, BT_INTEGER
))
1081 if (n
->expr_type
== EXPR_CONSTANT
)
1084 gfc_extract_int (n
, &i
);
1085 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1086 "N at %L", &n
->where
))
1090 if (!type_check (x
, 1, BT_REAL
))
1097 /* Transformational version of the Bessel JN and YN functions. */
1100 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1102 if (!type_check (n1
, 0, BT_INTEGER
))
1104 if (!scalar_check (n1
, 0))
1106 if (!nonnegative_check ("N1", n1
))
1109 if (!type_check (n2
, 1, BT_INTEGER
))
1111 if (!scalar_check (n2
, 1))
1113 if (!nonnegative_check ("N2", n2
))
1116 if (!type_check (x
, 2, BT_REAL
))
1118 if (!scalar_check (x
, 2))
1126 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1128 if (!type_check (i
, 0, BT_INTEGER
))
1131 if (!type_check (j
, 1, BT_INTEGER
))
1139 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1141 if (!type_check (i
, 0, BT_INTEGER
))
1144 if (!type_check (pos
, 1, BT_INTEGER
))
1147 if (!nonnegative_check ("pos", pos
))
1150 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1158 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1160 if (!type_check (i
, 0, BT_INTEGER
))
1162 if (!kind_check (kind
, 1, BT_CHARACTER
))
1170 gfc_check_chdir (gfc_expr
*dir
)
1172 if (!type_check (dir
, 0, BT_CHARACTER
))
1174 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1182 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1184 if (!type_check (dir
, 0, BT_CHARACTER
))
1186 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1192 if (!type_check (status
, 1, BT_INTEGER
))
1194 if (!scalar_check (status
, 1))
1202 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1204 if (!type_check (name
, 0, BT_CHARACTER
))
1206 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1209 if (!type_check (mode
, 1, BT_CHARACTER
))
1211 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1219 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1221 if (!type_check (name
, 0, BT_CHARACTER
))
1223 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1226 if (!type_check (mode
, 1, BT_CHARACTER
))
1228 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1234 if (!type_check (status
, 2, BT_INTEGER
))
1237 if (!scalar_check (status
, 2))
1245 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1247 if (!numeric_check (x
, 0))
1252 if (!numeric_check (y
, 1))
1255 if (x
->ts
.type
== BT_COMPLEX
)
1257 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1258 "present if 'x' is COMPLEX",
1259 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1264 if (y
->ts
.type
== BT_COMPLEX
)
1266 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1267 "of either REAL or INTEGER",
1268 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1275 if (!kind_check (kind
, 2, BT_COMPLEX
))
1278 if (!kind
&& gfc_option
.gfc_warn_conversion
1279 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1280 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1281 "might loose precision, consider using the KIND argument",
1282 gfc_typename (&x
->ts
), gfc_default_real_kind
, &x
->where
);
1283 else if (y
&& !kind
&& gfc_option
.gfc_warn_conversion
1284 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1285 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1286 "might loose precision, consider using the KIND argument",
1287 gfc_typename (&y
->ts
), gfc_default_real_kind
, &y
->where
);
1294 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1296 if (!int_or_real_check (x
, 0))
1298 if (!scalar_check (x
, 0))
1301 if (!int_or_real_check (y
, 1))
1303 if (!scalar_check (y
, 1))
1311 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1313 if (!logical_array_check (mask
, 0))
1315 if (!dim_check (dim
, 1, false))
1317 if (!dim_rank_check (dim
, mask
, 0))
1319 if (!kind_check (kind
, 2, BT_INTEGER
))
1321 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1322 "with KIND argument at %L",
1323 gfc_current_intrinsic
, &kind
->where
))
1331 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1333 if (!array_check (array
, 0))
1336 if (!type_check (shift
, 1, BT_INTEGER
))
1339 if (!dim_check (dim
, 2, true))
1342 if (!dim_rank_check (dim
, array
, false))
1345 if (array
->rank
== 1 || shift
->rank
== 0)
1347 if (!scalar_check (shift
, 1))
1350 else if (shift
->rank
== array
->rank
- 1)
1355 else if (dim
->expr_type
== EXPR_CONSTANT
)
1356 gfc_extract_int (dim
, &d
);
1363 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1366 if (!identical_dimen_shape (array
, i
, shift
, j
))
1368 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1369 "invalid shape in dimension %d (%ld/%ld)",
1370 gfc_current_intrinsic_arg
[1]->name
,
1371 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1372 mpz_get_si (array
->shape
[i
]),
1373 mpz_get_si (shift
->shape
[j
]));
1383 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1384 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1385 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1394 gfc_check_ctime (gfc_expr
*time
)
1396 if (!scalar_check (time
, 0))
1399 if (!type_check (time
, 0, BT_INTEGER
))
1406 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1408 if (!double_check (y
, 0) || !double_check (x
, 1))
1415 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1417 if (!numeric_check (x
, 0))
1422 if (!numeric_check (y
, 1))
1425 if (x
->ts
.type
== BT_COMPLEX
)
1427 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1428 "present if 'x' is COMPLEX",
1429 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1434 if (y
->ts
.type
== BT_COMPLEX
)
1436 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1437 "of either REAL or INTEGER",
1438 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1449 gfc_check_dble (gfc_expr
*x
)
1451 if (!numeric_check (x
, 0))
1459 gfc_check_digits (gfc_expr
*x
)
1461 if (!int_or_real_check (x
, 0))
1469 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1471 switch (vector_a
->ts
.type
)
1474 if (!type_check (vector_b
, 1, BT_LOGICAL
))
1481 if (!numeric_check (vector_b
, 1))
1486 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1487 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1488 gfc_current_intrinsic
, &vector_a
->where
);
1492 if (!rank_check (vector_a
, 0, 1))
1495 if (!rank_check (vector_b
, 1, 1))
1498 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1500 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1501 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0]->name
,
1502 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1511 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1513 if (!type_check (x
, 0, BT_REAL
)
1514 || !type_check (y
, 1, BT_REAL
))
1517 if (x
->ts
.kind
!= gfc_default_real_kind
)
1519 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1520 "real", gfc_current_intrinsic_arg
[0]->name
,
1521 gfc_current_intrinsic
, &x
->where
);
1525 if (y
->ts
.kind
!= gfc_default_real_kind
)
1527 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1528 "real", gfc_current_intrinsic_arg
[1]->name
,
1529 gfc_current_intrinsic
, &y
->where
);
1538 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1540 if (!type_check (i
, 0, BT_INTEGER
))
1543 if (!type_check (j
, 1, BT_INTEGER
))
1546 if (i
->is_boz
&& j
->is_boz
)
1548 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1549 "constants", &i
->where
, &j
->where
);
1553 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
1556 if (!type_check (shift
, 2, BT_INTEGER
))
1559 if (!nonnegative_check ("SHIFT", shift
))
1564 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
1566 i
->ts
.kind
= j
->ts
.kind
;
1570 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
1572 j
->ts
.kind
= i
->ts
.kind
;
1580 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1583 if (!array_check (array
, 0))
1586 if (!type_check (shift
, 1, BT_INTEGER
))
1589 if (!dim_check (dim
, 3, true))
1592 if (!dim_rank_check (dim
, array
, false))
1595 if (array
->rank
== 1 || shift
->rank
== 0)
1597 if (!scalar_check (shift
, 1))
1600 else if (shift
->rank
== array
->rank
- 1)
1605 else if (dim
->expr_type
== EXPR_CONSTANT
)
1606 gfc_extract_int (dim
, &d
);
1613 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1616 if (!identical_dimen_shape (array
, i
, shift
, j
))
1618 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1619 "invalid shape in dimension %d (%ld/%ld)",
1620 gfc_current_intrinsic_arg
[1]->name
,
1621 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1622 mpz_get_si (array
->shape
[i
]),
1623 mpz_get_si (shift
->shape
[j
]));
1633 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1634 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1635 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1639 if (boundary
!= NULL
)
1641 if (!same_type_check (array
, 0, boundary
, 2))
1644 if (array
->rank
== 1 || boundary
->rank
== 0)
1646 if (!scalar_check (boundary
, 2))
1649 else if (boundary
->rank
== array
->rank
- 1)
1651 if (!gfc_check_conformance (shift
, boundary
,
1652 "arguments '%s' and '%s' for "
1654 gfc_current_intrinsic_arg
[1]->name
,
1655 gfc_current_intrinsic_arg
[2]->name
,
1656 gfc_current_intrinsic
))
1661 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1662 "rank %d or be a scalar",
1663 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1664 &shift
->where
, array
->rank
- 1);
1673 gfc_check_float (gfc_expr
*a
)
1675 if (!type_check (a
, 0, BT_INTEGER
))
1678 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
1679 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
1680 "kind argument to %s intrinsic at %L",
1681 gfc_current_intrinsic
, &a
->where
))
1687 /* A single complex argument. */
1690 gfc_check_fn_c (gfc_expr
*a
)
1692 if (!type_check (a
, 0, BT_COMPLEX
))
1698 /* A single real argument. */
1701 gfc_check_fn_r (gfc_expr
*a
)
1703 if (!type_check (a
, 0, BT_REAL
))
1709 /* A single double argument. */
1712 gfc_check_fn_d (gfc_expr
*a
)
1714 if (!double_check (a
, 0))
1720 /* A single real or complex argument. */
1723 gfc_check_fn_rc (gfc_expr
*a
)
1725 if (!real_or_complex_check (a
, 0))
1733 gfc_check_fn_rc2008 (gfc_expr
*a
)
1735 if (!real_or_complex_check (a
, 0))
1738 if (a
->ts
.type
== BT_COMPLEX
1739 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument '%s' "
1740 "argument of '%s' intrinsic at %L",
1741 gfc_current_intrinsic_arg
[0]->name
,
1742 gfc_current_intrinsic
, &a
->where
))
1750 gfc_check_fnum (gfc_expr
*unit
)
1752 if (!type_check (unit
, 0, BT_INTEGER
))
1755 if (!scalar_check (unit
, 0))
1763 gfc_check_huge (gfc_expr
*x
)
1765 if (!int_or_real_check (x
, 0))
1773 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
1775 if (!type_check (x
, 0, BT_REAL
))
1777 if (!same_type_check (x
, 0, y
, 1))
1784 /* Check that the single argument is an integer. */
1787 gfc_check_i (gfc_expr
*i
)
1789 if (!type_check (i
, 0, BT_INTEGER
))
1797 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1799 if (!type_check (i
, 0, BT_INTEGER
))
1802 if (!type_check (j
, 1, BT_INTEGER
))
1805 if (i
->ts
.kind
!= j
->ts
.kind
)
1807 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1817 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1819 if (!type_check (i
, 0, BT_INTEGER
))
1822 if (!type_check (pos
, 1, BT_INTEGER
))
1825 if (!type_check (len
, 2, BT_INTEGER
))
1828 if (!nonnegative_check ("pos", pos
))
1831 if (!nonnegative_check ("len", len
))
1834 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
1842 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1846 if (!type_check (c
, 0, BT_CHARACTER
))
1849 if (!kind_check (kind
, 1, BT_INTEGER
))
1852 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1853 "with KIND argument at %L",
1854 gfc_current_intrinsic
, &kind
->where
))
1857 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1863 /* Substring references don't have the charlength set. */
1865 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1868 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1872 /* Check that the argument is length one. Non-constant lengths
1873 can't be checked here, so assume they are ok. */
1874 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
1876 /* If we already have a length for this expression then use it. */
1877 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1879 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1886 start
= ref
->u
.ss
.start
;
1887 end
= ref
->u
.ss
.end
;
1890 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1891 || start
->expr_type
!= EXPR_CONSTANT
)
1894 i
= mpz_get_si (end
->value
.integer
) + 1
1895 - mpz_get_si (start
->value
.integer
);
1903 gfc_error ("Argument of %s at %L must be of length one",
1904 gfc_current_intrinsic
, &c
->where
);
1913 gfc_check_idnint (gfc_expr
*a
)
1915 if (!double_check (a
, 0))
1923 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
1925 if (!type_check (i
, 0, BT_INTEGER
))
1928 if (!type_check (j
, 1, BT_INTEGER
))
1931 if (i
->ts
.kind
!= j
->ts
.kind
)
1933 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1943 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
1946 if (!type_check (string
, 0, BT_CHARACTER
)
1947 || !type_check (substring
, 1, BT_CHARACTER
))
1950 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
1953 if (!kind_check (kind
, 3, BT_INTEGER
))
1955 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1956 "with KIND argument at %L",
1957 gfc_current_intrinsic
, &kind
->where
))
1960 if (string
->ts
.kind
!= substring
->ts
.kind
)
1962 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1963 "kind as '%s'", gfc_current_intrinsic_arg
[1]->name
,
1964 gfc_current_intrinsic
, &substring
->where
,
1965 gfc_current_intrinsic_arg
[0]->name
);
1974 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
1976 if (!numeric_check (x
, 0))
1979 if (!kind_check (kind
, 1, BT_INTEGER
))
1987 gfc_check_intconv (gfc_expr
*x
)
1989 if (!numeric_check (x
, 0))
1997 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
1999 if (!type_check (i
, 0, BT_INTEGER
))
2002 if (!type_check (j
, 1, BT_INTEGER
))
2005 if (i
->ts
.kind
!= j
->ts
.kind
)
2007 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2017 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2019 if (!type_check (i
, 0, BT_INTEGER
)
2020 || !type_check (shift
, 1, BT_INTEGER
))
2023 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2031 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2033 if (!type_check (i
, 0, BT_INTEGER
)
2034 || !type_check (shift
, 1, BT_INTEGER
))
2041 if (!type_check (size
, 2, BT_INTEGER
))
2044 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2047 if (size
->expr_type
== EXPR_CONSTANT
)
2049 gfc_extract_int (size
, &i3
);
2052 gfc_error ("SIZE at %L must be positive", &size
->where
);
2056 if (shift
->expr_type
== EXPR_CONSTANT
)
2058 gfc_extract_int (shift
, &i2
);
2064 gfc_error ("The absolute value of SHIFT at %L must be less "
2065 "than or equal to SIZE at %L", &shift
->where
,
2072 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2080 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2082 if (!type_check (pid
, 0, BT_INTEGER
))
2085 if (!type_check (sig
, 1, BT_INTEGER
))
2093 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2095 if (!type_check (pid
, 0, BT_INTEGER
))
2098 if (!scalar_check (pid
, 0))
2101 if (!type_check (sig
, 1, BT_INTEGER
))
2104 if (!scalar_check (sig
, 1))
2110 if (!type_check (status
, 2, BT_INTEGER
))
2113 if (!scalar_check (status
, 2))
2121 gfc_check_kind (gfc_expr
*x
)
2123 if (x
->ts
.type
== BT_DERIVED
)
2125 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2126 "non-derived type", gfc_current_intrinsic_arg
[0]->name
,
2127 gfc_current_intrinsic
, &x
->where
);
2136 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2138 if (!array_check (array
, 0))
2141 if (!dim_check (dim
, 1, false))
2144 if (!dim_rank_check (dim
, array
, 1))
2147 if (!kind_check (kind
, 2, BT_INTEGER
))
2149 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2150 "with KIND argument at %L",
2151 gfc_current_intrinsic
, &kind
->where
))
2159 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2161 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2163 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2167 if (!coarray_check (coarray
, 0))
2172 if (!dim_check (dim
, 1, false))
2175 if (!dim_corank_check (dim
, coarray
))
2179 if (!kind_check (kind
, 2, BT_INTEGER
))
2187 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2189 if (!type_check (s
, 0, BT_CHARACTER
))
2192 if (!kind_check (kind
, 1, BT_INTEGER
))
2194 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2195 "with KIND argument at %L",
2196 gfc_current_intrinsic
, &kind
->where
))
2204 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2206 if (!type_check (a
, 0, BT_CHARACTER
))
2208 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2211 if (!type_check (b
, 1, BT_CHARACTER
))
2213 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2221 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2223 if (!type_check (path1
, 0, BT_CHARACTER
))
2225 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2228 if (!type_check (path2
, 1, BT_CHARACTER
))
2230 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2238 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2240 if (!type_check (path1
, 0, BT_CHARACTER
))
2242 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2245 if (!type_check (path2
, 1, BT_CHARACTER
))
2247 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2253 if (!type_check (status
, 2, BT_INTEGER
))
2256 if (!scalar_check (status
, 2))
2264 gfc_check_loc (gfc_expr
*expr
)
2266 return variable_check (expr
, 0, true);
2271 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2273 if (!type_check (path1
, 0, BT_CHARACTER
))
2275 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2278 if (!type_check (path2
, 1, BT_CHARACTER
))
2280 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2288 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2290 if (!type_check (path1
, 0, BT_CHARACTER
))
2292 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2295 if (!type_check (path2
, 1, BT_CHARACTER
))
2297 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2303 if (!type_check (status
, 2, BT_INTEGER
))
2306 if (!scalar_check (status
, 2))
2314 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2316 if (!type_check (a
, 0, BT_LOGICAL
))
2318 if (!kind_check (kind
, 1, BT_LOGICAL
))
2325 /* Min/max family. */
2328 min_max_args (gfc_actual_arglist
*args
)
2330 gfc_actual_arglist
*arg
;
2331 int i
, j
, nargs
, *nlabels
, nlabelless
;
2332 bool a1
= false, a2
= false;
2334 if (args
== NULL
|| args
->next
== NULL
)
2336 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2337 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2344 if (!args
->next
->name
)
2348 for (arg
= args
; arg
; arg
= arg
->next
)
2355 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2357 nlabels
= XALLOCAVEC (int, nargs
);
2358 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2364 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2366 n
= strtol (&arg
->name
[1], &endp
, 10);
2367 if (endp
[0] != '\0')
2371 if (n
<= nlabelless
)
2384 gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
2385 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2386 gfc_current_intrinsic_where
);
2390 /* Check for duplicates. */
2391 for (i
= 0; i
< nargs
; i
++)
2392 for (j
= i
+ 1; j
< nargs
; j
++)
2393 if (nlabels
[i
] == nlabels
[j
])
2399 gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg
->name
,
2400 &arg
->expr
->where
, gfc_current_intrinsic
);
2404 gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg
->name
,
2405 &arg
->expr
->where
, gfc_current_intrinsic
);
2411 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2413 gfc_actual_arglist
*arg
, *tmp
;
2417 if (!min_max_args (arglist
))
2420 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2423 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2425 if (x
->ts
.type
== type
)
2427 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
2428 "kinds at %L", &x
->where
))
2433 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2434 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2435 gfc_basic_typename (type
), kind
);
2440 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2441 if (!gfc_check_conformance (tmp
->expr
, x
,
2442 "arguments 'a%d' and 'a%d' for "
2443 "intrinsic '%s'", m
, n
,
2444 gfc_current_intrinsic
))
2453 gfc_check_min_max (gfc_actual_arglist
*arg
)
2457 if (!min_max_args (arg
))
2462 if (x
->ts
.type
== BT_CHARACTER
)
2464 if (!gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2465 "with CHARACTER argument at %L",
2466 gfc_current_intrinsic
, &x
->where
))
2469 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2471 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2472 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2476 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2481 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2483 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2488 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2490 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2495 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2497 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2501 /* End of min/max family. */
2504 gfc_check_malloc (gfc_expr
*size
)
2506 if (!type_check (size
, 0, BT_INTEGER
))
2509 if (!scalar_check (size
, 0))
2517 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2519 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2521 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2522 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2523 gfc_current_intrinsic
, &matrix_a
->where
);
2527 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2529 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2530 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2531 gfc_current_intrinsic
, &matrix_b
->where
);
2535 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2536 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2538 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2539 gfc_current_intrinsic
, &matrix_a
->where
,
2540 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2544 switch (matrix_a
->rank
)
2547 if (!rank_check (matrix_b
, 1, 2))
2549 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2550 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2552 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2553 "and '%s' at %L for intrinsic matmul",
2554 gfc_current_intrinsic_arg
[0]->name
,
2555 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2561 if (matrix_b
->rank
!= 2)
2563 if (!rank_check (matrix_b
, 1, 1))
2566 /* matrix_b has rank 1 or 2 here. Common check for the cases
2567 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2568 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2569 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2571 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2572 "dimension 1 for argument '%s' at %L for intrinsic "
2573 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2574 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2580 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2581 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
2582 gfc_current_intrinsic
, &matrix_a
->where
);
2590 /* Whoever came up with this interface was probably on something.
2591 The possibilities for the occupation of the second and third
2598 NULL MASK minloc(array, mask=m)
2601 I.e. in the case of minloc(array,mask), mask will be in the second
2602 position of the argument list and we'll have to fix that up. */
2605 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
2607 gfc_expr
*a
, *m
, *d
;
2610 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
2614 m
= ap
->next
->next
->expr
;
2616 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2617 && ap
->next
->name
== NULL
)
2621 ap
->next
->expr
= NULL
;
2622 ap
->next
->next
->expr
= m
;
2625 if (!dim_check (d
, 1, false))
2628 if (!dim_rank_check (d
, a
, 0))
2631 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
2635 && !gfc_check_conformance (a
, m
,
2636 "arguments '%s' and '%s' for intrinsic %s",
2637 gfc_current_intrinsic_arg
[0]->name
,
2638 gfc_current_intrinsic_arg
[2]->name
,
2639 gfc_current_intrinsic
))
2646 /* Similar to minloc/maxloc, the argument list might need to be
2647 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2648 difference is that MINLOC/MAXLOC take an additional KIND argument.
2649 The possibilities are:
2655 NULL MASK minval(array, mask=m)
2658 I.e. in the case of minval(array,mask), mask will be in the second
2659 position of the argument list and we'll have to fix that up. */
2662 check_reduction (gfc_actual_arglist
*ap
)
2664 gfc_expr
*a
, *m
, *d
;
2668 m
= ap
->next
->next
->expr
;
2670 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2671 && ap
->next
->name
== NULL
)
2675 ap
->next
->expr
= NULL
;
2676 ap
->next
->next
->expr
= m
;
2679 if (!dim_check (d
, 1, false))
2682 if (!dim_rank_check (d
, a
, 0))
2685 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
2689 && !gfc_check_conformance (a
, m
,
2690 "arguments '%s' and '%s' for intrinsic %s",
2691 gfc_current_intrinsic_arg
[0]->name
,
2692 gfc_current_intrinsic_arg
[2]->name
,
2693 gfc_current_intrinsic
))
2701 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
2703 if (!int_or_real_check (ap
->expr
, 0)
2704 || !array_check (ap
->expr
, 0))
2707 return check_reduction (ap
);
2712 gfc_check_product_sum (gfc_actual_arglist
*ap
)
2714 if (!numeric_check (ap
->expr
, 0)
2715 || !array_check (ap
->expr
, 0))
2718 return check_reduction (ap
);
2722 /* For IANY, IALL and IPARITY. */
2725 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
2729 if (!type_check (i
, 0, BT_INTEGER
))
2732 if (!nonnegative_check ("I", i
))
2735 if (!kind_check (kind
, 1, BT_INTEGER
))
2739 gfc_extract_int (kind
, &k
);
2741 k
= gfc_default_integer_kind
;
2743 if (!less_than_bitsizekind ("I", i
, k
))
2751 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
2753 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
2755 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2756 gfc_current_intrinsic_arg
[0]->name
,
2757 gfc_current_intrinsic
, &ap
->expr
->where
);
2761 if (!array_check (ap
->expr
, 0))
2764 return check_reduction (ap
);
2769 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
2771 if (!same_type_check (tsource
, 0, fsource
, 1))
2774 if (!type_check (mask
, 2, BT_LOGICAL
))
2777 if (tsource
->ts
.type
== BT_CHARACTER
)
2778 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
2785 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
2787 if (!type_check (i
, 0, BT_INTEGER
))
2790 if (!type_check (j
, 1, BT_INTEGER
))
2793 if (!type_check (mask
, 2, BT_INTEGER
))
2796 if (!same_type_check (i
, 0, j
, 1))
2799 if (!same_type_check (i
, 0, mask
, 2))
2807 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
2809 if (!variable_check (from
, 0, false))
2811 if (!allocatable_check (from
, 0))
2813 if (gfc_is_coindexed (from
))
2815 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
2816 "coindexed", &from
->where
);
2820 if (!variable_check (to
, 1, false))
2822 if (!allocatable_check (to
, 1))
2824 if (gfc_is_coindexed (to
))
2826 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
2827 "coindexed", &to
->where
);
2831 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
2833 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2834 "polymorphic if FROM is polymorphic",
2839 if (!same_type_check (to
, 1, from
, 0))
2842 if (to
->rank
!= from
->rank
)
2844 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2845 "must have the same rank %d/%d", &to
->where
, from
->rank
,
2850 /* IR F08/0040; cf. 12-006A. */
2851 if (gfc_get_corank (to
) != gfc_get_corank (from
))
2853 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2854 "must have the same corank %d/%d", &to
->where
,
2855 gfc_get_corank (from
), gfc_get_corank (to
));
2859 /* CLASS arguments: Make sure the vtab of from is present. */
2860 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
2861 gfc_find_vtab (&from
->ts
);
2868 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
2870 if (!type_check (x
, 0, BT_REAL
))
2873 if (!type_check (s
, 1, BT_REAL
))
2876 if (s
->expr_type
== EXPR_CONSTANT
)
2878 if (mpfr_sgn (s
->value
.real
) == 0)
2880 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2891 gfc_check_new_line (gfc_expr
*a
)
2893 if (!type_check (a
, 0, BT_CHARACTER
))
2901 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
2903 if (!type_check (array
, 0, BT_REAL
))
2906 if (!array_check (array
, 0))
2909 if (!dim_rank_check (dim
, array
, false))
2916 gfc_check_null (gfc_expr
*mold
)
2918 symbol_attribute attr
;
2923 if (!variable_check (mold
, 0, true))
2926 attr
= gfc_variable_attr (mold
, NULL
);
2928 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
2930 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2931 "ALLOCATABLE or procedure pointer",
2932 gfc_current_intrinsic_arg
[0]->name
,
2933 gfc_current_intrinsic
, &mold
->where
);
2937 if (attr
.allocatable
2938 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
2939 "allocatable MOLD at %L", &mold
->where
))
2943 if (gfc_is_coindexed (mold
))
2945 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2946 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
2947 gfc_current_intrinsic
, &mold
->where
);
2956 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
2958 if (!array_check (array
, 0))
2961 if (!type_check (mask
, 1, BT_LOGICAL
))
2964 if (!gfc_check_conformance (array
, mask
,
2965 "arguments '%s' and '%s' for intrinsic '%s'",
2966 gfc_current_intrinsic_arg
[0]->name
,
2967 gfc_current_intrinsic_arg
[1]->name
,
2968 gfc_current_intrinsic
))
2973 mpz_t array_size
, vector_size
;
2974 bool have_array_size
, have_vector_size
;
2976 if (!same_type_check (array
, 0, vector
, 2))
2979 if (!rank_check (vector
, 2, 1))
2982 /* VECTOR requires at least as many elements as MASK
2983 has .TRUE. values. */
2984 have_array_size
= gfc_array_size(array
, &array_size
);
2985 have_vector_size
= gfc_array_size(vector
, &vector_size
);
2987 if (have_vector_size
2988 && (mask
->expr_type
== EXPR_ARRAY
2989 || (mask
->expr_type
== EXPR_CONSTANT
2990 && have_array_size
)))
2992 int mask_true_values
= 0;
2994 if (mask
->expr_type
== EXPR_ARRAY
)
2996 gfc_constructor
*mask_ctor
;
2997 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3000 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3002 mask_true_values
= 0;
3006 if (mask_ctor
->expr
->value
.logical
)
3009 mask_ctor
= gfc_constructor_next (mask_ctor
);
3012 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3013 mask_true_values
= mpz_get_si (array_size
);
3015 if (mpz_get_si (vector_size
) < mask_true_values
)
3017 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3018 "provide at least as many elements as there "
3019 "are .TRUE. values in '%s' (%ld/%d)",
3020 gfc_current_intrinsic_arg
[2]->name
,
3021 gfc_current_intrinsic
, &vector
->where
,
3022 gfc_current_intrinsic_arg
[1]->name
,
3023 mpz_get_si (vector_size
), mask_true_values
);
3028 if (have_array_size
)
3029 mpz_clear (array_size
);
3030 if (have_vector_size
)
3031 mpz_clear (vector_size
);
3039 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3041 if (!type_check (mask
, 0, BT_LOGICAL
))
3044 if (!array_check (mask
, 0))
3047 if (!dim_rank_check (dim
, mask
, false))
3055 gfc_check_precision (gfc_expr
*x
)
3057 if (!real_or_complex_check (x
, 0))
3065 gfc_check_present (gfc_expr
*a
)
3069 if (!variable_check (a
, 0, true))
3072 sym
= a
->symtree
->n
.sym
;
3073 if (!sym
->attr
.dummy
)
3075 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3076 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3077 gfc_current_intrinsic
, &a
->where
);
3081 if (!sym
->attr
.optional
)
3083 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3084 "an OPTIONAL dummy variable",
3085 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3090 /* 13.14.82 PRESENT(A)
3092 Argument. A shall be the name of an optional dummy argument that is
3093 accessible in the subprogram in which the PRESENT function reference
3097 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3098 && (a
->ref
->u
.ar
.type
== AR_FULL
3099 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3100 && a
->ref
->u
.ar
.as
->rank
== 0))))
3102 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3103 "subobject of '%s'", gfc_current_intrinsic_arg
[0]->name
,
3104 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3113 gfc_check_radix (gfc_expr
*x
)
3115 if (!int_or_real_check (x
, 0))
3123 gfc_check_range (gfc_expr
*x
)
3125 if (!numeric_check (x
, 0))
3133 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3135 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3136 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3138 bool is_variable
= true;
3140 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3141 if (a
->expr_type
== EXPR_FUNCTION
)
3142 is_variable
= a
->value
.function
.esym
3143 ? a
->value
.function
.esym
->result
->attr
.pointer
3144 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3146 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3147 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3150 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3151 "object", &a
->where
);
3159 /* real, float, sngl. */
3161 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3163 if (!numeric_check (a
, 0))
3166 if (!kind_check (kind
, 1, BT_REAL
))
3174 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3176 if (!type_check (path1
, 0, BT_CHARACTER
))
3178 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3181 if (!type_check (path2
, 1, BT_CHARACTER
))
3183 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3191 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3193 if (!type_check (path1
, 0, BT_CHARACTER
))
3195 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3198 if (!type_check (path2
, 1, BT_CHARACTER
))
3200 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3206 if (!type_check (status
, 2, BT_INTEGER
))
3209 if (!scalar_check (status
, 2))
3217 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3219 if (!type_check (x
, 0, BT_CHARACTER
))
3222 if (!scalar_check (x
, 0))
3225 if (!type_check (y
, 0, BT_INTEGER
))
3228 if (!scalar_check (y
, 1))
3236 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3237 gfc_expr
*pad
, gfc_expr
*order
)
3243 if (!array_check (source
, 0))
3246 if (!rank_check (shape
, 1, 1))
3249 if (!type_check (shape
, 1, BT_INTEGER
))
3252 if (!gfc_array_size (shape
, &size
))
3254 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3255 "array of constant size", &shape
->where
);
3259 shape_size
= mpz_get_ui (size
);
3262 if (shape_size
<= 0)
3264 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3265 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3269 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3271 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3272 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3275 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3279 for (i
= 0; i
< shape_size
; ++i
)
3281 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3282 if (e
->expr_type
!= EXPR_CONSTANT
)
3285 gfc_extract_int (e
, &extent
);
3288 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3289 "negative element (%d)",
3290 gfc_current_intrinsic_arg
[1]->name
,
3291 gfc_current_intrinsic
, &e
->where
, extent
);
3299 if (!same_type_check (source
, 0, pad
, 2))
3302 if (!array_check (pad
, 2))
3308 if (!array_check (order
, 3))
3311 if (!type_check (order
, 3, BT_INTEGER
))
3314 if (order
->expr_type
== EXPR_ARRAY
)
3316 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3319 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3322 gfc_array_size (order
, &size
);
3323 order_size
= mpz_get_ui (size
);
3326 if (order_size
!= shape_size
)
3328 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3329 "has wrong number of elements (%d/%d)",
3330 gfc_current_intrinsic_arg
[3]->name
,
3331 gfc_current_intrinsic
, &order
->where
,
3332 order_size
, shape_size
);
3336 for (i
= 1; i
<= order_size
; ++i
)
3338 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3339 if (e
->expr_type
!= EXPR_CONSTANT
)
3342 gfc_extract_int (e
, &dim
);
3344 if (dim
< 1 || dim
> order_size
)
3346 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3347 "has out-of-range dimension (%d)",
3348 gfc_current_intrinsic_arg
[3]->name
,
3349 gfc_current_intrinsic
, &e
->where
, dim
);
3353 if (perm
[dim
-1] != 0)
3355 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3356 "invalid permutation of dimensions (dimension "
3358 gfc_current_intrinsic_arg
[3]->name
,
3359 gfc_current_intrinsic
, &e
->where
, dim
);
3368 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3369 && gfc_is_constant_expr (shape
)
3370 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3371 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3373 /* Check the match in size between source and destination. */
3374 if (gfc_array_size (source
, &nelems
))
3380 mpz_init_set_ui (size
, 1);
3381 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3382 c
; c
= gfc_constructor_next (c
))
3383 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3385 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3391 gfc_error ("Without padding, there are not enough elements "
3392 "in the intrinsic RESHAPE source at %L to match "
3393 "the shape", &source
->where
);
3404 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3406 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3408 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3409 "cannot be of type %s",
3410 gfc_current_intrinsic_arg
[0]->name
,
3411 gfc_current_intrinsic
,
3412 &a
->where
, gfc_typename (&a
->ts
));
3416 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3418 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3419 "must be of an extensible type",
3420 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3425 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3427 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3428 "cannot be of type %s",
3429 gfc_current_intrinsic_arg
[0]->name
,
3430 gfc_current_intrinsic
,
3431 &b
->where
, gfc_typename (&b
->ts
));
3435 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3437 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3438 "must be of an extensible type",
3439 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3449 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3451 if (!type_check (x
, 0, BT_REAL
))
3454 if (!type_check (i
, 1, BT_INTEGER
))
3462 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3464 if (!type_check (x
, 0, BT_CHARACTER
))
3467 if (!type_check (y
, 1, BT_CHARACTER
))
3470 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
3473 if (!kind_check (kind
, 3, BT_INTEGER
))
3475 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3476 "with KIND argument at %L",
3477 gfc_current_intrinsic
, &kind
->where
))
3480 if (!same_type_check (x
, 0, y
, 1))
3488 gfc_check_secnds (gfc_expr
*r
)
3490 if (!type_check (r
, 0, BT_REAL
))
3493 if (!kind_value_check (r
, 0, 4))
3496 if (!scalar_check (r
, 0))
3504 gfc_check_selected_char_kind (gfc_expr
*name
)
3506 if (!type_check (name
, 0, BT_CHARACTER
))
3509 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
3512 if (!scalar_check (name
, 0))
3520 gfc_check_selected_int_kind (gfc_expr
*r
)
3522 if (!type_check (r
, 0, BT_INTEGER
))
3525 if (!scalar_check (r
, 0))
3533 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3535 if (p
== NULL
&& r
== NULL
3536 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
3537 " neither 'P' nor 'R' argument at %L",
3538 gfc_current_intrinsic_where
))
3543 if (!type_check (p
, 0, BT_INTEGER
))
3546 if (!scalar_check (p
, 0))
3552 if (!type_check (r
, 1, BT_INTEGER
))
3555 if (!scalar_check (r
, 1))
3561 if (!type_check (radix
, 1, BT_INTEGER
))
3564 if (!scalar_check (radix
, 1))
3567 if (!gfc_notify_std (GFC_STD_F2008
, "'%s' intrinsic with "
3568 "RADIX argument at %L", gfc_current_intrinsic
,
3578 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3580 if (!type_check (x
, 0, BT_REAL
))
3583 if (!type_check (i
, 1, BT_INTEGER
))
3591 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
3595 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3598 ar
= gfc_find_array_ref (source
);
3600 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
3602 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3603 "an assumed size array", &source
->where
);
3607 if (!kind_check (kind
, 1, BT_INTEGER
))
3609 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3610 "with KIND argument at %L",
3611 gfc_current_intrinsic
, &kind
->where
))
3619 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
3621 if (!type_check (i
, 0, BT_INTEGER
))
3624 if (!type_check (shift
, 0, BT_INTEGER
))
3627 if (!nonnegative_check ("SHIFT", shift
))
3630 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
3638 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
3640 if (!int_or_real_check (a
, 0))
3643 if (!same_type_check (a
, 0, b
, 1))
3651 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3653 if (!array_check (array
, 0))
3656 if (!dim_check (dim
, 1, true))
3659 if (!dim_rank_check (dim
, array
, 0))
3662 if (!kind_check (kind
, 2, BT_INTEGER
))
3664 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3665 "with KIND argument at %L",
3666 gfc_current_intrinsic
, &kind
->where
))
3675 gfc_check_sizeof (gfc_expr
*arg
)
3677 if (arg
->ts
.type
== BT_PROCEDURE
)
3679 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
3680 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3685 if (arg
->ts
.type
== BT_ASSUMED
)
3687 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
3688 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3693 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
3694 && arg
->symtree
->n
.sym
->as
!= NULL
3695 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
3696 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
3698 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3699 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
3700 gfc_current_intrinsic
, &arg
->where
);
3708 /* Check whether an expression is interoperable. When returning false,
3709 msg is set to a string telling why the expression is not interoperable,
3710 otherwise, it is set to NULL. The msg string can be used in diagnostics.
3711 If c_loc is true, character with len > 1 are allowed (cf. Fortran
3712 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
3713 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
3717 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
3721 if (expr
->ts
.type
== BT_CLASS
)
3723 *msg
= "Expression is polymorphic";
3727 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
3728 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
3730 *msg
= "Expression is a noninteroperable derived type";
3734 if (expr
->ts
.type
== BT_PROCEDURE
)
3736 *msg
= "Procedure unexpected as argument";
3740 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
3743 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
3744 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
3746 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
3750 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
3751 && expr
->ts
.kind
!= 1)
3753 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
3757 if (expr
->ts
.type
== BT_CHARACTER
) {
3758 if (expr
->ts
.deferred
)
3760 /* TS 29113 allows deferred-length strings as dummy arguments,
3761 but it is not an interoperable type. */
3762 *msg
= "Expression shall not be a deferred-length string";
3766 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
3767 && !gfc_simplify_expr (expr
, 0))
3768 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
3770 if (!c_loc
&& expr
->ts
.u
.cl
3771 && (!expr
->ts
.u
.cl
->length
3772 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3773 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
3775 *msg
= "Type shall have a character length of 1";
3780 /* Note: The following checks are about interoperatable variables, Fortran
3781 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
3782 is allowed, e.g. assumed-shape arrays with TS 29113. */
3784 if (gfc_is_coarray (expr
))
3786 *msg
= "Coarrays are not interoperable";
3790 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
3792 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
3793 if (ar
->type
!= AR_FULL
)
3795 *msg
= "Only whole-arrays are interoperable";
3798 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
3799 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
3801 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
3811 gfc_check_c_sizeof (gfc_expr
*arg
)
3815 if (!is_c_interoperable (arg
, &msg
, false, false))
3817 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3818 "interoperable data entity: %s",
3819 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3824 if (arg
->ts
.type
== BT_ASSUMED
)
3826 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
3828 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3833 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
3834 && arg
->symtree
->n
.sym
->as
!= NULL
3835 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
3836 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
3838 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3839 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
3840 gfc_current_intrinsic
, &arg
->where
);
3849 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
3851 if (c_ptr_1
->ts
.type
!= BT_DERIVED
3852 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3853 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
3854 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
3856 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
3857 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
3861 if (!scalar_check (c_ptr_1
, 0))
3865 && (c_ptr_2
->ts
.type
!= BT_DERIVED
3866 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3867 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
3868 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
3870 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
3871 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
3872 gfc_typename (&c_ptr_1
->ts
),
3873 gfc_typename (&c_ptr_2
->ts
));
3877 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
3885 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
3887 symbol_attribute attr
;
3890 if (cptr
->ts
.type
!= BT_DERIVED
3891 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3892 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
3894 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
3895 "type TYPE(C_PTR)", &cptr
->where
);
3899 if (!scalar_check (cptr
, 0))
3902 attr
= gfc_expr_attr (fptr
);
3906 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
3911 if (fptr
->ts
.type
== BT_CLASS
)
3913 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
3918 if (gfc_is_coindexed (fptr
))
3920 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
3921 "coindexed", &fptr
->where
);
3925 if (fptr
->rank
== 0 && shape
)
3927 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
3928 "FPTR", &fptr
->where
);
3931 else if (fptr
->rank
&& !shape
)
3933 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
3934 "FPTR at %L", &fptr
->where
);
3938 if (shape
&& !rank_check (shape
, 2, 1))
3941 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
3948 if (gfc_array_size (shape
, &size
)
3949 && mpz_cmp_ui (size
, fptr
->rank
) != 0)
3952 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
3953 "size as the RANK of FPTR", &shape
->where
);
3959 if (fptr
->ts
.type
== BT_CLASS
)
3961 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
3965 if (!is_c_interoperable (fptr
, &msg
, false, true))
3966 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
3967 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
3974 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
3976 symbol_attribute attr
;
3978 if (cptr
->ts
.type
!= BT_DERIVED
3979 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
3980 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
3982 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
3983 "type TYPE(C_FUNPTR)", &cptr
->where
);
3987 if (!scalar_check (cptr
, 0))
3990 attr
= gfc_expr_attr (fptr
);
3992 if (!attr
.proc_pointer
)
3994 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
3995 "pointer", &fptr
->where
);
3999 if (gfc_is_coindexed (fptr
))
4001 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4002 "coindexed", &fptr
->where
);
4006 if (!attr
.is_bind_c
)
4007 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4008 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4015 gfc_check_c_funloc (gfc_expr
*x
)
4017 symbol_attribute attr
;
4019 if (gfc_is_coindexed (x
))
4021 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4022 "coindexed", &x
->where
);
4026 attr
= gfc_expr_attr (x
);
4028 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4029 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4031 gfc_namespace
*ns
= gfc_current_ns
;
4033 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4034 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4036 gfc_error ("Function result '%s' at %L is invalid as X argument "
4037 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4042 if (attr
.flavor
!= FL_PROCEDURE
)
4044 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4045 "or a procedure pointer", &x
->where
);
4049 if (!attr
.is_bind_c
)
4050 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4051 "at %L to C_FUNLOC", &x
->where
);
4057 gfc_check_c_loc (gfc_expr
*x
)
4059 symbol_attribute attr
;
4062 if (gfc_is_coindexed (x
))
4064 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4068 if (x
->ts
.type
== BT_CLASS
)
4070 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4075 attr
= gfc_expr_attr (x
);
4078 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4079 || attr
.flavor
== FL_PARAMETER
))
4081 gfc_error ("Argument X at %L to C_LOC shall have either "
4082 "the POINTER or the TARGET attribute", &x
->where
);
4086 if (x
->ts
.type
== BT_CHARACTER
4087 && gfc_var_strlen (x
) == 0)
4089 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4090 "string", &x
->where
);
4094 if (!is_c_interoperable (x
, &msg
, true, false))
4096 if (x
->ts
.type
== BT_CLASS
)
4098 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4104 && !gfc_notify_std (GFC_STD_F2008_TS
,
4105 "Noninteroperable array at %L as"
4106 " argument to C_LOC: %s", &x
->where
, msg
))
4109 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4111 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4113 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4114 && !attr
.allocatable
4115 && !gfc_notify_std (GFC_STD_F2008
,
4116 "Array of interoperable type at %L "
4117 "to C_LOC which is nonallocatable and neither "
4118 "assumed size nor explicit size", &x
->where
))
4120 else if (ar
->type
!= AR_FULL
4121 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4122 "to C_LOC", &x
->where
))
4131 gfc_check_sleep_sub (gfc_expr
*seconds
)
4133 if (!type_check (seconds
, 0, BT_INTEGER
))
4136 if (!scalar_check (seconds
, 0))
4143 gfc_check_sngl (gfc_expr
*a
)
4145 if (!type_check (a
, 0, BT_REAL
))
4148 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4149 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4150 "REAL argument to %s intrinsic at %L",
4151 gfc_current_intrinsic
, &a
->where
))
4158 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4160 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4162 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
4163 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4164 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4172 if (!dim_check (dim
, 1, false))
4175 /* dim_rank_check() does not apply here. */
4177 && dim
->expr_type
== EXPR_CONSTANT
4178 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4179 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4181 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
4182 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4183 gfc_current_intrinsic
, &dim
->where
);
4187 if (!type_check (ncopies
, 2, BT_INTEGER
))
4190 if (!scalar_check (ncopies
, 2))
4197 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4201 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4203 if (!type_check (unit
, 0, BT_INTEGER
))
4206 if (!scalar_check (unit
, 0))
4209 if (!type_check (c
, 1, BT_CHARACTER
))
4211 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4217 if (!type_check (status
, 2, BT_INTEGER
)
4218 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4219 || !scalar_check (status
, 2))
4227 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4229 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4234 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4236 if (!type_check (c
, 0, BT_CHARACTER
))
4238 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4244 if (!type_check (status
, 1, BT_INTEGER
)
4245 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4246 || !scalar_check (status
, 1))
4254 gfc_check_fgetput (gfc_expr
*c
)
4256 return gfc_check_fgetput_sub (c
, NULL
);
4261 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4263 if (!type_check (unit
, 0, BT_INTEGER
))
4266 if (!scalar_check (unit
, 0))
4269 if (!type_check (offset
, 1, BT_INTEGER
))
4272 if (!scalar_check (offset
, 1))
4275 if (!type_check (whence
, 2, BT_INTEGER
))
4278 if (!scalar_check (whence
, 2))
4284 if (!type_check (status
, 3, BT_INTEGER
))
4287 if (!kind_value_check (status
, 3, 4))
4290 if (!scalar_check (status
, 3))
4299 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4301 if (!type_check (unit
, 0, BT_INTEGER
))
4304 if (!scalar_check (unit
, 0))
4307 if (!type_check (array
, 1, BT_INTEGER
)
4308 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4311 if (!array_check (array
, 1))
4319 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4321 if (!type_check (unit
, 0, BT_INTEGER
))
4324 if (!scalar_check (unit
, 0))
4327 if (!type_check (array
, 1, BT_INTEGER
)
4328 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4331 if (!array_check (array
, 1))
4337 if (!type_check (status
, 2, BT_INTEGER
)
4338 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4341 if (!scalar_check (status
, 2))
4349 gfc_check_ftell (gfc_expr
*unit
)
4351 if (!type_check (unit
, 0, BT_INTEGER
))
4354 if (!scalar_check (unit
, 0))
4362 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4364 if (!type_check (unit
, 0, BT_INTEGER
))
4367 if (!scalar_check (unit
, 0))
4370 if (!type_check (offset
, 1, BT_INTEGER
))
4373 if (!scalar_check (offset
, 1))
4381 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4383 if (!type_check (name
, 0, BT_CHARACTER
))
4385 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4388 if (!type_check (array
, 1, BT_INTEGER
)
4389 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4392 if (!array_check (array
, 1))
4400 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4402 if (!type_check (name
, 0, BT_CHARACTER
))
4404 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4407 if (!type_check (array
, 1, BT_INTEGER
)
4408 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4411 if (!array_check (array
, 1))
4417 if (!type_check (status
, 2, BT_INTEGER
)
4418 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4421 if (!scalar_check (status
, 2))
4429 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4433 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4435 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4439 if (!coarray_check (coarray
, 0))
4444 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4445 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
4449 if (gfc_array_size (sub
, &nelems
))
4451 int corank
= gfc_get_corank (coarray
);
4453 if (mpz_cmp_ui (nelems
, corank
) != 0)
4455 gfc_error ("The number of array elements of the SUB argument to "
4456 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4457 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
4469 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
)
4471 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4473 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4477 if (dim
!= NULL
&& coarray
== NULL
)
4479 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
4480 "intrinsic at %L", &dim
->where
);
4484 if (coarray
== NULL
)
4487 if (!coarray_check (coarray
, 0))
4492 if (!dim_check (dim
, 1, false))
4495 if (!dim_corank_check (dim
, coarray
))
4502 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4503 by gfc_simplify_transfer. Return false if we cannot do so. */
4506 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
4507 size_t *source_size
, size_t *result_size
,
4508 size_t *result_length_p
)
4510 size_t result_elt_size
;
4512 if (source
->expr_type
== EXPR_FUNCTION
)
4515 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
4518 /* Calculate the size of the source. */
4519 *source_size
= gfc_target_expr_size (source
);
4520 if (*source_size
== 0)
4523 /* Determine the size of the element. */
4524 result_elt_size
= gfc_element_size (mold
);
4525 if (result_elt_size
== 0)
4528 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
4533 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
4536 result_length
= *source_size
/ result_elt_size
;
4537 if (result_length
* result_elt_size
< *source_size
)
4541 *result_size
= result_length
* result_elt_size
;
4542 if (result_length_p
)
4543 *result_length_p
= result_length
;
4546 *result_size
= result_elt_size
;
4553 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
4558 if (mold
->ts
.type
== BT_HOLLERITH
)
4560 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4561 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
4567 if (!type_check (size
, 2, BT_INTEGER
))
4570 if (!scalar_check (size
, 2))
4573 if (!nonoptional_check (size
, 2))
4577 if (!gfc_option
.warn_surprising
)
4580 /* If we can't calculate the sizes, we cannot check any more.
4581 Return true for that case. */
4583 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
4584 &result_size
, NULL
))
4587 if (source_size
< result_size
)
4588 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4589 "source size %ld < result size %ld", &source
->where
,
4590 (long) source_size
, (long) result_size
);
4597 gfc_check_transpose (gfc_expr
*matrix
)
4599 if (!rank_check (matrix
, 0, 2))
4607 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4609 if (!array_check (array
, 0))
4612 if (!dim_check (dim
, 1, false))
4615 if (!dim_rank_check (dim
, array
, 0))
4618 if (!kind_check (kind
, 2, BT_INTEGER
))
4620 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4621 "with KIND argument at %L",
4622 gfc_current_intrinsic
, &kind
->where
))
4630 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
4632 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4634 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4638 if (!coarray_check (coarray
, 0))
4643 if (!dim_check (dim
, 1, false))
4646 if (!dim_corank_check (dim
, coarray
))
4650 if (!kind_check (kind
, 2, BT_INTEGER
))
4658 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
4662 if (!rank_check (vector
, 0, 1))
4665 if (!array_check (mask
, 1))
4668 if (!type_check (mask
, 1, BT_LOGICAL
))
4671 if (!same_type_check (vector
, 0, field
, 2))
4674 if (mask
->expr_type
== EXPR_ARRAY
4675 && gfc_array_size (vector
, &vector_size
))
4677 int mask_true_count
= 0;
4678 gfc_constructor
*mask_ctor
;
4679 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4682 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4684 mask_true_count
= 0;
4688 if (mask_ctor
->expr
->value
.logical
)
4691 mask_ctor
= gfc_constructor_next (mask_ctor
);
4694 if (mpz_get_si (vector_size
) < mask_true_count
)
4696 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4697 "provide at least as many elements as there "
4698 "are .TRUE. values in '%s' (%ld/%d)",
4699 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4700 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
4701 mpz_get_si (vector_size
), mask_true_count
);
4705 mpz_clear (vector_size
);
4708 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
4710 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4711 "the same rank as '%s' or be a scalar",
4712 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
4713 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
4717 if (mask
->rank
== field
->rank
)
4720 for (i
= 0; i
< field
->rank
; i
++)
4721 if (! identical_dimen_shape (mask
, i
, field
, i
))
4723 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4724 "must have identical shape.",
4725 gfc_current_intrinsic_arg
[2]->name
,
4726 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4736 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4738 if (!type_check (x
, 0, BT_CHARACTER
))
4741 if (!same_type_check (x
, 0, y
, 1))
4744 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4747 if (!kind_check (kind
, 3, BT_INTEGER
))
4749 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4750 "with KIND argument at %L",
4751 gfc_current_intrinsic
, &kind
->where
))
4759 gfc_check_trim (gfc_expr
*x
)
4761 if (!type_check (x
, 0, BT_CHARACTER
))
4764 if (!scalar_check (x
, 0))
4772 gfc_check_ttynam (gfc_expr
*unit
)
4774 if (!scalar_check (unit
, 0))
4777 if (!type_check (unit
, 0, BT_INTEGER
))
4784 /* Common check function for the half a dozen intrinsics that have a
4785 single real argument. */
4788 gfc_check_x (gfc_expr
*x
)
4790 if (!type_check (x
, 0, BT_REAL
))
4797 /************* Check functions for intrinsic subroutines *************/
4800 gfc_check_cpu_time (gfc_expr
*time
)
4802 if (!scalar_check (time
, 0))
4805 if (!type_check (time
, 0, BT_REAL
))
4808 if (!variable_check (time
, 0, false))
4816 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
4817 gfc_expr
*zone
, gfc_expr
*values
)
4821 if (!type_check (date
, 0, BT_CHARACTER
))
4823 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
4825 if (!scalar_check (date
, 0))
4827 if (!variable_check (date
, 0, false))
4833 if (!type_check (time
, 1, BT_CHARACTER
))
4835 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
4837 if (!scalar_check (time
, 1))
4839 if (!variable_check (time
, 1, false))
4845 if (!type_check (zone
, 2, BT_CHARACTER
))
4847 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
4849 if (!scalar_check (zone
, 2))
4851 if (!variable_check (zone
, 2, false))
4857 if (!type_check (values
, 3, BT_INTEGER
))
4859 if (!array_check (values
, 3))
4861 if (!rank_check (values
, 3, 1))
4863 if (!variable_check (values
, 3, false))
4872 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
4873 gfc_expr
*to
, gfc_expr
*topos
)
4875 if (!type_check (from
, 0, BT_INTEGER
))
4878 if (!type_check (frompos
, 1, BT_INTEGER
))
4881 if (!type_check (len
, 2, BT_INTEGER
))
4884 if (!same_type_check (from
, 0, to
, 3))
4887 if (!variable_check (to
, 3, false))
4890 if (!type_check (topos
, 4, BT_INTEGER
))
4893 if (!nonnegative_check ("frompos", frompos
))
4896 if (!nonnegative_check ("topos", topos
))
4899 if (!nonnegative_check ("len", len
))
4902 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
4905 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
4913 gfc_check_random_number (gfc_expr
*harvest
)
4915 if (!type_check (harvest
, 0, BT_REAL
))
4918 if (!variable_check (harvest
, 0, false))
4926 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
4928 unsigned int nargs
= 0, kiss_size
;
4929 locus
*where
= NULL
;
4930 mpz_t put_size
, get_size
;
4931 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4933 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
4935 /* Keep the number of bytes in sync with kiss_size in
4936 libgfortran/intrinsics/random.c. */
4937 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
4941 if (size
->expr_type
!= EXPR_VARIABLE
4942 || !size
->symtree
->n
.sym
->attr
.optional
)
4945 if (!scalar_check (size
, 0))
4948 if (!type_check (size
, 0, BT_INTEGER
))
4951 if (!variable_check (size
, 0, false))
4954 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
4960 if (put
->expr_type
!= EXPR_VARIABLE
4961 || !put
->symtree
->n
.sym
->attr
.optional
)
4964 where
= &put
->where
;
4967 if (!array_check (put
, 1))
4970 if (!rank_check (put
, 1, 1))
4973 if (!type_check (put
, 1, BT_INTEGER
))
4976 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
4979 if (gfc_array_size (put
, &put_size
)
4980 && mpz_get_ui (put_size
) < kiss_size
)
4981 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4982 "too small (%i/%i)",
4983 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4984 where
, (int) mpz_get_ui (put_size
), kiss_size
);
4989 if (get
->expr_type
!= EXPR_VARIABLE
4990 || !get
->symtree
->n
.sym
->attr
.optional
)
4993 where
= &get
->where
;
4996 if (!array_check (get
, 2))
4999 if (!rank_check (get
, 2, 1))
5002 if (!type_check (get
, 2, BT_INTEGER
))
5005 if (!variable_check (get
, 2, false))
5008 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5011 if (gfc_array_size (get
, &get_size
)
5012 && mpz_get_ui (get_size
) < kiss_size
)
5013 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5014 "too small (%i/%i)",
5015 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5016 where
, (int) mpz_get_ui (get_size
), kiss_size
);
5019 /* RANDOM_SEED may not have more than one non-optional argument. */
5021 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5028 gfc_check_second_sub (gfc_expr
*time
)
5030 if (!scalar_check (time
, 0))
5033 if (!type_check (time
, 0, BT_REAL
))
5036 if (!kind_value_check (time
, 0, 4))
5043 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
5044 count, count_rate, and count_max are all optional arguments */
5047 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5048 gfc_expr
*count_max
)
5052 if (!scalar_check (count
, 0))
5055 if (!type_check (count
, 0, BT_INTEGER
))
5058 if (!variable_check (count
, 0, false))
5062 if (count_rate
!= NULL
)
5064 if (!scalar_check (count_rate
, 1))
5067 if (!type_check (count_rate
, 1, BT_INTEGER
))
5070 if (!variable_check (count_rate
, 1, false))
5074 && !same_type_check (count
, 0, count_rate
, 1))
5079 if (count_max
!= NULL
)
5081 if (!scalar_check (count_max
, 2))
5084 if (!type_check (count_max
, 2, BT_INTEGER
))
5087 if (!variable_check (count_max
, 2, false))
5091 && !same_type_check (count
, 0, count_max
, 2))
5094 if (count_rate
!= NULL
5095 && !same_type_check (count_rate
, 1, count_max
, 2))
5104 gfc_check_irand (gfc_expr
*x
)
5109 if (!scalar_check (x
, 0))
5112 if (!type_check (x
, 0, BT_INTEGER
))
5115 if (!kind_value_check (x
, 0, 4))
5123 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5125 if (!scalar_check (seconds
, 0))
5127 if (!type_check (seconds
, 0, BT_INTEGER
))
5130 if (!int_or_proc_check (handler
, 1))
5132 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5138 if (!scalar_check (status
, 2))
5140 if (!type_check (status
, 2, BT_INTEGER
))
5142 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5150 gfc_check_rand (gfc_expr
*x
)
5155 if (!scalar_check (x
, 0))
5158 if (!type_check (x
, 0, BT_INTEGER
))
5161 if (!kind_value_check (x
, 0, 4))
5169 gfc_check_srand (gfc_expr
*x
)
5171 if (!scalar_check (x
, 0))
5174 if (!type_check (x
, 0, BT_INTEGER
))
5177 if (!kind_value_check (x
, 0, 4))
5185 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5187 if (!scalar_check (time
, 0))
5189 if (!type_check (time
, 0, BT_INTEGER
))
5192 if (!type_check (result
, 1, BT_CHARACTER
))
5194 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5202 gfc_check_dtime_etime (gfc_expr
*x
)
5204 if (!array_check (x
, 0))
5207 if (!rank_check (x
, 0, 1))
5210 if (!variable_check (x
, 0, false))
5213 if (!type_check (x
, 0, BT_REAL
))
5216 if (!kind_value_check (x
, 0, 4))
5224 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5226 if (!array_check (values
, 0))
5229 if (!rank_check (values
, 0, 1))
5232 if (!variable_check (values
, 0, false))
5235 if (!type_check (values
, 0, BT_REAL
))
5238 if (!kind_value_check (values
, 0, 4))
5241 if (!scalar_check (time
, 1))
5244 if (!type_check (time
, 1, BT_REAL
))
5247 if (!kind_value_check (time
, 1, 4))
5255 gfc_check_fdate_sub (gfc_expr
*date
)
5257 if (!type_check (date
, 0, BT_CHARACTER
))
5259 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5267 gfc_check_gerror (gfc_expr
*msg
)
5269 if (!type_check (msg
, 0, BT_CHARACTER
))
5271 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5279 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5281 if (!type_check (cwd
, 0, BT_CHARACTER
))
5283 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5289 if (!scalar_check (status
, 1))
5292 if (!type_check (status
, 1, BT_INTEGER
))
5300 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5302 if (!type_check (pos
, 0, BT_INTEGER
))
5305 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5307 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
5308 "not wider than the default kind (%d)",
5309 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5310 &pos
->where
, gfc_default_integer_kind
);
5314 if (!type_check (value
, 1, BT_CHARACTER
))
5316 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
5324 gfc_check_getlog (gfc_expr
*msg
)
5326 if (!type_check (msg
, 0, BT_CHARACTER
))
5328 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5336 gfc_check_exit (gfc_expr
*status
)
5341 if (!type_check (status
, 0, BT_INTEGER
))
5344 if (!scalar_check (status
, 0))
5352 gfc_check_flush (gfc_expr
*unit
)
5357 if (!type_check (unit
, 0, BT_INTEGER
))
5360 if (!scalar_check (unit
, 0))
5368 gfc_check_free (gfc_expr
*i
)
5370 if (!type_check (i
, 0, BT_INTEGER
))
5373 if (!scalar_check (i
, 0))
5381 gfc_check_hostnm (gfc_expr
*name
)
5383 if (!type_check (name
, 0, BT_CHARACTER
))
5385 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5393 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
5395 if (!type_check (name
, 0, BT_CHARACTER
))
5397 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5403 if (!scalar_check (status
, 1))
5406 if (!type_check (status
, 1, BT_INTEGER
))
5414 gfc_check_itime_idate (gfc_expr
*values
)
5416 if (!array_check (values
, 0))
5419 if (!rank_check (values
, 0, 1))
5422 if (!variable_check (values
, 0, false))
5425 if (!type_check (values
, 0, BT_INTEGER
))
5428 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
5436 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
5438 if (!type_check (time
, 0, BT_INTEGER
))
5441 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
5444 if (!scalar_check (time
, 0))
5447 if (!array_check (values
, 1))
5450 if (!rank_check (values
, 1, 1))
5453 if (!variable_check (values
, 1, false))
5456 if (!type_check (values
, 1, BT_INTEGER
))
5459 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
5467 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
5469 if (!scalar_check (unit
, 0))
5472 if (!type_check (unit
, 0, BT_INTEGER
))
5475 if (!type_check (name
, 1, BT_CHARACTER
))
5477 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
5485 gfc_check_isatty (gfc_expr
*unit
)
5490 if (!type_check (unit
, 0, BT_INTEGER
))
5493 if (!scalar_check (unit
, 0))
5501 gfc_check_isnan (gfc_expr
*x
)
5503 if (!type_check (x
, 0, BT_REAL
))
5511 gfc_check_perror (gfc_expr
*string
)
5513 if (!type_check (string
, 0, BT_CHARACTER
))
5515 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
5523 gfc_check_umask (gfc_expr
*mask
)
5525 if (!type_check (mask
, 0, BT_INTEGER
))
5528 if (!scalar_check (mask
, 0))
5536 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
5538 if (!type_check (mask
, 0, BT_INTEGER
))
5541 if (!scalar_check (mask
, 0))
5547 if (!scalar_check (old
, 1))
5550 if (!type_check (old
, 1, BT_INTEGER
))
5558 gfc_check_unlink (gfc_expr
*name
)
5560 if (!type_check (name
, 0, BT_CHARACTER
))
5562 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5570 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
5572 if (!type_check (name
, 0, BT_CHARACTER
))
5574 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5580 if (!scalar_check (status
, 1))
5583 if (!type_check (status
, 1, BT_INTEGER
))
5591 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
5593 if (!scalar_check (number
, 0))
5595 if (!type_check (number
, 0, BT_INTEGER
))
5598 if (!int_or_proc_check (handler
, 1))
5600 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5608 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
5610 if (!scalar_check (number
, 0))
5612 if (!type_check (number
, 0, BT_INTEGER
))
5615 if (!int_or_proc_check (handler
, 1))
5617 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5623 if (!type_check (status
, 2, BT_INTEGER
))
5625 if (!scalar_check (status
, 2))
5633 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
5635 if (!type_check (cmd
, 0, BT_CHARACTER
))
5637 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
5640 if (!scalar_check (status
, 1))
5643 if (!type_check (status
, 1, BT_INTEGER
))
5646 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
5653 /* This is used for the GNU intrinsics AND, OR and XOR. */
5655 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
5657 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
5659 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5660 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
5661 gfc_current_intrinsic
, &i
->where
);
5665 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
5667 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5668 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
5669 gfc_current_intrinsic
, &j
->where
);
5673 if (i
->ts
.type
!= j
->ts
.type
)
5675 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5676 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
5677 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5682 if (!scalar_check (i
, 0))
5685 if (!scalar_check (j
, 1))
5693 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
5695 if (a
->ts
.type
== BT_ASSUMED
)
5697 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
5698 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5703 if (a
->ts
.type
== BT_PROCEDURE
)
5705 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
5706 "procedure", gfc_current_intrinsic_arg
[0]->name
,
5707 gfc_current_intrinsic
, &a
->where
);
5714 if (!type_check (kind
, 1, BT_INTEGER
))
5717 if (!scalar_check (kind
, 1))
5720 if (kind
->expr_type
!= EXPR_CONSTANT
)
5722 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5723 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,