2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 if (gfc_numeric_ts (&e
->ts
))
78 /* If the expression has not got a type, check if its namespace can
79 offer a default type. */
80 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
81 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
82 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
83 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
85 e
->ts
= e
->symtree
->n
.sym
->ts
;
89 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
90 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
97 /* Check that an expression is integer or real. */
100 int_or_real_check (gfc_expr
*e
, int n
)
102 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
105 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
106 gfc_current_intrinsic
, &e
->where
);
114 /* Check that an expression is real or complex. */
117 real_or_complex_check (gfc_expr
*e
, int n
)
119 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
121 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
122 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
123 gfc_current_intrinsic
, &e
->where
);
131 /* Check that an expression is INTEGER or PROCEDURE. */
134 int_or_proc_check (gfc_expr
*e
, int n
)
136 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
138 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
139 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
140 gfc_current_intrinsic
, &e
->where
);
148 /* Check that the expression is an optional constant integer
149 and that it specifies a valid kind for that type. */
152 kind_check (gfc_expr
*k
, int n
, bt type
)
159 if (!type_check (k
, n
, BT_INTEGER
))
162 if (!scalar_check (k
, n
))
165 if (!gfc_check_init_expr (k
))
167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
168 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
173 if (gfc_extract_int (k
, &kind
) != NULL
174 || gfc_validate_kind (type
, kind
, true) < 0)
176 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
185 /* Make sure the expression is a double precision real. */
188 double_check (gfc_expr
*d
, int n
)
190 if (!type_check (d
, n
, BT_REAL
))
193 if (d
->ts
.kind
!= gfc_default_double_kind
)
195 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
196 "precision", gfc_current_intrinsic_arg
[n
]->name
,
197 gfc_current_intrinsic
, &d
->where
);
206 coarray_check (gfc_expr
*e
, int n
)
208 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
209 && CLASS_DATA (e
)->attr
.codimension
210 && CLASS_DATA (e
)->as
->corank
)
212 gfc_add_class_array_ref (e
);
216 if (!gfc_is_coarray (e
))
218 gfc_error ("Expected coarray variable as '%s' argument to the %s "
219 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
220 gfc_current_intrinsic
, &e
->where
);
228 /* Make sure the expression is a logical array. */
231 logical_array_check (gfc_expr
*array
, int n
)
233 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
235 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
236 "array", gfc_current_intrinsic_arg
[n
]->name
,
237 gfc_current_intrinsic
, &array
->where
);
245 /* Make sure an expression is an array. */
248 array_check (gfc_expr
*e
, int n
)
250 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
251 && CLASS_DATA (e
)->attr
.dimension
252 && CLASS_DATA (e
)->as
->rank
)
254 gfc_add_class_array_ref (e
);
258 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
261 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
262 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
269 /* If expr is a constant, then check to ensure that it is greater than
273 nonnegative_check (const char *arg
, gfc_expr
*expr
)
277 if (expr
->expr_type
== EXPR_CONSTANT
)
279 gfc_extract_int (expr
, &i
);
282 gfc_error ("'%s' at %L must be nonnegative", arg
, &expr
->where
);
291 /* If expr2 is constant, then check that the value is less than
292 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
295 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
296 gfc_expr
*expr2
, bool or_equal
)
300 if (expr2
->expr_type
== EXPR_CONSTANT
)
302 gfc_extract_int (expr2
, &i2
);
303 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
305 /* For ISHFT[C], check that |shift| <= bit_size(i). */
311 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
313 gfc_error ("The absolute value of SHIFT at %L must be less "
314 "than or equal to BIT_SIZE('%s')",
315 &expr2
->where
, arg1
);
322 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
324 gfc_error ("'%s' at %L must be less than "
325 "or equal to BIT_SIZE('%s')",
326 arg2
, &expr2
->where
, arg1
);
332 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
334 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
335 arg2
, &expr2
->where
, arg1
);
345 /* If expr is constant, then check that the value is less than or equal
346 to the bit_size of the kind k. */
349 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
353 if (expr
->expr_type
!= EXPR_CONSTANT
)
356 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
357 gfc_extract_int (expr
, &val
);
359 if (val
> gfc_integer_kinds
[i
].bit_size
)
361 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
362 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
370 /* If expr2 and expr3 are constants, then check that the value is less than
371 or equal to bit_size(expr1). */
374 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
375 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
379 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
381 gfc_extract_int (expr2
, &i2
);
382 gfc_extract_int (expr3
, &i3
);
384 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
385 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
387 gfc_error ("'%s + %s' at %L must be less than or equal "
389 arg2
, arg3
, &expr2
->where
, arg1
);
397 /* Make sure two expressions have the same type. */
400 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
402 if (gfc_compare_types (&e
->ts
, &f
->ts
))
405 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
406 "and kind as '%s'", gfc_current_intrinsic_arg
[m
]->name
,
407 gfc_current_intrinsic
, &f
->where
,
408 gfc_current_intrinsic_arg
[n
]->name
);
414 /* Make sure that an expression has a certain (nonzero) rank. */
417 rank_check (gfc_expr
*e
, int n
, int rank
)
422 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
423 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
430 /* Make sure a variable expression is not an optional dummy argument. */
433 nonoptional_check (gfc_expr
*e
, int n
)
435 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
437 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
438 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
442 /* TODO: Recursive check on nonoptional variables? */
448 /* Check for ALLOCATABLE attribute. */
451 allocatable_check (gfc_expr
*e
, int n
)
453 symbol_attribute attr
;
455 attr
= gfc_variable_attr (e
, NULL
);
456 if (!attr
.allocatable
|| attr
.associate_var
)
458 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
459 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
468 /* Check that an expression has a particular kind. */
471 kind_value_check (gfc_expr
*e
, int n
, int k
)
476 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
477 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
484 /* Make sure an expression is a variable. */
487 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
489 if (e
->expr_type
== EXPR_VARIABLE
490 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
491 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
492 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
495 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
496 && CLASS_DATA (e
->symtree
->n
.sym
)
497 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
498 : e
->symtree
->n
.sym
->attr
.pointer
;
500 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
502 if (pointer
&& ref
->type
== REF_COMPONENT
)
504 if (ref
->type
== REF_COMPONENT
505 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
506 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
507 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
508 && ref
->u
.c
.component
->attr
.pointer
)))
514 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
515 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
516 gfc_current_intrinsic
, &e
->where
);
521 if (e
->expr_type
== EXPR_VARIABLE
522 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
523 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
526 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
527 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
530 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
531 if (ns
->proc_name
== e
->symtree
->n
.sym
)
535 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
536 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
542 /* Check the common DIM parameter for correctness. */
545 dim_check (gfc_expr
*dim
, int n
, bool optional
)
550 if (!type_check (dim
, n
, BT_INTEGER
))
553 if (!scalar_check (dim
, n
))
556 if (!optional
&& !nonoptional_check (dim
, n
))
563 /* If a coarray DIM parameter is a constant, make sure that it is greater than
564 zero and less than or equal to the corank of the given array. */
567 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
571 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
573 if (dim
->expr_type
!= EXPR_CONSTANT
)
576 if (array
->ts
.type
== BT_CLASS
)
579 corank
= gfc_get_corank (array
);
581 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
582 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
584 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
585 "codimension index", gfc_current_intrinsic
, &dim
->where
);
594 /* If a DIM parameter is a constant, make sure that it is greater than
595 zero and less than or equal to the rank of the given array. If
596 allow_assumed is zero then dim must be less than the rank of the array
597 for assumed size arrays. */
600 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
608 if (dim
->expr_type
!= EXPR_CONSTANT
)
611 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
612 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
613 rank
= array
->rank
+ 1;
617 /* Assumed-rank array. */
619 rank
= GFC_MAX_DIMENSIONS
;
621 if (array
->expr_type
== EXPR_VARIABLE
)
623 ar
= gfc_find_array_ref (array
);
624 if (ar
->as
->type
== AS_ASSUMED_SIZE
626 && ar
->type
!= AR_ELEMENT
627 && ar
->type
!= AR_SECTION
)
631 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
632 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
634 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
635 "dimension index", gfc_current_intrinsic
, &dim
->where
);
644 /* Compare the size of a along dimension ai with the size of b along
645 dimension bi, returning 0 if they are known not to be identical,
646 and 1 if they are identical, or if this cannot be determined. */
649 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
651 mpz_t a_size
, b_size
;
654 gcc_assert (a
->rank
> ai
);
655 gcc_assert (b
->rank
> bi
);
659 if (gfc_array_dimen_size (a
, ai
, &a_size
))
661 if (gfc_array_dimen_size (b
, bi
, &b_size
))
663 if (mpz_cmp (a_size
, b_size
) != 0)
673 /* Calculate the length of a character variable, including substrings.
674 Strip away parentheses if necessary. Return -1 if no length could
678 gfc_var_strlen (const gfc_expr
*a
)
682 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
685 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
695 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
696 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
698 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
700 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
701 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
703 else if (ra
->u
.ss
.start
704 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
710 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
711 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
712 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
713 else if (a
->expr_type
== EXPR_CONSTANT
714 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
715 return a
->value
.character
.length
;
721 /* Check whether two character expressions have the same length;
722 returns true if they have or if the length cannot be determined,
723 otherwise return false and raise a gfc_error. */
726 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
730 len_a
= gfc_var_strlen(a
);
731 len_b
= gfc_var_strlen(b
);
733 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
737 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
738 len_a
, len_b
, name
, &a
->where
);
744 /***** Check functions *****/
746 /* Check subroutine suitable for intrinsics taking a real argument and
747 a kind argument for the result. */
750 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
752 if (!type_check (a
, 0, BT_REAL
))
754 if (!kind_check (kind
, 1, type
))
761 /* Check subroutine suitable for ceiling, floor and nint. */
764 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
766 return check_a_kind (a
, kind
, BT_INTEGER
);
770 /* Check subroutine suitable for aint, anint. */
773 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
775 return check_a_kind (a
, kind
, BT_REAL
);
780 gfc_check_abs (gfc_expr
*a
)
782 if (!numeric_check (a
, 0))
790 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
792 if (!type_check (a
, 0, BT_INTEGER
))
794 if (!kind_check (kind
, 1, BT_CHARACTER
))
802 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
804 if (!type_check (name
, 0, BT_CHARACTER
)
805 || !scalar_check (name
, 0))
807 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
810 if (!type_check (mode
, 1, BT_CHARACTER
)
811 || !scalar_check (mode
, 1))
813 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
821 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
823 if (!logical_array_check (mask
, 0))
826 if (!dim_check (dim
, 1, false))
829 if (!dim_rank_check (dim
, mask
, 0))
837 gfc_check_allocated (gfc_expr
*array
)
839 if (!variable_check (array
, 0, false))
841 if (!allocatable_check (array
, 0))
848 /* Common check function where the first argument must be real or
849 integer and the second argument must be the same as the first. */
852 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
854 if (!int_or_real_check (a
, 0))
857 if (a
->ts
.type
!= p
->ts
.type
)
859 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
860 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
861 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
866 if (a
->ts
.kind
!= p
->ts
.kind
)
868 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
878 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
880 if (!double_check (x
, 0) || !double_check (y
, 1))
888 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
890 symbol_attribute attr1
, attr2
;
895 where
= &pointer
->where
;
897 if (pointer
->expr_type
== EXPR_NULL
)
900 attr1
= gfc_expr_attr (pointer
);
902 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
904 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
905 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
911 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
913 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
914 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
915 gfc_current_intrinsic
, &pointer
->where
);
919 /* Target argument is optional. */
923 where
= &target
->where
;
924 if (target
->expr_type
== EXPR_NULL
)
927 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
928 attr2
= gfc_expr_attr (target
);
931 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
932 "or target VARIABLE or FUNCTION",
933 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
938 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
940 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
941 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
942 gfc_current_intrinsic
, &target
->where
);
947 if (attr1
.pointer
&& gfc_is_coindexed (target
))
949 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
950 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
951 gfc_current_intrinsic
, &target
->where
);
956 if (!same_type_check (pointer
, 0, target
, 1))
958 if (!rank_check (target
, 0, pointer
->rank
))
960 if (target
->rank
> 0)
962 for (i
= 0; i
< target
->rank
; i
++)
963 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
965 gfc_error ("Array section with a vector subscript at %L shall not "
966 "be the target of a pointer",
976 gfc_error ("NULL pointer at %L is not permitted as actual argument "
977 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
984 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
986 /* gfc_notify_std would be a waste of time as the return value
987 is seemingly used only for the generic resolution. The error
988 will be: Too many arguments. */
989 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
992 return gfc_check_atan2 (y
, x
);
997 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
999 if (!type_check (y
, 0, BT_REAL
))
1001 if (!same_type_check (y
, 0, x
, 1))
1009 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1010 gfc_expr
*stat
, int stat_no
)
1012 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1015 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1016 && !(atom
->ts
.type
== BT_LOGICAL
1017 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1019 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1020 "integer of ATOMIC_INT_KIND or a logical of "
1021 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1025 if (!gfc_expr_attr (atom
).codimension
)
1027 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1028 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1032 if (atom
->ts
.type
!= value
->ts
.type
)
1034 gfc_error ("'%s' argument of '%s' intrinsic at %L shall have the same "
1035 "type as '%s' at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1036 gfc_current_intrinsic
, &value
->where
,
1037 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1043 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1045 if (!scalar_check (stat
, stat_no
))
1047 if (!variable_check (stat
, stat_no
, false))
1049 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1052 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1053 gfc_current_intrinsic
, &stat
->where
))
1062 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1064 if (atom
->expr_type
== EXPR_FUNCTION
1065 && atom
->value
.function
.isym
1066 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1067 atom
= atom
->value
.function
.actual
->expr
;
1069 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1071 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1072 "definable", gfc_current_intrinsic
, &atom
->where
);
1076 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1081 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1083 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1085 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1086 "integer of ATOMIC_INT_KIND", &atom
->where
,
1087 gfc_current_intrinsic
);
1091 return gfc_check_atomic_def (atom
, value
, stat
);
1096 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1098 if (atom
->expr_type
== EXPR_FUNCTION
1099 && atom
->value
.function
.isym
1100 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1101 atom
= atom
->value
.function
.actual
->expr
;
1103 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1105 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1106 "definable", gfc_current_intrinsic
, &value
->where
);
1110 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1115 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1116 gfc_expr
*new_val
, gfc_expr
*stat
)
1118 if (atom
->expr_type
== EXPR_FUNCTION
1119 && atom
->value
.function
.isym
1120 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1121 atom
= atom
->value
.function
.actual
->expr
;
1123 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1126 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1129 if (!same_type_check (atom
, 0, old
, 1))
1132 if (!same_type_check (atom
, 0, compare
, 2))
1135 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1137 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1138 "definable", gfc_current_intrinsic
, &atom
->where
);
1142 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1144 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1145 "definable", gfc_current_intrinsic
, &old
->where
);
1154 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1157 if (atom
->expr_type
== EXPR_FUNCTION
1158 && atom
->value
.function
.isym
1159 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1160 atom
= atom
->value
.function
.actual
->expr
;
1162 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1164 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1165 "integer of ATOMIC_INT_KIND", &atom
->where
,
1166 gfc_current_intrinsic
);
1170 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1173 if (!scalar_check (old
, 2))
1176 if (!same_type_check (atom
, 0, old
, 2))
1179 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1181 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1182 "definable", gfc_current_intrinsic
, &atom
->where
);
1186 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1188 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1189 "definable", gfc_current_intrinsic
, &old
->where
);
1197 /* BESJN and BESYN functions. */
1200 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1202 if (!type_check (n
, 0, BT_INTEGER
))
1204 if (n
->expr_type
== EXPR_CONSTANT
)
1207 gfc_extract_int (n
, &i
);
1208 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1209 "N at %L", &n
->where
))
1213 if (!type_check (x
, 1, BT_REAL
))
1220 /* Transformational version of the Bessel JN and YN functions. */
1223 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1225 if (!type_check (n1
, 0, BT_INTEGER
))
1227 if (!scalar_check (n1
, 0))
1229 if (!nonnegative_check ("N1", n1
))
1232 if (!type_check (n2
, 1, BT_INTEGER
))
1234 if (!scalar_check (n2
, 1))
1236 if (!nonnegative_check ("N2", n2
))
1239 if (!type_check (x
, 2, BT_REAL
))
1241 if (!scalar_check (x
, 2))
1249 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1251 if (!type_check (i
, 0, BT_INTEGER
))
1254 if (!type_check (j
, 1, BT_INTEGER
))
1262 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1264 if (!type_check (i
, 0, BT_INTEGER
))
1267 if (!type_check (pos
, 1, BT_INTEGER
))
1270 if (!nonnegative_check ("pos", pos
))
1273 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1281 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1283 if (!type_check (i
, 0, BT_INTEGER
))
1285 if (!kind_check (kind
, 1, BT_CHARACTER
))
1293 gfc_check_chdir (gfc_expr
*dir
)
1295 if (!type_check (dir
, 0, BT_CHARACTER
))
1297 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1305 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1307 if (!type_check (dir
, 0, BT_CHARACTER
))
1309 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1315 if (!type_check (status
, 1, BT_INTEGER
))
1317 if (!scalar_check (status
, 1))
1325 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1327 if (!type_check (name
, 0, BT_CHARACTER
))
1329 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1332 if (!type_check (mode
, 1, BT_CHARACTER
))
1334 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1342 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1344 if (!type_check (name
, 0, BT_CHARACTER
))
1346 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1349 if (!type_check (mode
, 1, BT_CHARACTER
))
1351 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1357 if (!type_check (status
, 2, BT_INTEGER
))
1360 if (!scalar_check (status
, 2))
1368 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1370 if (!numeric_check (x
, 0))
1375 if (!numeric_check (y
, 1))
1378 if (x
->ts
.type
== BT_COMPLEX
)
1380 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1381 "present if 'x' is COMPLEX",
1382 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1387 if (y
->ts
.type
== BT_COMPLEX
)
1389 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1390 "of either REAL or INTEGER",
1391 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1398 if (!kind_check (kind
, 2, BT_COMPLEX
))
1401 if (!kind
&& warn_conversion
1402 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1403 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1404 "COMPLEX(%d) at %L might lose precision, consider using "
1405 "the KIND argument", gfc_typename (&x
->ts
),
1406 gfc_default_real_kind
, &x
->where
);
1407 else if (y
&& !kind
&& warn_conversion
1408 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1409 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1410 "COMPLEX(%d) at %L might lose precision, consider using "
1411 "the KIND argument", gfc_typename (&y
->ts
),
1412 gfc_default_real_kind
, &y
->where
);
1418 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1419 gfc_expr
*errmsg
, bool co_reduce
)
1421 if (!variable_check (a
, 0, false))
1424 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1428 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1429 if (gfc_has_vector_subscript (a
))
1431 gfc_error ("Argument 'A' with INTENT(INOUT) at %L of the intrinsic "
1432 "subroutine %s shall not have a vector subscript",
1433 &a
->where
, gfc_current_intrinsic
);
1437 if (gfc_is_coindexed (a
))
1439 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1440 "coindexed", &a
->where
, gfc_current_intrinsic
);
1444 if (image_idx
!= NULL
)
1446 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1448 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1454 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1456 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1458 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1460 if (stat
->ts
.kind
!= 4)
1462 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1463 "variable", &stat
->where
);
1470 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1472 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1474 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1476 if (errmsg
->ts
.kind
!= 1)
1478 gfc_error ("The errmsg= argument at %L must be a default-kind "
1479 "character variable", &errmsg
->where
);
1484 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
1486 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1496 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1499 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1501 gfc_error ("Support for the A argument at %L which is polymorphic A "
1502 "argument or has allocatable components is not yet "
1503 "implemented", &a
->where
);
1506 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1511 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1512 gfc_expr
*stat
, gfc_expr
*errmsg
)
1514 symbol_attribute attr
;
1515 gfc_formal_arglist
*formal
;
1518 if (a
->ts
.type
== BT_CLASS
)
1520 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1525 if (gfc_expr_attr (a
).alloc_comp
)
1527 gfc_error ("Support for the A argument at %L with allocatable components"
1528 " is not yet implemented", &a
->where
);
1532 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1535 if (!gfc_resolve_expr (op
))
1538 attr
= gfc_expr_attr (op
);
1539 if (!attr
.pure
|| !attr
.function
)
1541 gfc_error ("OPERATOR argument at %L must be a PURE function",
1548 /* None of the intrinsics fulfills the criteria of taking two arguments,
1549 returning the same type and kind as the arguments and being permitted
1550 as actual argument. */
1551 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1552 op
->symtree
->n
.sym
->name
, &op
->where
);
1556 if (gfc_is_proc_ptr_comp (op
))
1558 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1559 sym
= comp
->ts
.interface
;
1562 sym
= op
->symtree
->n
.sym
;
1564 formal
= sym
->formal
;
1566 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1568 gfc_error ("The function passed as OPERATOR at %L shall have two "
1569 "arguments", &op
->where
);
1573 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1574 gfc_set_default_type (sym
->result
, 0, NULL
);
1576 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1578 gfc_error ("A argument at %L has type %s but the function passed as "
1579 "OPERATOR at %L returns %s",
1580 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1581 gfc_typename (&sym
->result
->ts
));
1584 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1585 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1587 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1588 "%s and %s but shall have type %s", &op
->where
,
1589 gfc_typename (&formal
->sym
->ts
),
1590 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1593 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1594 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1595 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1596 || formal
->next
->sym
->attr
.pointer
)
1598 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1599 "nonallocatable nonpointer arguments and return a "
1600 "nonallocatable nonpointer scalar", &op
->where
);
1604 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1606 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1607 "attribute either for none or both arguments", &op
->where
);
1611 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1613 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1614 "attribute either for none or both arguments", &op
->where
);
1618 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1620 gfc_error ("The function passed as OPERATOR at %L shall have the "
1621 "ASYNCHRONOUS attribute either for none or both arguments",
1626 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1628 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1629 "OPTIONAL attribute for either of the arguments", &op
->where
);
1633 if (a
->ts
.type
== BT_CHARACTER
)
1636 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1639 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1640 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1642 cl
= formal
->sym
->ts
.u
.cl
;
1643 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1644 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1646 cl
= formal
->next
->sym
->ts
.u
.cl
;
1647 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1648 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1651 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1652 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1655 && ((formal_size1
&& actual_size
!= formal_size1
)
1656 || (formal_size2
&& actual_size
!= formal_size2
)))
1658 gfc_error ("The character length of the A argument at %L and of the "
1659 "arguments of the OPERATOR at %L shall be the same",
1660 &a
->where
, &op
->where
);
1663 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1665 gfc_error ("The character length of the A argument at %L and of the "
1666 "function result of the OPERATOR at %L shall be the same",
1667 &a
->where
, &op
->where
);
1677 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1680 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1681 && a
->ts
.type
!= BT_CHARACTER
)
1683 gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type "
1684 "integer, real or character",
1685 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1689 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1694 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1697 if (!numeric_check (a
, 0))
1699 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1704 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1706 if (!int_or_real_check (x
, 0))
1708 if (!scalar_check (x
, 0))
1711 if (!int_or_real_check (y
, 1))
1713 if (!scalar_check (y
, 1))
1721 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1723 if (!logical_array_check (mask
, 0))
1725 if (!dim_check (dim
, 1, false))
1727 if (!dim_rank_check (dim
, mask
, 0))
1729 if (!kind_check (kind
, 2, BT_INTEGER
))
1731 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1732 "with KIND argument at %L",
1733 gfc_current_intrinsic
, &kind
->where
))
1741 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1743 if (!array_check (array
, 0))
1746 if (!type_check (shift
, 1, BT_INTEGER
))
1749 if (!dim_check (dim
, 2, true))
1752 if (!dim_rank_check (dim
, array
, false))
1755 if (array
->rank
== 1 || shift
->rank
== 0)
1757 if (!scalar_check (shift
, 1))
1760 else if (shift
->rank
== array
->rank
- 1)
1765 else if (dim
->expr_type
== EXPR_CONSTANT
)
1766 gfc_extract_int (dim
, &d
);
1773 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1776 if (!identical_dimen_shape (array
, i
, shift
, j
))
1778 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1779 "invalid shape in dimension %d (%ld/%ld)",
1780 gfc_current_intrinsic_arg
[1]->name
,
1781 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1782 mpz_get_si (array
->shape
[i
]),
1783 mpz_get_si (shift
->shape
[j
]));
1793 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1794 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1795 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1804 gfc_check_ctime (gfc_expr
*time
)
1806 if (!scalar_check (time
, 0))
1809 if (!type_check (time
, 0, BT_INTEGER
))
1816 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1818 if (!double_check (y
, 0) || !double_check (x
, 1))
1825 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1827 if (!numeric_check (x
, 0))
1832 if (!numeric_check (y
, 1))
1835 if (x
->ts
.type
== BT_COMPLEX
)
1837 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1838 "present if 'x' is COMPLEX",
1839 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1844 if (y
->ts
.type
== BT_COMPLEX
)
1846 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1847 "of either REAL or INTEGER",
1848 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1859 gfc_check_dble (gfc_expr
*x
)
1861 if (!numeric_check (x
, 0))
1869 gfc_check_digits (gfc_expr
*x
)
1871 if (!int_or_real_check (x
, 0))
1879 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1881 switch (vector_a
->ts
.type
)
1884 if (!type_check (vector_b
, 1, BT_LOGICAL
))
1891 if (!numeric_check (vector_b
, 1))
1896 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1897 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1898 gfc_current_intrinsic
, &vector_a
->where
);
1902 if (!rank_check (vector_a
, 0, 1))
1905 if (!rank_check (vector_b
, 1, 1))
1908 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1910 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1911 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0]->name
,
1912 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1921 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1923 if (!type_check (x
, 0, BT_REAL
)
1924 || !type_check (y
, 1, BT_REAL
))
1927 if (x
->ts
.kind
!= gfc_default_real_kind
)
1929 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1930 "real", gfc_current_intrinsic_arg
[0]->name
,
1931 gfc_current_intrinsic
, &x
->where
);
1935 if (y
->ts
.kind
!= gfc_default_real_kind
)
1937 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1938 "real", gfc_current_intrinsic_arg
[1]->name
,
1939 gfc_current_intrinsic
, &y
->where
);
1948 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1950 if (!type_check (i
, 0, BT_INTEGER
))
1953 if (!type_check (j
, 1, BT_INTEGER
))
1956 if (i
->is_boz
&& j
->is_boz
)
1958 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1959 "constants", &i
->where
, &j
->where
);
1963 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
1966 if (!type_check (shift
, 2, BT_INTEGER
))
1969 if (!nonnegative_check ("SHIFT", shift
))
1974 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
1976 i
->ts
.kind
= j
->ts
.kind
;
1980 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
1982 j
->ts
.kind
= i
->ts
.kind
;
1990 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1993 if (!array_check (array
, 0))
1996 if (!type_check (shift
, 1, BT_INTEGER
))
1999 if (!dim_check (dim
, 3, true))
2002 if (!dim_rank_check (dim
, array
, false))
2005 if (array
->rank
== 1 || shift
->rank
== 0)
2007 if (!scalar_check (shift
, 1))
2010 else if (shift
->rank
== array
->rank
- 1)
2015 else if (dim
->expr_type
== EXPR_CONSTANT
)
2016 gfc_extract_int (dim
, &d
);
2023 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2026 if (!identical_dimen_shape (array
, i
, shift
, j
))
2028 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2029 "invalid shape in dimension %d (%ld/%ld)",
2030 gfc_current_intrinsic_arg
[1]->name
,
2031 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2032 mpz_get_si (array
->shape
[i
]),
2033 mpz_get_si (shift
->shape
[j
]));
2043 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
2044 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2045 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2049 if (boundary
!= NULL
)
2051 if (!same_type_check (array
, 0, boundary
, 2))
2054 if (array
->rank
== 1 || boundary
->rank
== 0)
2056 if (!scalar_check (boundary
, 2))
2059 else if (boundary
->rank
== array
->rank
- 1)
2061 if (!gfc_check_conformance (shift
, boundary
,
2062 "arguments '%s' and '%s' for "
2064 gfc_current_intrinsic_arg
[1]->name
,
2065 gfc_current_intrinsic_arg
[2]->name
,
2066 gfc_current_intrinsic
))
2071 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
2072 "rank %d or be a scalar",
2073 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2074 &shift
->where
, array
->rank
- 1);
2083 gfc_check_float (gfc_expr
*a
)
2085 if (!type_check (a
, 0, BT_INTEGER
))
2088 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2089 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2090 "kind argument to %s intrinsic at %L",
2091 gfc_current_intrinsic
, &a
->where
))
2097 /* A single complex argument. */
2100 gfc_check_fn_c (gfc_expr
*a
)
2102 if (!type_check (a
, 0, BT_COMPLEX
))
2108 /* A single real argument. */
2111 gfc_check_fn_r (gfc_expr
*a
)
2113 if (!type_check (a
, 0, BT_REAL
))
2119 /* A single double argument. */
2122 gfc_check_fn_d (gfc_expr
*a
)
2124 if (!double_check (a
, 0))
2130 /* A single real or complex argument. */
2133 gfc_check_fn_rc (gfc_expr
*a
)
2135 if (!real_or_complex_check (a
, 0))
2143 gfc_check_fn_rc2008 (gfc_expr
*a
)
2145 if (!real_or_complex_check (a
, 0))
2148 if (a
->ts
.type
== BT_COMPLEX
2149 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument '%s' "
2150 "of '%s' intrinsic at %L",
2151 gfc_current_intrinsic_arg
[0]->name
,
2152 gfc_current_intrinsic
, &a
->where
))
2160 gfc_check_fnum (gfc_expr
*unit
)
2162 if (!type_check (unit
, 0, BT_INTEGER
))
2165 if (!scalar_check (unit
, 0))
2173 gfc_check_huge (gfc_expr
*x
)
2175 if (!int_or_real_check (x
, 0))
2183 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2185 if (!type_check (x
, 0, BT_REAL
))
2187 if (!same_type_check (x
, 0, y
, 1))
2194 /* Check that the single argument is an integer. */
2197 gfc_check_i (gfc_expr
*i
)
2199 if (!type_check (i
, 0, BT_INTEGER
))
2207 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2209 if (!type_check (i
, 0, BT_INTEGER
))
2212 if (!type_check (j
, 1, BT_INTEGER
))
2215 if (i
->ts
.kind
!= j
->ts
.kind
)
2217 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2227 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2229 if (!type_check (i
, 0, BT_INTEGER
))
2232 if (!type_check (pos
, 1, BT_INTEGER
))
2235 if (!type_check (len
, 2, BT_INTEGER
))
2238 if (!nonnegative_check ("pos", pos
))
2241 if (!nonnegative_check ("len", len
))
2244 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2252 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2256 if (!type_check (c
, 0, BT_CHARACTER
))
2259 if (!kind_check (kind
, 1, BT_INTEGER
))
2262 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2263 "with KIND argument at %L",
2264 gfc_current_intrinsic
, &kind
->where
))
2267 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2273 /* Substring references don't have the charlength set. */
2275 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2278 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2282 /* Check that the argument is length one. Non-constant lengths
2283 can't be checked here, so assume they are ok. */
2284 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2286 /* If we already have a length for this expression then use it. */
2287 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2289 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2296 start
= ref
->u
.ss
.start
;
2297 end
= ref
->u
.ss
.end
;
2300 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2301 || start
->expr_type
!= EXPR_CONSTANT
)
2304 i
= mpz_get_si (end
->value
.integer
) + 1
2305 - mpz_get_si (start
->value
.integer
);
2313 gfc_error ("Argument of %s at %L must be of length one",
2314 gfc_current_intrinsic
, &c
->where
);
2323 gfc_check_idnint (gfc_expr
*a
)
2325 if (!double_check (a
, 0))
2333 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2335 if (!type_check (i
, 0, BT_INTEGER
))
2338 if (!type_check (j
, 1, BT_INTEGER
))
2341 if (i
->ts
.kind
!= j
->ts
.kind
)
2343 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2353 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2356 if (!type_check (string
, 0, BT_CHARACTER
)
2357 || !type_check (substring
, 1, BT_CHARACTER
))
2360 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2363 if (!kind_check (kind
, 3, BT_INTEGER
))
2365 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2366 "with KIND argument at %L",
2367 gfc_current_intrinsic
, &kind
->where
))
2370 if (string
->ts
.kind
!= substring
->ts
.kind
)
2372 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
2373 "kind as '%s'", gfc_current_intrinsic_arg
[1]->name
,
2374 gfc_current_intrinsic
, &substring
->where
,
2375 gfc_current_intrinsic_arg
[0]->name
);
2384 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2386 if (!numeric_check (x
, 0))
2389 if (!kind_check (kind
, 1, BT_INTEGER
))
2397 gfc_check_intconv (gfc_expr
*x
)
2399 if (!numeric_check (x
, 0))
2407 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2409 if (!type_check (i
, 0, BT_INTEGER
))
2412 if (!type_check (j
, 1, BT_INTEGER
))
2415 if (i
->ts
.kind
!= j
->ts
.kind
)
2417 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2427 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2429 if (!type_check (i
, 0, BT_INTEGER
)
2430 || !type_check (shift
, 1, BT_INTEGER
))
2433 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2441 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2443 if (!type_check (i
, 0, BT_INTEGER
)
2444 || !type_check (shift
, 1, BT_INTEGER
))
2451 if (!type_check (size
, 2, BT_INTEGER
))
2454 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2457 if (size
->expr_type
== EXPR_CONSTANT
)
2459 gfc_extract_int (size
, &i3
);
2462 gfc_error ("SIZE at %L must be positive", &size
->where
);
2466 if (shift
->expr_type
== EXPR_CONSTANT
)
2468 gfc_extract_int (shift
, &i2
);
2474 gfc_error ("The absolute value of SHIFT at %L must be less "
2475 "than or equal to SIZE at %L", &shift
->where
,
2482 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2490 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2492 if (!type_check (pid
, 0, BT_INTEGER
))
2495 if (!type_check (sig
, 1, BT_INTEGER
))
2503 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2505 if (!type_check (pid
, 0, BT_INTEGER
))
2508 if (!scalar_check (pid
, 0))
2511 if (!type_check (sig
, 1, BT_INTEGER
))
2514 if (!scalar_check (sig
, 1))
2520 if (!type_check (status
, 2, BT_INTEGER
))
2523 if (!scalar_check (status
, 2))
2531 gfc_check_kind (gfc_expr
*x
)
2533 if (x
->ts
.type
== BT_DERIVED
)
2535 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2536 "non-derived type", gfc_current_intrinsic_arg
[0]->name
,
2537 gfc_current_intrinsic
, &x
->where
);
2546 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2548 if (!array_check (array
, 0))
2551 if (!dim_check (dim
, 1, false))
2554 if (!dim_rank_check (dim
, array
, 1))
2557 if (!kind_check (kind
, 2, BT_INTEGER
))
2559 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2560 "with KIND argument at %L",
2561 gfc_current_intrinsic
, &kind
->where
))
2569 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2571 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2573 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2577 if (!coarray_check (coarray
, 0))
2582 if (!dim_check (dim
, 1, false))
2585 if (!dim_corank_check (dim
, coarray
))
2589 if (!kind_check (kind
, 2, BT_INTEGER
))
2597 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2599 if (!type_check (s
, 0, BT_CHARACTER
))
2602 if (!kind_check (kind
, 1, BT_INTEGER
))
2604 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2605 "with KIND argument at %L",
2606 gfc_current_intrinsic
, &kind
->where
))
2614 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2616 if (!type_check (a
, 0, BT_CHARACTER
))
2618 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2621 if (!type_check (b
, 1, BT_CHARACTER
))
2623 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2631 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2633 if (!type_check (path1
, 0, BT_CHARACTER
))
2635 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2638 if (!type_check (path2
, 1, BT_CHARACTER
))
2640 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2648 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2650 if (!type_check (path1
, 0, BT_CHARACTER
))
2652 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2655 if (!type_check (path2
, 1, BT_CHARACTER
))
2657 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2663 if (!type_check (status
, 2, BT_INTEGER
))
2666 if (!scalar_check (status
, 2))
2674 gfc_check_loc (gfc_expr
*expr
)
2676 return variable_check (expr
, 0, true);
2681 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2683 if (!type_check (path1
, 0, BT_CHARACTER
))
2685 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2688 if (!type_check (path2
, 1, BT_CHARACTER
))
2690 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2698 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2700 if (!type_check (path1
, 0, BT_CHARACTER
))
2702 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2705 if (!type_check (path2
, 1, BT_CHARACTER
))
2707 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2713 if (!type_check (status
, 2, BT_INTEGER
))
2716 if (!scalar_check (status
, 2))
2724 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2726 if (!type_check (a
, 0, BT_LOGICAL
))
2728 if (!kind_check (kind
, 1, BT_LOGICAL
))
2735 /* Min/max family. */
2738 min_max_args (gfc_actual_arglist
*args
)
2740 gfc_actual_arglist
*arg
;
2741 int i
, j
, nargs
, *nlabels
, nlabelless
;
2742 bool a1
= false, a2
= false;
2744 if (args
== NULL
|| args
->next
== NULL
)
2746 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2747 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2754 if (!args
->next
->name
)
2758 for (arg
= args
; arg
; arg
= arg
->next
)
2765 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2767 nlabels
= XALLOCAVEC (int, nargs
);
2768 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2774 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2776 n
= strtol (&arg
->name
[1], &endp
, 10);
2777 if (endp
[0] != '\0')
2781 if (n
<= nlabelless
)
2794 gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
2795 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2796 gfc_current_intrinsic_where
);
2800 /* Check for duplicates. */
2801 for (i
= 0; i
< nargs
; i
++)
2802 for (j
= i
+ 1; j
< nargs
; j
++)
2803 if (nlabels
[i
] == nlabels
[j
])
2809 gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg
->name
,
2810 &arg
->expr
->where
, gfc_current_intrinsic
);
2814 gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg
->name
,
2815 &arg
->expr
->where
, gfc_current_intrinsic
);
2821 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2823 gfc_actual_arglist
*arg
, *tmp
;
2827 if (!min_max_args (arglist
))
2830 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2833 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2835 if (x
->ts
.type
== type
)
2837 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
2838 "kinds at %L", &x
->where
))
2843 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2844 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2845 gfc_basic_typename (type
), kind
);
2850 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2851 if (!gfc_check_conformance (tmp
->expr
, x
,
2852 "arguments 'a%d' and 'a%d' for "
2853 "intrinsic '%s'", m
, n
,
2854 gfc_current_intrinsic
))
2863 gfc_check_min_max (gfc_actual_arglist
*arg
)
2867 if (!min_max_args (arg
))
2872 if (x
->ts
.type
== BT_CHARACTER
)
2874 if (!gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2875 "with CHARACTER argument at %L",
2876 gfc_current_intrinsic
, &x
->where
))
2879 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2881 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2882 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2886 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2891 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2893 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2898 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2900 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2905 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2907 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2911 /* End of min/max family. */
2914 gfc_check_malloc (gfc_expr
*size
)
2916 if (!type_check (size
, 0, BT_INTEGER
))
2919 if (!scalar_check (size
, 0))
2927 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2929 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2931 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2932 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2933 gfc_current_intrinsic
, &matrix_a
->where
);
2937 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2939 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2940 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2941 gfc_current_intrinsic
, &matrix_b
->where
);
2945 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2946 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2948 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2949 gfc_current_intrinsic
, &matrix_a
->where
,
2950 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2954 switch (matrix_a
->rank
)
2957 if (!rank_check (matrix_b
, 1, 2))
2959 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2960 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2962 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2963 "and '%s' at %L for intrinsic matmul",
2964 gfc_current_intrinsic_arg
[0]->name
,
2965 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2971 if (matrix_b
->rank
!= 2)
2973 if (!rank_check (matrix_b
, 1, 1))
2976 /* matrix_b has rank 1 or 2 here. Common check for the cases
2977 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2978 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2979 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2981 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2982 "dimension 1 for argument '%s' at %L for intrinsic "
2983 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2984 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2990 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2991 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
2992 gfc_current_intrinsic
, &matrix_a
->where
);
3000 /* Whoever came up with this interface was probably on something.
3001 The possibilities for the occupation of the second and third
3008 NULL MASK minloc(array, mask=m)
3011 I.e. in the case of minloc(array,mask), mask will be in the second
3012 position of the argument list and we'll have to fix that up. */
3015 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3017 gfc_expr
*a
, *m
, *d
;
3020 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
3024 m
= ap
->next
->next
->expr
;
3026 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3027 && ap
->next
->name
== NULL
)
3031 ap
->next
->expr
= NULL
;
3032 ap
->next
->next
->expr
= m
;
3035 if (!dim_check (d
, 1, false))
3038 if (!dim_rank_check (d
, a
, 0))
3041 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3045 && !gfc_check_conformance (a
, m
,
3046 "arguments '%s' and '%s' for intrinsic %s",
3047 gfc_current_intrinsic_arg
[0]->name
,
3048 gfc_current_intrinsic_arg
[2]->name
,
3049 gfc_current_intrinsic
))
3056 /* Similar to minloc/maxloc, the argument list might need to be
3057 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3058 difference is that MINLOC/MAXLOC take an additional KIND argument.
3059 The possibilities are:
3065 NULL MASK minval(array, mask=m)
3068 I.e. in the case of minval(array,mask), mask will be in the second
3069 position of the argument list and we'll have to fix that up. */
3072 check_reduction (gfc_actual_arglist
*ap
)
3074 gfc_expr
*a
, *m
, *d
;
3078 m
= ap
->next
->next
->expr
;
3080 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3081 && ap
->next
->name
== NULL
)
3085 ap
->next
->expr
= NULL
;
3086 ap
->next
->next
->expr
= m
;
3089 if (!dim_check (d
, 1, false))
3092 if (!dim_rank_check (d
, a
, 0))
3095 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3099 && !gfc_check_conformance (a
, m
,
3100 "arguments '%s' and '%s' for intrinsic %s",
3101 gfc_current_intrinsic_arg
[0]->name
,
3102 gfc_current_intrinsic_arg
[2]->name
,
3103 gfc_current_intrinsic
))
3111 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3113 if (!int_or_real_check (ap
->expr
, 0)
3114 || !array_check (ap
->expr
, 0))
3117 return check_reduction (ap
);
3122 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3124 if (!numeric_check (ap
->expr
, 0)
3125 || !array_check (ap
->expr
, 0))
3128 return check_reduction (ap
);
3132 /* For IANY, IALL and IPARITY. */
3135 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3139 if (!type_check (i
, 0, BT_INTEGER
))
3142 if (!nonnegative_check ("I", i
))
3145 if (!kind_check (kind
, 1, BT_INTEGER
))
3149 gfc_extract_int (kind
, &k
);
3151 k
= gfc_default_integer_kind
;
3153 if (!less_than_bitsizekind ("I", i
, k
))
3161 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3163 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3165 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
3166 gfc_current_intrinsic_arg
[0]->name
,
3167 gfc_current_intrinsic
, &ap
->expr
->where
);
3171 if (!array_check (ap
->expr
, 0))
3174 return check_reduction (ap
);
3179 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3181 if (!same_type_check (tsource
, 0, fsource
, 1))
3184 if (!type_check (mask
, 2, BT_LOGICAL
))
3187 if (tsource
->ts
.type
== BT_CHARACTER
)
3188 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3195 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3197 if (!type_check (i
, 0, BT_INTEGER
))
3200 if (!type_check (j
, 1, BT_INTEGER
))
3203 if (!type_check (mask
, 2, BT_INTEGER
))
3206 if (!same_type_check (i
, 0, j
, 1))
3209 if (!same_type_check (i
, 0, mask
, 2))
3217 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3219 if (!variable_check (from
, 0, false))
3221 if (!allocatable_check (from
, 0))
3223 if (gfc_is_coindexed (from
))
3225 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3226 "coindexed", &from
->where
);
3230 if (!variable_check (to
, 1, false))
3232 if (!allocatable_check (to
, 1))
3234 if (gfc_is_coindexed (to
))
3236 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3237 "coindexed", &to
->where
);
3241 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3243 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3244 "polymorphic if FROM is polymorphic",
3249 if (!same_type_check (to
, 1, from
, 0))
3252 if (to
->rank
!= from
->rank
)
3254 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3255 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3260 /* IR F08/0040; cf. 12-006A. */
3261 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3263 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3264 "must have the same corank %d/%d", &to
->where
,
3265 gfc_get_corank (from
), gfc_get_corank (to
));
3269 /* CLASS arguments: Make sure the vtab of from is present. */
3270 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3271 gfc_find_vtab (&from
->ts
);
3278 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3280 if (!type_check (x
, 0, BT_REAL
))
3283 if (!type_check (s
, 1, BT_REAL
))
3286 if (s
->expr_type
== EXPR_CONSTANT
)
3288 if (mpfr_sgn (s
->value
.real
) == 0)
3290 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
3301 gfc_check_new_line (gfc_expr
*a
)
3303 if (!type_check (a
, 0, BT_CHARACTER
))
3311 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3313 if (!type_check (array
, 0, BT_REAL
))
3316 if (!array_check (array
, 0))
3319 if (!dim_rank_check (dim
, array
, false))
3326 gfc_check_null (gfc_expr
*mold
)
3328 symbol_attribute attr
;
3333 if (!variable_check (mold
, 0, true))
3336 attr
= gfc_variable_attr (mold
, NULL
);
3338 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3340 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
3341 "ALLOCATABLE or procedure pointer",
3342 gfc_current_intrinsic_arg
[0]->name
,
3343 gfc_current_intrinsic
, &mold
->where
);
3347 if (attr
.allocatable
3348 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3349 "allocatable MOLD at %L", &mold
->where
))
3353 if (gfc_is_coindexed (mold
))
3355 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
3356 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3357 gfc_current_intrinsic
, &mold
->where
);
3366 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3368 if (!array_check (array
, 0))
3371 if (!type_check (mask
, 1, BT_LOGICAL
))
3374 if (!gfc_check_conformance (array
, mask
,
3375 "arguments '%s' and '%s' for intrinsic '%s'",
3376 gfc_current_intrinsic_arg
[0]->name
,
3377 gfc_current_intrinsic_arg
[1]->name
,
3378 gfc_current_intrinsic
))
3383 mpz_t array_size
, vector_size
;
3384 bool have_array_size
, have_vector_size
;
3386 if (!same_type_check (array
, 0, vector
, 2))
3389 if (!rank_check (vector
, 2, 1))
3392 /* VECTOR requires at least as many elements as MASK
3393 has .TRUE. values. */
3394 have_array_size
= gfc_array_size(array
, &array_size
);
3395 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3397 if (have_vector_size
3398 && (mask
->expr_type
== EXPR_ARRAY
3399 || (mask
->expr_type
== EXPR_CONSTANT
3400 && have_array_size
)))
3402 int mask_true_values
= 0;
3404 if (mask
->expr_type
== EXPR_ARRAY
)
3406 gfc_constructor
*mask_ctor
;
3407 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3410 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3412 mask_true_values
= 0;
3416 if (mask_ctor
->expr
->value
.logical
)
3419 mask_ctor
= gfc_constructor_next (mask_ctor
);
3422 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3423 mask_true_values
= mpz_get_si (array_size
);
3425 if (mpz_get_si (vector_size
) < mask_true_values
)
3427 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3428 "provide at least as many elements as there "
3429 "are .TRUE. values in '%s' (%ld/%d)",
3430 gfc_current_intrinsic_arg
[2]->name
,
3431 gfc_current_intrinsic
, &vector
->where
,
3432 gfc_current_intrinsic_arg
[1]->name
,
3433 mpz_get_si (vector_size
), mask_true_values
);
3438 if (have_array_size
)
3439 mpz_clear (array_size
);
3440 if (have_vector_size
)
3441 mpz_clear (vector_size
);
3449 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3451 if (!type_check (mask
, 0, BT_LOGICAL
))
3454 if (!array_check (mask
, 0))
3457 if (!dim_rank_check (dim
, mask
, false))
3465 gfc_check_precision (gfc_expr
*x
)
3467 if (!real_or_complex_check (x
, 0))
3475 gfc_check_present (gfc_expr
*a
)
3479 if (!variable_check (a
, 0, true))
3482 sym
= a
->symtree
->n
.sym
;
3483 if (!sym
->attr
.dummy
)
3485 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3486 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3487 gfc_current_intrinsic
, &a
->where
);
3491 if (!sym
->attr
.optional
)
3493 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3494 "an OPTIONAL dummy variable",
3495 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3500 /* 13.14.82 PRESENT(A)
3502 Argument. A shall be the name of an optional dummy argument that is
3503 accessible in the subprogram in which the PRESENT function reference
3507 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3508 && (a
->ref
->u
.ar
.type
== AR_FULL
3509 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3510 && a
->ref
->u
.ar
.as
->rank
== 0))))
3512 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3513 "subobject of '%s'", gfc_current_intrinsic_arg
[0]->name
,
3514 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3523 gfc_check_radix (gfc_expr
*x
)
3525 if (!int_or_real_check (x
, 0))
3533 gfc_check_range (gfc_expr
*x
)
3535 if (!numeric_check (x
, 0))
3543 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3545 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3546 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3548 bool is_variable
= true;
3550 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3551 if (a
->expr_type
== EXPR_FUNCTION
)
3552 is_variable
= a
->value
.function
.esym
3553 ? a
->value
.function
.esym
->result
->attr
.pointer
3554 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3556 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3557 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3560 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3561 "object", &a
->where
);
3569 /* real, float, sngl. */
3571 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3573 if (!numeric_check (a
, 0))
3576 if (!kind_check (kind
, 1, BT_REAL
))
3584 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3586 if (!type_check (path1
, 0, BT_CHARACTER
))
3588 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3591 if (!type_check (path2
, 1, BT_CHARACTER
))
3593 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3601 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3603 if (!type_check (path1
, 0, BT_CHARACTER
))
3605 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3608 if (!type_check (path2
, 1, BT_CHARACTER
))
3610 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3616 if (!type_check (status
, 2, BT_INTEGER
))
3619 if (!scalar_check (status
, 2))
3627 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3629 if (!type_check (x
, 0, BT_CHARACTER
))
3632 if (!scalar_check (x
, 0))
3635 if (!type_check (y
, 0, BT_INTEGER
))
3638 if (!scalar_check (y
, 1))
3646 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3647 gfc_expr
*pad
, gfc_expr
*order
)
3653 if (!array_check (source
, 0))
3656 if (!rank_check (shape
, 1, 1))
3659 if (!type_check (shape
, 1, BT_INTEGER
))
3662 if (!gfc_array_size (shape
, &size
))
3664 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3665 "array of constant size", &shape
->where
);
3669 shape_size
= mpz_get_ui (size
);
3672 if (shape_size
<= 0)
3674 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3675 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3679 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3681 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3682 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3685 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3689 for (i
= 0; i
< shape_size
; ++i
)
3691 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3692 if (e
->expr_type
!= EXPR_CONSTANT
)
3695 gfc_extract_int (e
, &extent
);
3698 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3699 "negative element (%d)",
3700 gfc_current_intrinsic_arg
[1]->name
,
3701 gfc_current_intrinsic
, &e
->where
, extent
);
3709 if (!same_type_check (source
, 0, pad
, 2))
3712 if (!array_check (pad
, 2))
3718 if (!array_check (order
, 3))
3721 if (!type_check (order
, 3, BT_INTEGER
))
3724 if (order
->expr_type
== EXPR_ARRAY
)
3726 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3729 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3732 gfc_array_size (order
, &size
);
3733 order_size
= mpz_get_ui (size
);
3736 if (order_size
!= shape_size
)
3738 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3739 "has wrong number of elements (%d/%d)",
3740 gfc_current_intrinsic_arg
[3]->name
,
3741 gfc_current_intrinsic
, &order
->where
,
3742 order_size
, shape_size
);
3746 for (i
= 1; i
<= order_size
; ++i
)
3748 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3749 if (e
->expr_type
!= EXPR_CONSTANT
)
3752 gfc_extract_int (e
, &dim
);
3754 if (dim
< 1 || dim
> order_size
)
3756 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3757 "has out-of-range dimension (%d)",
3758 gfc_current_intrinsic_arg
[3]->name
,
3759 gfc_current_intrinsic
, &e
->where
, dim
);
3763 if (perm
[dim
-1] != 0)
3765 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3766 "invalid permutation of dimensions (dimension "
3768 gfc_current_intrinsic_arg
[3]->name
,
3769 gfc_current_intrinsic
, &e
->where
, dim
);
3778 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3779 && gfc_is_constant_expr (shape
)
3780 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3781 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3783 /* Check the match in size between source and destination. */
3784 if (gfc_array_size (source
, &nelems
))
3790 mpz_init_set_ui (size
, 1);
3791 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3792 c
; c
= gfc_constructor_next (c
))
3793 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3795 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3801 gfc_error ("Without padding, there are not enough elements "
3802 "in the intrinsic RESHAPE source at %L to match "
3803 "the shape", &source
->where
);
3814 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3816 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3818 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3819 "cannot be of type %s",
3820 gfc_current_intrinsic_arg
[0]->name
,
3821 gfc_current_intrinsic
,
3822 &a
->where
, gfc_typename (&a
->ts
));
3826 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3828 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3829 "must be of an extensible type",
3830 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3835 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3837 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3838 "cannot be of type %s",
3839 gfc_current_intrinsic_arg
[0]->name
,
3840 gfc_current_intrinsic
,
3841 &b
->where
, gfc_typename (&b
->ts
));
3845 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3847 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3848 "must be of an extensible type",
3849 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3859 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3861 if (!type_check (x
, 0, BT_REAL
))
3864 if (!type_check (i
, 1, BT_INTEGER
))
3872 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3874 if (!type_check (x
, 0, BT_CHARACTER
))
3877 if (!type_check (y
, 1, BT_CHARACTER
))
3880 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
3883 if (!kind_check (kind
, 3, BT_INTEGER
))
3885 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3886 "with KIND argument at %L",
3887 gfc_current_intrinsic
, &kind
->where
))
3890 if (!same_type_check (x
, 0, y
, 1))
3898 gfc_check_secnds (gfc_expr
*r
)
3900 if (!type_check (r
, 0, BT_REAL
))
3903 if (!kind_value_check (r
, 0, 4))
3906 if (!scalar_check (r
, 0))
3914 gfc_check_selected_char_kind (gfc_expr
*name
)
3916 if (!type_check (name
, 0, BT_CHARACTER
))
3919 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
3922 if (!scalar_check (name
, 0))
3930 gfc_check_selected_int_kind (gfc_expr
*r
)
3932 if (!type_check (r
, 0, BT_INTEGER
))
3935 if (!scalar_check (r
, 0))
3943 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3945 if (p
== NULL
&& r
== NULL
3946 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
3947 " neither 'P' nor 'R' argument at %L",
3948 gfc_current_intrinsic_where
))
3953 if (!type_check (p
, 0, BT_INTEGER
))
3956 if (!scalar_check (p
, 0))
3962 if (!type_check (r
, 1, BT_INTEGER
))
3965 if (!scalar_check (r
, 1))
3971 if (!type_check (radix
, 1, BT_INTEGER
))
3974 if (!scalar_check (radix
, 1))
3977 if (!gfc_notify_std (GFC_STD_F2008
, "'%s' intrinsic with "
3978 "RADIX argument at %L", gfc_current_intrinsic
,
3988 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3990 if (!type_check (x
, 0, BT_REAL
))
3993 if (!type_check (i
, 1, BT_INTEGER
))
4001 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4005 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4008 ar
= gfc_find_array_ref (source
);
4010 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4012 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
4013 "an assumed size array", &source
->where
);
4017 if (!kind_check (kind
, 1, BT_INTEGER
))
4019 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4020 "with KIND argument at %L",
4021 gfc_current_intrinsic
, &kind
->where
))
4029 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4031 if (!type_check (i
, 0, BT_INTEGER
))
4034 if (!type_check (shift
, 0, BT_INTEGER
))
4037 if (!nonnegative_check ("SHIFT", shift
))
4040 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4048 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4050 if (!int_or_real_check (a
, 0))
4053 if (!same_type_check (a
, 0, b
, 1))
4061 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4063 if (!array_check (array
, 0))
4066 if (!dim_check (dim
, 1, true))
4069 if (!dim_rank_check (dim
, array
, 0))
4072 if (!kind_check (kind
, 2, BT_INTEGER
))
4074 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4075 "with KIND argument at %L",
4076 gfc_current_intrinsic
, &kind
->where
))
4085 gfc_check_sizeof (gfc_expr
*arg
)
4087 if (arg
->ts
.type
== BT_PROCEDURE
)
4089 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
4090 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4095 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4096 if (arg
->ts
.type
== BT_ASSUMED
4097 && (arg
->symtree
->n
.sym
->as
== NULL
4098 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4099 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4100 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4102 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
4103 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4108 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4109 && arg
->symtree
->n
.sym
->as
!= NULL
4110 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4111 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4113 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
4114 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4115 gfc_current_intrinsic
, &arg
->where
);
4123 /* Check whether an expression is interoperable. When returning false,
4124 msg is set to a string telling why the expression is not interoperable,
4125 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4126 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4127 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4128 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4132 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4136 if (expr
->ts
.type
== BT_CLASS
)
4138 *msg
= "Expression is polymorphic";
4142 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4143 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4145 *msg
= "Expression is a noninteroperable derived type";
4149 if (expr
->ts
.type
== BT_PROCEDURE
)
4151 *msg
= "Procedure unexpected as argument";
4155 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4158 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4159 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4161 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4165 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4166 && expr
->ts
.kind
!= 1)
4168 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4172 if (expr
->ts
.type
== BT_CHARACTER
) {
4173 if (expr
->ts
.deferred
)
4175 /* TS 29113 allows deferred-length strings as dummy arguments,
4176 but it is not an interoperable type. */
4177 *msg
= "Expression shall not be a deferred-length string";
4181 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4182 && !gfc_simplify_expr (expr
, 0))
4183 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4185 if (!c_loc
&& expr
->ts
.u
.cl
4186 && (!expr
->ts
.u
.cl
->length
4187 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4188 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4190 *msg
= "Type shall have a character length of 1";
4195 /* Note: The following checks are about interoperatable variables, Fortran
4196 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4197 is allowed, e.g. assumed-shape arrays with TS 29113. */
4199 if (gfc_is_coarray (expr
))
4201 *msg
= "Coarrays are not interoperable";
4205 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4207 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4208 if (ar
->type
!= AR_FULL
)
4210 *msg
= "Only whole-arrays are interoperable";
4213 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4214 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4216 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4226 gfc_check_c_sizeof (gfc_expr
*arg
)
4230 if (!is_c_interoperable (arg
, &msg
, false, false))
4232 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
4233 "interoperable data entity: %s",
4234 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4239 if (arg
->ts
.type
== BT_ASSUMED
)
4241 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
4243 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4248 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4249 && arg
->symtree
->n
.sym
->as
!= NULL
4250 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4251 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4253 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
4254 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4255 gfc_current_intrinsic
, &arg
->where
);
4264 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4266 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4267 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4268 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4269 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4271 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4272 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4276 if (!scalar_check (c_ptr_1
, 0))
4280 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4281 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4282 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4283 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4285 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4286 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4287 gfc_typename (&c_ptr_1
->ts
),
4288 gfc_typename (&c_ptr_2
->ts
));
4292 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4300 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4302 symbol_attribute attr
;
4305 if (cptr
->ts
.type
!= BT_DERIVED
4306 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4307 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4309 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4310 "type TYPE(C_PTR)", &cptr
->where
);
4314 if (!scalar_check (cptr
, 0))
4317 attr
= gfc_expr_attr (fptr
);
4321 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4326 if (fptr
->ts
.type
== BT_CLASS
)
4328 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4333 if (gfc_is_coindexed (fptr
))
4335 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4336 "coindexed", &fptr
->where
);
4340 if (fptr
->rank
== 0 && shape
)
4342 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4343 "FPTR", &fptr
->where
);
4346 else if (fptr
->rank
&& !shape
)
4348 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4349 "FPTR at %L", &fptr
->where
);
4353 if (shape
&& !rank_check (shape
, 2, 1))
4356 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4362 if (gfc_array_size (shape
, &size
))
4364 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4367 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4368 "size as the RANK of FPTR", &shape
->where
);
4375 if (fptr
->ts
.type
== BT_CLASS
)
4377 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4381 if (!is_c_interoperable (fptr
, &msg
, false, true))
4382 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4383 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4390 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4392 symbol_attribute attr
;
4394 if (cptr
->ts
.type
!= BT_DERIVED
4395 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4396 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4398 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4399 "type TYPE(C_FUNPTR)", &cptr
->where
);
4403 if (!scalar_check (cptr
, 0))
4406 attr
= gfc_expr_attr (fptr
);
4408 if (!attr
.proc_pointer
)
4410 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4411 "pointer", &fptr
->where
);
4415 if (gfc_is_coindexed (fptr
))
4417 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4418 "coindexed", &fptr
->where
);
4422 if (!attr
.is_bind_c
)
4423 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4424 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4431 gfc_check_c_funloc (gfc_expr
*x
)
4433 symbol_attribute attr
;
4435 if (gfc_is_coindexed (x
))
4437 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4438 "coindexed", &x
->where
);
4442 attr
= gfc_expr_attr (x
);
4444 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4445 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4447 gfc_namespace
*ns
= gfc_current_ns
;
4449 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4450 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4452 gfc_error ("Function result '%s' at %L is invalid as X argument "
4453 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4458 if (attr
.flavor
!= FL_PROCEDURE
)
4460 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4461 "or a procedure pointer", &x
->where
);
4465 if (!attr
.is_bind_c
)
4466 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4467 "at %L to C_FUNLOC", &x
->where
);
4473 gfc_check_c_loc (gfc_expr
*x
)
4475 symbol_attribute attr
;
4478 if (gfc_is_coindexed (x
))
4480 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4484 if (x
->ts
.type
== BT_CLASS
)
4486 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4491 attr
= gfc_expr_attr (x
);
4494 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4495 || attr
.flavor
== FL_PARAMETER
))
4497 gfc_error ("Argument X at %L to C_LOC shall have either "
4498 "the POINTER or the TARGET attribute", &x
->where
);
4502 if (x
->ts
.type
== BT_CHARACTER
4503 && gfc_var_strlen (x
) == 0)
4505 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4506 "string", &x
->where
);
4510 if (!is_c_interoperable (x
, &msg
, true, false))
4512 if (x
->ts
.type
== BT_CLASS
)
4514 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4520 && !gfc_notify_std (GFC_STD_F2008_TS
,
4521 "Noninteroperable array at %L as"
4522 " argument to C_LOC: %s", &x
->where
, msg
))
4525 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4527 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4529 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4530 && !attr
.allocatable
4531 && !gfc_notify_std (GFC_STD_F2008
,
4532 "Array of interoperable type at %L "
4533 "to C_LOC which is nonallocatable and neither "
4534 "assumed size nor explicit size", &x
->where
))
4536 else if (ar
->type
!= AR_FULL
4537 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4538 "to C_LOC", &x
->where
))
4547 gfc_check_sleep_sub (gfc_expr
*seconds
)
4549 if (!type_check (seconds
, 0, BT_INTEGER
))
4552 if (!scalar_check (seconds
, 0))
4559 gfc_check_sngl (gfc_expr
*a
)
4561 if (!type_check (a
, 0, BT_REAL
))
4564 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4565 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4566 "REAL argument to %s intrinsic at %L",
4567 gfc_current_intrinsic
, &a
->where
))
4574 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4576 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4578 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
4579 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4580 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4588 if (!dim_check (dim
, 1, false))
4591 /* dim_rank_check() does not apply here. */
4593 && dim
->expr_type
== EXPR_CONSTANT
4594 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4595 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4597 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
4598 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4599 gfc_current_intrinsic
, &dim
->where
);
4603 if (!type_check (ncopies
, 2, BT_INTEGER
))
4606 if (!scalar_check (ncopies
, 2))
4613 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4617 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4619 if (!type_check (unit
, 0, BT_INTEGER
))
4622 if (!scalar_check (unit
, 0))
4625 if (!type_check (c
, 1, BT_CHARACTER
))
4627 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4633 if (!type_check (status
, 2, BT_INTEGER
)
4634 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4635 || !scalar_check (status
, 2))
4643 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4645 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4650 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4652 if (!type_check (c
, 0, BT_CHARACTER
))
4654 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4660 if (!type_check (status
, 1, BT_INTEGER
)
4661 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4662 || !scalar_check (status
, 1))
4670 gfc_check_fgetput (gfc_expr
*c
)
4672 return gfc_check_fgetput_sub (c
, NULL
);
4677 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4679 if (!type_check (unit
, 0, BT_INTEGER
))
4682 if (!scalar_check (unit
, 0))
4685 if (!type_check (offset
, 1, BT_INTEGER
))
4688 if (!scalar_check (offset
, 1))
4691 if (!type_check (whence
, 2, BT_INTEGER
))
4694 if (!scalar_check (whence
, 2))
4700 if (!type_check (status
, 3, BT_INTEGER
))
4703 if (!kind_value_check (status
, 3, 4))
4706 if (!scalar_check (status
, 3))
4715 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4717 if (!type_check (unit
, 0, BT_INTEGER
))
4720 if (!scalar_check (unit
, 0))
4723 if (!type_check (array
, 1, BT_INTEGER
)
4724 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4727 if (!array_check (array
, 1))
4735 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4737 if (!type_check (unit
, 0, BT_INTEGER
))
4740 if (!scalar_check (unit
, 0))
4743 if (!type_check (array
, 1, BT_INTEGER
)
4744 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4747 if (!array_check (array
, 1))
4753 if (!type_check (status
, 2, BT_INTEGER
)
4754 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4757 if (!scalar_check (status
, 2))
4765 gfc_check_ftell (gfc_expr
*unit
)
4767 if (!type_check (unit
, 0, BT_INTEGER
))
4770 if (!scalar_check (unit
, 0))
4778 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4780 if (!type_check (unit
, 0, BT_INTEGER
))
4783 if (!scalar_check (unit
, 0))
4786 if (!type_check (offset
, 1, BT_INTEGER
))
4789 if (!scalar_check (offset
, 1))
4797 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4799 if (!type_check (name
, 0, BT_CHARACTER
))
4801 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4804 if (!type_check (array
, 1, BT_INTEGER
)
4805 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4808 if (!array_check (array
, 1))
4816 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4818 if (!type_check (name
, 0, BT_CHARACTER
))
4820 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4823 if (!type_check (array
, 1, BT_INTEGER
)
4824 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4827 if (!array_check (array
, 1))
4833 if (!type_check (status
, 2, BT_INTEGER
)
4834 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4837 if (!scalar_check (status
, 2))
4845 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4849 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4851 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4855 if (!coarray_check (coarray
, 0))
4860 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4861 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
4865 if (gfc_array_size (sub
, &nelems
))
4867 int corank
= gfc_get_corank (coarray
);
4869 if (mpz_cmp_ui (nelems
, corank
) != 0)
4871 gfc_error ("The number of array elements of the SUB argument to "
4872 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4873 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
4885 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
4887 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4889 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4895 if (!type_check (distance
, 0, BT_INTEGER
))
4898 if (!nonnegative_check ("DISTANCE", distance
))
4901 if (!scalar_check (distance
, 0))
4904 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
4905 "NUM_IMAGES at %L", &distance
->where
))
4911 if (!type_check (failed
, 1, BT_LOGICAL
))
4914 if (!scalar_check (failed
, 1))
4917 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
4918 "NUM_IMAGES at %L", &distance
->where
))
4927 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
4929 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4931 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4935 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
4938 if (dim
!= NULL
&& coarray
== NULL
)
4940 gfc_error ("DIM argument without COARRAY argument not allowed for "
4941 "THIS_IMAGE intrinsic at %L", &dim
->where
);
4945 if (distance
&& (coarray
|| dim
))
4947 gfc_error ("The DISTANCE argument may not be specified together with the "
4948 "COARRAY or DIM argument in intrinsic at %L",
4953 /* Assume that we have "this_image (distance)". */
4954 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
4958 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
4967 if (!type_check (distance
, 2, BT_INTEGER
))
4970 if (!nonnegative_check ("DISTANCE", distance
))
4973 if (!scalar_check (distance
, 2))
4976 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
4977 "THIS_IMAGE at %L", &distance
->where
))
4983 if (!coarray_check (coarray
, 0))
4988 if (!dim_check (dim
, 1, false))
4991 if (!dim_corank_check (dim
, coarray
))
4998 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4999 by gfc_simplify_transfer. Return false if we cannot do so. */
5002 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5003 size_t *source_size
, size_t *result_size
,
5004 size_t *result_length_p
)
5006 size_t result_elt_size
;
5008 if (source
->expr_type
== EXPR_FUNCTION
)
5011 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5014 /* Calculate the size of the source. */
5015 *source_size
= gfc_target_expr_size (source
);
5016 if (*source_size
== 0)
5019 /* Determine the size of the element. */
5020 result_elt_size
= gfc_element_size (mold
);
5021 if (result_elt_size
== 0)
5024 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5029 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5032 result_length
= *source_size
/ result_elt_size
;
5033 if (result_length
* result_elt_size
< *source_size
)
5037 *result_size
= result_length
* result_elt_size
;
5038 if (result_length_p
)
5039 *result_length_p
= result_length
;
5042 *result_size
= result_elt_size
;
5049 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5054 if (mold
->ts
.type
== BT_HOLLERITH
)
5056 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
5057 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5063 if (!type_check (size
, 2, BT_INTEGER
))
5066 if (!scalar_check (size
, 2))
5069 if (!nonoptional_check (size
, 2))
5073 if (!warn_surprising
)
5076 /* If we can't calculate the sizes, we cannot check any more.
5077 Return true for that case. */
5079 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5080 &result_size
, NULL
))
5083 if (source_size
< result_size
)
5084 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5085 "source size %ld < result size %ld", &source
->where
,
5086 (long) source_size
, (long) result_size
);
5093 gfc_check_transpose (gfc_expr
*matrix
)
5095 if (!rank_check (matrix
, 0, 2))
5103 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5105 if (!array_check (array
, 0))
5108 if (!dim_check (dim
, 1, false))
5111 if (!dim_rank_check (dim
, array
, 0))
5114 if (!kind_check (kind
, 2, BT_INTEGER
))
5116 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
5117 "with KIND argument at %L",
5118 gfc_current_intrinsic
, &kind
->where
))
5126 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5128 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
5130 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5134 if (!coarray_check (coarray
, 0))
5139 if (!dim_check (dim
, 1, false))
5142 if (!dim_corank_check (dim
, coarray
))
5146 if (!kind_check (kind
, 2, BT_INTEGER
))
5154 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5158 if (!rank_check (vector
, 0, 1))
5161 if (!array_check (mask
, 1))
5164 if (!type_check (mask
, 1, BT_LOGICAL
))
5167 if (!same_type_check (vector
, 0, field
, 2))
5170 if (mask
->expr_type
== EXPR_ARRAY
5171 && gfc_array_size (vector
, &vector_size
))
5173 int mask_true_count
= 0;
5174 gfc_constructor
*mask_ctor
;
5175 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5178 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5180 mask_true_count
= 0;
5184 if (mask_ctor
->expr
->value
.logical
)
5187 mask_ctor
= gfc_constructor_next (mask_ctor
);
5190 if (mpz_get_si (vector_size
) < mask_true_count
)
5192 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
5193 "provide at least as many elements as there "
5194 "are .TRUE. values in '%s' (%ld/%d)",
5195 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5196 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5197 mpz_get_si (vector_size
), mask_true_count
);
5201 mpz_clear (vector_size
);
5204 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5206 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
5207 "the same rank as '%s' or be a scalar",
5208 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5209 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5213 if (mask
->rank
== field
->rank
)
5216 for (i
= 0; i
< field
->rank
; i
++)
5217 if (! identical_dimen_shape (mask
, i
, field
, i
))
5219 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
5220 "must have identical shape.",
5221 gfc_current_intrinsic_arg
[2]->name
,
5222 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5232 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5234 if (!type_check (x
, 0, BT_CHARACTER
))
5237 if (!same_type_check (x
, 0, y
, 1))
5240 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5243 if (!kind_check (kind
, 3, BT_INTEGER
))
5245 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
5246 "with KIND argument at %L",
5247 gfc_current_intrinsic
, &kind
->where
))
5255 gfc_check_trim (gfc_expr
*x
)
5257 if (!type_check (x
, 0, BT_CHARACTER
))
5260 if (!scalar_check (x
, 0))
5268 gfc_check_ttynam (gfc_expr
*unit
)
5270 if (!scalar_check (unit
, 0))
5273 if (!type_check (unit
, 0, BT_INTEGER
))
5280 /* Common check function for the half a dozen intrinsics that have a
5281 single real argument. */
5284 gfc_check_x (gfc_expr
*x
)
5286 if (!type_check (x
, 0, BT_REAL
))
5293 /************* Check functions for intrinsic subroutines *************/
5296 gfc_check_cpu_time (gfc_expr
*time
)
5298 if (!scalar_check (time
, 0))
5301 if (!type_check (time
, 0, BT_REAL
))
5304 if (!variable_check (time
, 0, false))
5312 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5313 gfc_expr
*zone
, gfc_expr
*values
)
5317 if (!type_check (date
, 0, BT_CHARACTER
))
5319 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5321 if (!scalar_check (date
, 0))
5323 if (!variable_check (date
, 0, false))
5329 if (!type_check (time
, 1, BT_CHARACTER
))
5331 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5333 if (!scalar_check (time
, 1))
5335 if (!variable_check (time
, 1, false))
5341 if (!type_check (zone
, 2, BT_CHARACTER
))
5343 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5345 if (!scalar_check (zone
, 2))
5347 if (!variable_check (zone
, 2, false))
5353 if (!type_check (values
, 3, BT_INTEGER
))
5355 if (!array_check (values
, 3))
5357 if (!rank_check (values
, 3, 1))
5359 if (!variable_check (values
, 3, false))
5368 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5369 gfc_expr
*to
, gfc_expr
*topos
)
5371 if (!type_check (from
, 0, BT_INTEGER
))
5374 if (!type_check (frompos
, 1, BT_INTEGER
))
5377 if (!type_check (len
, 2, BT_INTEGER
))
5380 if (!same_type_check (from
, 0, to
, 3))
5383 if (!variable_check (to
, 3, false))
5386 if (!type_check (topos
, 4, BT_INTEGER
))
5389 if (!nonnegative_check ("frompos", frompos
))
5392 if (!nonnegative_check ("topos", topos
))
5395 if (!nonnegative_check ("len", len
))
5398 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5401 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5409 gfc_check_random_number (gfc_expr
*harvest
)
5411 if (!type_check (harvest
, 0, BT_REAL
))
5414 if (!variable_check (harvest
, 0, false))
5422 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5424 unsigned int nargs
= 0, kiss_size
;
5425 locus
*where
= NULL
;
5426 mpz_t put_size
, get_size
;
5427 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
5429 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
5431 /* Keep the number of bytes in sync with kiss_size in
5432 libgfortran/intrinsics/random.c. */
5433 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
5437 if (size
->expr_type
!= EXPR_VARIABLE
5438 || !size
->symtree
->n
.sym
->attr
.optional
)
5441 if (!scalar_check (size
, 0))
5444 if (!type_check (size
, 0, BT_INTEGER
))
5447 if (!variable_check (size
, 0, false))
5450 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5456 if (put
->expr_type
!= EXPR_VARIABLE
5457 || !put
->symtree
->n
.sym
->attr
.optional
)
5460 where
= &put
->where
;
5463 if (!array_check (put
, 1))
5466 if (!rank_check (put
, 1, 1))
5469 if (!type_check (put
, 1, BT_INTEGER
))
5472 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5475 if (gfc_array_size (put
, &put_size
)
5476 && mpz_get_ui (put_size
) < kiss_size
)
5477 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5478 "too small (%i/%i)",
5479 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5480 where
, (int) mpz_get_ui (put_size
), kiss_size
);
5485 if (get
->expr_type
!= EXPR_VARIABLE
5486 || !get
->symtree
->n
.sym
->attr
.optional
)
5489 where
= &get
->where
;
5492 if (!array_check (get
, 2))
5495 if (!rank_check (get
, 2, 1))
5498 if (!type_check (get
, 2, BT_INTEGER
))
5501 if (!variable_check (get
, 2, false))
5504 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5507 if (gfc_array_size (get
, &get_size
)
5508 && mpz_get_ui (get_size
) < kiss_size
)
5509 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5510 "too small (%i/%i)",
5511 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5512 where
, (int) mpz_get_ui (get_size
), kiss_size
);
5515 /* RANDOM_SEED may not have more than one non-optional argument. */
5517 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5524 gfc_check_second_sub (gfc_expr
*time
)
5526 if (!scalar_check (time
, 0))
5529 if (!type_check (time
, 0, BT_REAL
))
5532 if (!kind_value_check (time
, 0, 4))
5539 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5540 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5541 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5542 count_max are all optional arguments */
5545 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5546 gfc_expr
*count_max
)
5550 if (!scalar_check (count
, 0))
5553 if (!type_check (count
, 0, BT_INTEGER
))
5556 if (count
->ts
.kind
!= gfc_default_integer_kind
5557 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5558 "SYSTEM_CLOCK at %L has non-default kind",
5562 if (!variable_check (count
, 0, false))
5566 if (count_rate
!= NULL
)
5568 if (!scalar_check (count_rate
, 1))
5571 if (!variable_check (count_rate
, 1, false))
5574 if (count_rate
->ts
.type
== BT_REAL
)
5576 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5577 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5582 if (!type_check (count_rate
, 1, BT_INTEGER
))
5585 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5586 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5587 "SYSTEM_CLOCK at %L has non-default kind",
5588 &count_rate
->where
))
5594 if (count_max
!= NULL
)
5596 if (!scalar_check (count_max
, 2))
5599 if (!type_check (count_max
, 2, BT_INTEGER
))
5602 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5603 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5604 "SYSTEM_CLOCK at %L has non-default kind",
5608 if (!variable_check (count_max
, 2, false))
5617 gfc_check_irand (gfc_expr
*x
)
5622 if (!scalar_check (x
, 0))
5625 if (!type_check (x
, 0, BT_INTEGER
))
5628 if (!kind_value_check (x
, 0, 4))
5636 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5638 if (!scalar_check (seconds
, 0))
5640 if (!type_check (seconds
, 0, BT_INTEGER
))
5643 if (!int_or_proc_check (handler
, 1))
5645 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5651 if (!scalar_check (status
, 2))
5653 if (!type_check (status
, 2, BT_INTEGER
))
5655 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5663 gfc_check_rand (gfc_expr
*x
)
5668 if (!scalar_check (x
, 0))
5671 if (!type_check (x
, 0, BT_INTEGER
))
5674 if (!kind_value_check (x
, 0, 4))
5682 gfc_check_srand (gfc_expr
*x
)
5684 if (!scalar_check (x
, 0))
5687 if (!type_check (x
, 0, BT_INTEGER
))
5690 if (!kind_value_check (x
, 0, 4))
5698 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5700 if (!scalar_check (time
, 0))
5702 if (!type_check (time
, 0, BT_INTEGER
))
5705 if (!type_check (result
, 1, BT_CHARACTER
))
5707 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5715 gfc_check_dtime_etime (gfc_expr
*x
)
5717 if (!array_check (x
, 0))
5720 if (!rank_check (x
, 0, 1))
5723 if (!variable_check (x
, 0, false))
5726 if (!type_check (x
, 0, BT_REAL
))
5729 if (!kind_value_check (x
, 0, 4))
5737 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5739 if (!array_check (values
, 0))
5742 if (!rank_check (values
, 0, 1))
5745 if (!variable_check (values
, 0, false))
5748 if (!type_check (values
, 0, BT_REAL
))
5751 if (!kind_value_check (values
, 0, 4))
5754 if (!scalar_check (time
, 1))
5757 if (!type_check (time
, 1, BT_REAL
))
5760 if (!kind_value_check (time
, 1, 4))
5768 gfc_check_fdate_sub (gfc_expr
*date
)
5770 if (!type_check (date
, 0, BT_CHARACTER
))
5772 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5780 gfc_check_gerror (gfc_expr
*msg
)
5782 if (!type_check (msg
, 0, BT_CHARACTER
))
5784 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5792 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5794 if (!type_check (cwd
, 0, BT_CHARACTER
))
5796 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5802 if (!scalar_check (status
, 1))
5805 if (!type_check (status
, 1, BT_INTEGER
))
5813 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5815 if (!type_check (pos
, 0, BT_INTEGER
))
5818 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5820 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
5821 "not wider than the default kind (%d)",
5822 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5823 &pos
->where
, gfc_default_integer_kind
);
5827 if (!type_check (value
, 1, BT_CHARACTER
))
5829 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
5837 gfc_check_getlog (gfc_expr
*msg
)
5839 if (!type_check (msg
, 0, BT_CHARACTER
))
5841 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5849 gfc_check_exit (gfc_expr
*status
)
5854 if (!type_check (status
, 0, BT_INTEGER
))
5857 if (!scalar_check (status
, 0))
5865 gfc_check_flush (gfc_expr
*unit
)
5870 if (!type_check (unit
, 0, BT_INTEGER
))
5873 if (!scalar_check (unit
, 0))
5881 gfc_check_free (gfc_expr
*i
)
5883 if (!type_check (i
, 0, BT_INTEGER
))
5886 if (!scalar_check (i
, 0))
5894 gfc_check_hostnm (gfc_expr
*name
)
5896 if (!type_check (name
, 0, BT_CHARACTER
))
5898 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5906 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
5908 if (!type_check (name
, 0, BT_CHARACTER
))
5910 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5916 if (!scalar_check (status
, 1))
5919 if (!type_check (status
, 1, BT_INTEGER
))
5927 gfc_check_itime_idate (gfc_expr
*values
)
5929 if (!array_check (values
, 0))
5932 if (!rank_check (values
, 0, 1))
5935 if (!variable_check (values
, 0, false))
5938 if (!type_check (values
, 0, BT_INTEGER
))
5941 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
5949 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
5951 if (!type_check (time
, 0, BT_INTEGER
))
5954 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
5957 if (!scalar_check (time
, 0))
5960 if (!array_check (values
, 1))
5963 if (!rank_check (values
, 1, 1))
5966 if (!variable_check (values
, 1, false))
5969 if (!type_check (values
, 1, BT_INTEGER
))
5972 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
5980 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
5982 if (!scalar_check (unit
, 0))
5985 if (!type_check (unit
, 0, BT_INTEGER
))
5988 if (!type_check (name
, 1, BT_CHARACTER
))
5990 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
5998 gfc_check_isatty (gfc_expr
*unit
)
6003 if (!type_check (unit
, 0, BT_INTEGER
))
6006 if (!scalar_check (unit
, 0))
6014 gfc_check_isnan (gfc_expr
*x
)
6016 if (!type_check (x
, 0, BT_REAL
))
6024 gfc_check_perror (gfc_expr
*string
)
6026 if (!type_check (string
, 0, BT_CHARACTER
))
6028 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6036 gfc_check_umask (gfc_expr
*mask
)
6038 if (!type_check (mask
, 0, BT_INTEGER
))
6041 if (!scalar_check (mask
, 0))
6049 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6051 if (!type_check (mask
, 0, BT_INTEGER
))
6054 if (!scalar_check (mask
, 0))
6060 if (!scalar_check (old
, 1))
6063 if (!type_check (old
, 1, BT_INTEGER
))
6071 gfc_check_unlink (gfc_expr
*name
)
6073 if (!type_check (name
, 0, BT_CHARACTER
))
6075 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6083 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6085 if (!type_check (name
, 0, BT_CHARACTER
))
6087 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6093 if (!scalar_check (status
, 1))
6096 if (!type_check (status
, 1, BT_INTEGER
))
6104 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6106 if (!scalar_check (number
, 0))
6108 if (!type_check (number
, 0, BT_INTEGER
))
6111 if (!int_or_proc_check (handler
, 1))
6113 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6121 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6123 if (!scalar_check (number
, 0))
6125 if (!type_check (number
, 0, BT_INTEGER
))
6128 if (!int_or_proc_check (handler
, 1))
6130 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6136 if (!type_check (status
, 2, BT_INTEGER
))
6138 if (!scalar_check (status
, 2))
6146 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6148 if (!type_check (cmd
, 0, BT_CHARACTER
))
6150 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6153 if (!scalar_check (status
, 1))
6156 if (!type_check (status
, 1, BT_INTEGER
))
6159 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6166 /* This is used for the GNU intrinsics AND, OR and XOR. */
6168 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6170 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6172 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
6173 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6174 gfc_current_intrinsic
, &i
->where
);
6178 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6180 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
6181 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6182 gfc_current_intrinsic
, &j
->where
);
6186 if (i
->ts
.type
!= j
->ts
.type
)
6188 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
6189 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6190 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6195 if (!scalar_check (i
, 0))
6198 if (!scalar_check (j
, 1))
6206 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6208 if (a
->ts
.type
== BT_ASSUMED
)
6210 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
6211 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6216 if (a
->ts
.type
== BT_PROCEDURE
)
6218 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
6219 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6220 gfc_current_intrinsic
, &a
->where
);
6227 if (!type_check (kind
, 1, BT_INTEGER
))
6230 if (!scalar_check (kind
, 1))
6233 if (kind
->expr_type
!= EXPR_CONSTANT
)
6235 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
6236 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,