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
&& gfc_option
.gfc_warn_conversion
1402 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1403 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1404 "might lose precision, consider using the KIND argument",
1405 gfc_typename (&x
->ts
), gfc_default_real_kind
, &x
->where
);
1406 else if (y
&& !kind
&& gfc_option
.gfc_warn_conversion
1407 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1408 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1409 "might lose precision, consider using the KIND argument",
1410 gfc_typename (&y
->ts
), gfc_default_real_kind
, &y
->where
);
1417 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1418 gfc_expr
*errmsg
, bool co_reduce
)
1420 if (!variable_check (a
, 0, false))
1423 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1427 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1428 if (gfc_has_vector_subscript (a
))
1430 gfc_error ("Argument 'A' with INTENT(INOUT) at %L of the intrinsic "
1431 "subroutine %s shall not have a vector subscript",
1432 &a
->where
, gfc_current_intrinsic
);
1436 if (gfc_is_coindexed (a
))
1438 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1439 "coindexed", &a
->where
, gfc_current_intrinsic
);
1443 if (image_idx
!= NULL
)
1445 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1447 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1453 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1455 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1457 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1459 if (stat
->ts
.kind
!= 4)
1461 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1462 "variable", &stat
->where
);
1469 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1471 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1473 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1475 if (errmsg
->ts
.kind
!= 1)
1477 gfc_error ("The errmsg= argument at %L must be a default-kind "
1478 "character variable", &errmsg
->where
);
1483 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
1485 gfc_fatal_error ("Coarrays disabled at %L, use -fcoarray= to enable",
1495 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1498 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1500 gfc_error ("Support for the A argument at %L which is polymorphic A "
1501 "argument or has allocatable components is not yet "
1502 "implemented", &a
->where
);
1505 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1510 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1511 gfc_expr
*stat
, gfc_expr
*errmsg
)
1513 symbol_attribute attr
;
1514 gfc_formal_arglist
*formal
;
1517 if (a
->ts
.type
== BT_CLASS
)
1519 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1524 if (gfc_expr_attr (a
).alloc_comp
)
1526 gfc_error ("Support for the A argument at %L with allocatable components"
1527 " is not yet implemented", &a
->where
);
1531 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1534 if (!gfc_resolve_expr (op
))
1537 attr
= gfc_expr_attr (op
);
1538 if (!attr
.pure
|| !attr
.function
)
1540 gfc_error ("OPERATOR argument at %L must be a PURE function",
1547 /* None of the intrinsics fulfills the criteria of taking two arguments,
1548 returning the same type and kind as the arguments and being permitted
1549 as actual argument. */
1550 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1551 op
->symtree
->n
.sym
->name
, &op
->where
);
1555 if (gfc_is_proc_ptr_comp (op
))
1557 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1558 sym
= comp
->ts
.interface
;
1561 sym
= op
->symtree
->n
.sym
;
1563 formal
= sym
->formal
;
1565 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1567 gfc_error ("The function passed as OPERATOR at %L shall have two "
1568 "arguments", &op
->where
);
1572 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1573 gfc_set_default_type (sym
->result
, 0, NULL
);
1575 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1577 gfc_error ("A argument at %L has type %s but the function passed as "
1578 "OPERATOR at %L returns %s",
1579 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1580 gfc_typename (&sym
->result
->ts
));
1583 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1584 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1586 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1587 "%s and %s but shall have type %s", &op
->where
,
1588 gfc_typename (&formal
->sym
->ts
),
1589 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1592 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1593 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1594 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1595 || formal
->next
->sym
->attr
.pointer
)
1597 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1598 "nonallocatable nonpointer arguments and return a "
1599 "nonallocatable nonpointer scalar", &op
->where
);
1603 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1605 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1606 "attribute either for none or both arguments", &op
->where
);
1610 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1612 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1613 "attribute either for none or both arguments", &op
->where
);
1617 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1619 gfc_error ("The function passed as OPERATOR at %L shall have the "
1620 "ASYNCHRONOUS attribute either for none or both arguments",
1625 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1627 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1628 "OPTIONAL attribute for either of the arguments", &op
->where
);
1632 if (a
->ts
.type
== BT_CHARACTER
)
1635 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1638 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1639 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1641 cl
= formal
->sym
->ts
.u
.cl
;
1642 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1643 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1645 cl
= formal
->next
->sym
->ts
.u
.cl
;
1646 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1647 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1650 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1651 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1654 && ((formal_size1
&& actual_size
!= formal_size1
)
1655 || (formal_size2
&& actual_size
!= formal_size2
)))
1657 gfc_error ("The character length of the A argument at %L and of the "
1658 "arguments of the OPERATOR at %L shall be the same",
1659 &a
->where
, &op
->where
);
1662 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1664 gfc_error ("The character length of the A argument at %L and of the "
1665 "function result of the OPERATOR at %L shall be the same",
1666 &a
->where
, &op
->where
);
1676 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1679 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1680 && a
->ts
.type
!= BT_CHARACTER
)
1682 gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type "
1683 "integer, real or character",
1684 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1688 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1693 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1696 if (!numeric_check (a
, 0))
1698 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1703 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1705 if (!int_or_real_check (x
, 0))
1707 if (!scalar_check (x
, 0))
1710 if (!int_or_real_check (y
, 1))
1712 if (!scalar_check (y
, 1))
1720 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1722 if (!logical_array_check (mask
, 0))
1724 if (!dim_check (dim
, 1, false))
1726 if (!dim_rank_check (dim
, mask
, 0))
1728 if (!kind_check (kind
, 2, BT_INTEGER
))
1730 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1731 "with KIND argument at %L",
1732 gfc_current_intrinsic
, &kind
->where
))
1740 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1742 if (!array_check (array
, 0))
1745 if (!type_check (shift
, 1, BT_INTEGER
))
1748 if (!dim_check (dim
, 2, true))
1751 if (!dim_rank_check (dim
, array
, false))
1754 if (array
->rank
== 1 || shift
->rank
== 0)
1756 if (!scalar_check (shift
, 1))
1759 else if (shift
->rank
== array
->rank
- 1)
1764 else if (dim
->expr_type
== EXPR_CONSTANT
)
1765 gfc_extract_int (dim
, &d
);
1772 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1775 if (!identical_dimen_shape (array
, i
, shift
, j
))
1777 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1778 "invalid shape in dimension %d (%ld/%ld)",
1779 gfc_current_intrinsic_arg
[1]->name
,
1780 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1781 mpz_get_si (array
->shape
[i
]),
1782 mpz_get_si (shift
->shape
[j
]));
1792 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1793 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1794 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1803 gfc_check_ctime (gfc_expr
*time
)
1805 if (!scalar_check (time
, 0))
1808 if (!type_check (time
, 0, BT_INTEGER
))
1815 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1817 if (!double_check (y
, 0) || !double_check (x
, 1))
1824 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1826 if (!numeric_check (x
, 0))
1831 if (!numeric_check (y
, 1))
1834 if (x
->ts
.type
== BT_COMPLEX
)
1836 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1837 "present if 'x' is COMPLEX",
1838 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1843 if (y
->ts
.type
== BT_COMPLEX
)
1845 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1846 "of either REAL or INTEGER",
1847 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1858 gfc_check_dble (gfc_expr
*x
)
1860 if (!numeric_check (x
, 0))
1868 gfc_check_digits (gfc_expr
*x
)
1870 if (!int_or_real_check (x
, 0))
1878 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1880 switch (vector_a
->ts
.type
)
1883 if (!type_check (vector_b
, 1, BT_LOGICAL
))
1890 if (!numeric_check (vector_b
, 1))
1895 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1896 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1897 gfc_current_intrinsic
, &vector_a
->where
);
1901 if (!rank_check (vector_a
, 0, 1))
1904 if (!rank_check (vector_b
, 1, 1))
1907 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1909 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1910 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0]->name
,
1911 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1920 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1922 if (!type_check (x
, 0, BT_REAL
)
1923 || !type_check (y
, 1, BT_REAL
))
1926 if (x
->ts
.kind
!= gfc_default_real_kind
)
1928 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1929 "real", gfc_current_intrinsic_arg
[0]->name
,
1930 gfc_current_intrinsic
, &x
->where
);
1934 if (y
->ts
.kind
!= gfc_default_real_kind
)
1936 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1937 "real", gfc_current_intrinsic_arg
[1]->name
,
1938 gfc_current_intrinsic
, &y
->where
);
1947 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1949 if (!type_check (i
, 0, BT_INTEGER
))
1952 if (!type_check (j
, 1, BT_INTEGER
))
1955 if (i
->is_boz
&& j
->is_boz
)
1957 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1958 "constants", &i
->where
, &j
->where
);
1962 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
1965 if (!type_check (shift
, 2, BT_INTEGER
))
1968 if (!nonnegative_check ("SHIFT", shift
))
1973 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
1975 i
->ts
.kind
= j
->ts
.kind
;
1979 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
1981 j
->ts
.kind
= i
->ts
.kind
;
1989 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1992 if (!array_check (array
, 0))
1995 if (!type_check (shift
, 1, BT_INTEGER
))
1998 if (!dim_check (dim
, 3, true))
2001 if (!dim_rank_check (dim
, array
, false))
2004 if (array
->rank
== 1 || shift
->rank
== 0)
2006 if (!scalar_check (shift
, 1))
2009 else if (shift
->rank
== array
->rank
- 1)
2014 else if (dim
->expr_type
== EXPR_CONSTANT
)
2015 gfc_extract_int (dim
, &d
);
2022 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2025 if (!identical_dimen_shape (array
, i
, shift
, j
))
2027 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2028 "invalid shape in dimension %d (%ld/%ld)",
2029 gfc_current_intrinsic_arg
[1]->name
,
2030 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2031 mpz_get_si (array
->shape
[i
]),
2032 mpz_get_si (shift
->shape
[j
]));
2042 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
2043 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2044 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2048 if (boundary
!= NULL
)
2050 if (!same_type_check (array
, 0, boundary
, 2))
2053 if (array
->rank
== 1 || boundary
->rank
== 0)
2055 if (!scalar_check (boundary
, 2))
2058 else if (boundary
->rank
== array
->rank
- 1)
2060 if (!gfc_check_conformance (shift
, boundary
,
2061 "arguments '%s' and '%s' for "
2063 gfc_current_intrinsic_arg
[1]->name
,
2064 gfc_current_intrinsic_arg
[2]->name
,
2065 gfc_current_intrinsic
))
2070 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
2071 "rank %d or be a scalar",
2072 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2073 &shift
->where
, array
->rank
- 1);
2082 gfc_check_float (gfc_expr
*a
)
2084 if (!type_check (a
, 0, BT_INTEGER
))
2087 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2088 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2089 "kind argument to %s intrinsic at %L",
2090 gfc_current_intrinsic
, &a
->where
))
2096 /* A single complex argument. */
2099 gfc_check_fn_c (gfc_expr
*a
)
2101 if (!type_check (a
, 0, BT_COMPLEX
))
2107 /* A single real argument. */
2110 gfc_check_fn_r (gfc_expr
*a
)
2112 if (!type_check (a
, 0, BT_REAL
))
2118 /* A single double argument. */
2121 gfc_check_fn_d (gfc_expr
*a
)
2123 if (!double_check (a
, 0))
2129 /* A single real or complex argument. */
2132 gfc_check_fn_rc (gfc_expr
*a
)
2134 if (!real_or_complex_check (a
, 0))
2142 gfc_check_fn_rc2008 (gfc_expr
*a
)
2144 if (!real_or_complex_check (a
, 0))
2147 if (a
->ts
.type
== BT_COMPLEX
2148 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument '%s' "
2149 "of '%s' intrinsic at %L",
2150 gfc_current_intrinsic_arg
[0]->name
,
2151 gfc_current_intrinsic
, &a
->where
))
2159 gfc_check_fnum (gfc_expr
*unit
)
2161 if (!type_check (unit
, 0, BT_INTEGER
))
2164 if (!scalar_check (unit
, 0))
2172 gfc_check_huge (gfc_expr
*x
)
2174 if (!int_or_real_check (x
, 0))
2182 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2184 if (!type_check (x
, 0, BT_REAL
))
2186 if (!same_type_check (x
, 0, y
, 1))
2193 /* Check that the single argument is an integer. */
2196 gfc_check_i (gfc_expr
*i
)
2198 if (!type_check (i
, 0, BT_INTEGER
))
2206 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2208 if (!type_check (i
, 0, BT_INTEGER
))
2211 if (!type_check (j
, 1, BT_INTEGER
))
2214 if (i
->ts
.kind
!= j
->ts
.kind
)
2216 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2226 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2228 if (!type_check (i
, 0, BT_INTEGER
))
2231 if (!type_check (pos
, 1, BT_INTEGER
))
2234 if (!type_check (len
, 2, BT_INTEGER
))
2237 if (!nonnegative_check ("pos", pos
))
2240 if (!nonnegative_check ("len", len
))
2243 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2251 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2255 if (!type_check (c
, 0, BT_CHARACTER
))
2258 if (!kind_check (kind
, 1, BT_INTEGER
))
2261 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2262 "with KIND argument at %L",
2263 gfc_current_intrinsic
, &kind
->where
))
2266 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2272 /* Substring references don't have the charlength set. */
2274 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2277 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2281 /* Check that the argument is length one. Non-constant lengths
2282 can't be checked here, so assume they are ok. */
2283 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2285 /* If we already have a length for this expression then use it. */
2286 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2288 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2295 start
= ref
->u
.ss
.start
;
2296 end
= ref
->u
.ss
.end
;
2299 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2300 || start
->expr_type
!= EXPR_CONSTANT
)
2303 i
= mpz_get_si (end
->value
.integer
) + 1
2304 - mpz_get_si (start
->value
.integer
);
2312 gfc_error ("Argument of %s at %L must be of length one",
2313 gfc_current_intrinsic
, &c
->where
);
2322 gfc_check_idnint (gfc_expr
*a
)
2324 if (!double_check (a
, 0))
2332 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2334 if (!type_check (i
, 0, BT_INTEGER
))
2337 if (!type_check (j
, 1, BT_INTEGER
))
2340 if (i
->ts
.kind
!= j
->ts
.kind
)
2342 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2352 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2355 if (!type_check (string
, 0, BT_CHARACTER
)
2356 || !type_check (substring
, 1, BT_CHARACTER
))
2359 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2362 if (!kind_check (kind
, 3, BT_INTEGER
))
2364 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2365 "with KIND argument at %L",
2366 gfc_current_intrinsic
, &kind
->where
))
2369 if (string
->ts
.kind
!= substring
->ts
.kind
)
2371 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
2372 "kind as '%s'", gfc_current_intrinsic_arg
[1]->name
,
2373 gfc_current_intrinsic
, &substring
->where
,
2374 gfc_current_intrinsic_arg
[0]->name
);
2383 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2385 if (!numeric_check (x
, 0))
2388 if (!kind_check (kind
, 1, BT_INTEGER
))
2396 gfc_check_intconv (gfc_expr
*x
)
2398 if (!numeric_check (x
, 0))
2406 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2408 if (!type_check (i
, 0, BT_INTEGER
))
2411 if (!type_check (j
, 1, BT_INTEGER
))
2414 if (i
->ts
.kind
!= j
->ts
.kind
)
2416 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2426 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2428 if (!type_check (i
, 0, BT_INTEGER
)
2429 || !type_check (shift
, 1, BT_INTEGER
))
2432 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2440 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2442 if (!type_check (i
, 0, BT_INTEGER
)
2443 || !type_check (shift
, 1, BT_INTEGER
))
2450 if (!type_check (size
, 2, BT_INTEGER
))
2453 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2456 if (size
->expr_type
== EXPR_CONSTANT
)
2458 gfc_extract_int (size
, &i3
);
2461 gfc_error ("SIZE at %L must be positive", &size
->where
);
2465 if (shift
->expr_type
== EXPR_CONSTANT
)
2467 gfc_extract_int (shift
, &i2
);
2473 gfc_error ("The absolute value of SHIFT at %L must be less "
2474 "than or equal to SIZE at %L", &shift
->where
,
2481 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2489 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2491 if (!type_check (pid
, 0, BT_INTEGER
))
2494 if (!type_check (sig
, 1, BT_INTEGER
))
2502 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2504 if (!type_check (pid
, 0, BT_INTEGER
))
2507 if (!scalar_check (pid
, 0))
2510 if (!type_check (sig
, 1, BT_INTEGER
))
2513 if (!scalar_check (sig
, 1))
2519 if (!type_check (status
, 2, BT_INTEGER
))
2522 if (!scalar_check (status
, 2))
2530 gfc_check_kind (gfc_expr
*x
)
2532 if (x
->ts
.type
== BT_DERIVED
)
2534 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2535 "non-derived type", gfc_current_intrinsic_arg
[0]->name
,
2536 gfc_current_intrinsic
, &x
->where
);
2545 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2547 if (!array_check (array
, 0))
2550 if (!dim_check (dim
, 1, false))
2553 if (!dim_rank_check (dim
, array
, 1))
2556 if (!kind_check (kind
, 2, BT_INTEGER
))
2558 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2559 "with KIND argument at %L",
2560 gfc_current_intrinsic
, &kind
->where
))
2568 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2570 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2572 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2576 if (!coarray_check (coarray
, 0))
2581 if (!dim_check (dim
, 1, false))
2584 if (!dim_corank_check (dim
, coarray
))
2588 if (!kind_check (kind
, 2, BT_INTEGER
))
2596 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2598 if (!type_check (s
, 0, BT_CHARACTER
))
2601 if (!kind_check (kind
, 1, BT_INTEGER
))
2603 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2604 "with KIND argument at %L",
2605 gfc_current_intrinsic
, &kind
->where
))
2613 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2615 if (!type_check (a
, 0, BT_CHARACTER
))
2617 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2620 if (!type_check (b
, 1, BT_CHARACTER
))
2622 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2630 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2632 if (!type_check (path1
, 0, BT_CHARACTER
))
2634 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2637 if (!type_check (path2
, 1, BT_CHARACTER
))
2639 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2647 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2649 if (!type_check (path1
, 0, BT_CHARACTER
))
2651 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2654 if (!type_check (path2
, 1, BT_CHARACTER
))
2656 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2662 if (!type_check (status
, 2, BT_INTEGER
))
2665 if (!scalar_check (status
, 2))
2673 gfc_check_loc (gfc_expr
*expr
)
2675 return variable_check (expr
, 0, true);
2680 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2682 if (!type_check (path1
, 0, BT_CHARACTER
))
2684 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2687 if (!type_check (path2
, 1, BT_CHARACTER
))
2689 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2697 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2699 if (!type_check (path1
, 0, BT_CHARACTER
))
2701 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2704 if (!type_check (path2
, 1, BT_CHARACTER
))
2706 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2712 if (!type_check (status
, 2, BT_INTEGER
))
2715 if (!scalar_check (status
, 2))
2723 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2725 if (!type_check (a
, 0, BT_LOGICAL
))
2727 if (!kind_check (kind
, 1, BT_LOGICAL
))
2734 /* Min/max family. */
2737 min_max_args (gfc_actual_arglist
*args
)
2739 gfc_actual_arglist
*arg
;
2740 int i
, j
, nargs
, *nlabels
, nlabelless
;
2741 bool a1
= false, a2
= false;
2743 if (args
== NULL
|| args
->next
== NULL
)
2745 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2746 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2753 if (!args
->next
->name
)
2757 for (arg
= args
; arg
; arg
= arg
->next
)
2764 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2766 nlabels
= XALLOCAVEC (int, nargs
);
2767 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2773 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2775 n
= strtol (&arg
->name
[1], &endp
, 10);
2776 if (endp
[0] != '\0')
2780 if (n
<= nlabelless
)
2793 gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
2794 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2795 gfc_current_intrinsic_where
);
2799 /* Check for duplicates. */
2800 for (i
= 0; i
< nargs
; i
++)
2801 for (j
= i
+ 1; j
< nargs
; j
++)
2802 if (nlabels
[i
] == nlabels
[j
])
2808 gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg
->name
,
2809 &arg
->expr
->where
, gfc_current_intrinsic
);
2813 gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg
->name
,
2814 &arg
->expr
->where
, gfc_current_intrinsic
);
2820 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2822 gfc_actual_arglist
*arg
, *tmp
;
2826 if (!min_max_args (arglist
))
2829 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2832 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2834 if (x
->ts
.type
== type
)
2836 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
2837 "kinds at %L", &x
->where
))
2842 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2843 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2844 gfc_basic_typename (type
), kind
);
2849 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2850 if (!gfc_check_conformance (tmp
->expr
, x
,
2851 "arguments 'a%d' and 'a%d' for "
2852 "intrinsic '%s'", m
, n
,
2853 gfc_current_intrinsic
))
2862 gfc_check_min_max (gfc_actual_arglist
*arg
)
2866 if (!min_max_args (arg
))
2871 if (x
->ts
.type
== BT_CHARACTER
)
2873 if (!gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2874 "with CHARACTER argument at %L",
2875 gfc_current_intrinsic
, &x
->where
))
2878 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2880 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2881 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2885 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2890 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2892 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2897 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2899 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2904 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2906 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2910 /* End of min/max family. */
2913 gfc_check_malloc (gfc_expr
*size
)
2915 if (!type_check (size
, 0, BT_INTEGER
))
2918 if (!scalar_check (size
, 0))
2926 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2928 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2930 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2931 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2932 gfc_current_intrinsic
, &matrix_a
->where
);
2936 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2938 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2939 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2940 gfc_current_intrinsic
, &matrix_b
->where
);
2944 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2945 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2947 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2948 gfc_current_intrinsic
, &matrix_a
->where
,
2949 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2953 switch (matrix_a
->rank
)
2956 if (!rank_check (matrix_b
, 1, 2))
2958 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2959 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2961 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2962 "and '%s' at %L for intrinsic matmul",
2963 gfc_current_intrinsic_arg
[0]->name
,
2964 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2970 if (matrix_b
->rank
!= 2)
2972 if (!rank_check (matrix_b
, 1, 1))
2975 /* matrix_b has rank 1 or 2 here. Common check for the cases
2976 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2977 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2978 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2980 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2981 "dimension 1 for argument '%s' at %L for intrinsic "
2982 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2983 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2989 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2990 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
2991 gfc_current_intrinsic
, &matrix_a
->where
);
2999 /* Whoever came up with this interface was probably on something.
3000 The possibilities for the occupation of the second and third
3007 NULL MASK minloc(array, mask=m)
3010 I.e. in the case of minloc(array,mask), mask will be in the second
3011 position of the argument list and we'll have to fix that up. */
3014 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3016 gfc_expr
*a
, *m
, *d
;
3019 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
3023 m
= ap
->next
->next
->expr
;
3025 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3026 && ap
->next
->name
== NULL
)
3030 ap
->next
->expr
= NULL
;
3031 ap
->next
->next
->expr
= m
;
3034 if (!dim_check (d
, 1, false))
3037 if (!dim_rank_check (d
, a
, 0))
3040 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3044 && !gfc_check_conformance (a
, m
,
3045 "arguments '%s' and '%s' for intrinsic %s",
3046 gfc_current_intrinsic_arg
[0]->name
,
3047 gfc_current_intrinsic_arg
[2]->name
,
3048 gfc_current_intrinsic
))
3055 /* Similar to minloc/maxloc, the argument list might need to be
3056 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3057 difference is that MINLOC/MAXLOC take an additional KIND argument.
3058 The possibilities are:
3064 NULL MASK minval(array, mask=m)
3067 I.e. in the case of minval(array,mask), mask will be in the second
3068 position of the argument list and we'll have to fix that up. */
3071 check_reduction (gfc_actual_arglist
*ap
)
3073 gfc_expr
*a
, *m
, *d
;
3077 m
= ap
->next
->next
->expr
;
3079 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3080 && ap
->next
->name
== NULL
)
3084 ap
->next
->expr
= NULL
;
3085 ap
->next
->next
->expr
= m
;
3088 if (!dim_check (d
, 1, false))
3091 if (!dim_rank_check (d
, a
, 0))
3094 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3098 && !gfc_check_conformance (a
, m
,
3099 "arguments '%s' and '%s' for intrinsic %s",
3100 gfc_current_intrinsic_arg
[0]->name
,
3101 gfc_current_intrinsic_arg
[2]->name
,
3102 gfc_current_intrinsic
))
3110 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3112 if (!int_or_real_check (ap
->expr
, 0)
3113 || !array_check (ap
->expr
, 0))
3116 return check_reduction (ap
);
3121 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3123 if (!numeric_check (ap
->expr
, 0)
3124 || !array_check (ap
->expr
, 0))
3127 return check_reduction (ap
);
3131 /* For IANY, IALL and IPARITY. */
3134 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3138 if (!type_check (i
, 0, BT_INTEGER
))
3141 if (!nonnegative_check ("I", i
))
3144 if (!kind_check (kind
, 1, BT_INTEGER
))
3148 gfc_extract_int (kind
, &k
);
3150 k
= gfc_default_integer_kind
;
3152 if (!less_than_bitsizekind ("I", i
, k
))
3160 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3162 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3164 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
3165 gfc_current_intrinsic_arg
[0]->name
,
3166 gfc_current_intrinsic
, &ap
->expr
->where
);
3170 if (!array_check (ap
->expr
, 0))
3173 return check_reduction (ap
);
3178 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3180 if (!same_type_check (tsource
, 0, fsource
, 1))
3183 if (!type_check (mask
, 2, BT_LOGICAL
))
3186 if (tsource
->ts
.type
== BT_CHARACTER
)
3187 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3194 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3196 if (!type_check (i
, 0, BT_INTEGER
))
3199 if (!type_check (j
, 1, BT_INTEGER
))
3202 if (!type_check (mask
, 2, BT_INTEGER
))
3205 if (!same_type_check (i
, 0, j
, 1))
3208 if (!same_type_check (i
, 0, mask
, 2))
3216 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3218 if (!variable_check (from
, 0, false))
3220 if (!allocatable_check (from
, 0))
3222 if (gfc_is_coindexed (from
))
3224 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3225 "coindexed", &from
->where
);
3229 if (!variable_check (to
, 1, false))
3231 if (!allocatable_check (to
, 1))
3233 if (gfc_is_coindexed (to
))
3235 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3236 "coindexed", &to
->where
);
3240 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3242 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3243 "polymorphic if FROM is polymorphic",
3248 if (!same_type_check (to
, 1, from
, 0))
3251 if (to
->rank
!= from
->rank
)
3253 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3254 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3259 /* IR F08/0040; cf. 12-006A. */
3260 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3262 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3263 "must have the same corank %d/%d", &to
->where
,
3264 gfc_get_corank (from
), gfc_get_corank (to
));
3268 /* CLASS arguments: Make sure the vtab of from is present. */
3269 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3270 gfc_find_vtab (&from
->ts
);
3277 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3279 if (!type_check (x
, 0, BT_REAL
))
3282 if (!type_check (s
, 1, BT_REAL
))
3285 if (s
->expr_type
== EXPR_CONSTANT
)
3287 if (mpfr_sgn (s
->value
.real
) == 0)
3289 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
3300 gfc_check_new_line (gfc_expr
*a
)
3302 if (!type_check (a
, 0, BT_CHARACTER
))
3310 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3312 if (!type_check (array
, 0, BT_REAL
))
3315 if (!array_check (array
, 0))
3318 if (!dim_rank_check (dim
, array
, false))
3325 gfc_check_null (gfc_expr
*mold
)
3327 symbol_attribute attr
;
3332 if (!variable_check (mold
, 0, true))
3335 attr
= gfc_variable_attr (mold
, NULL
);
3337 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3339 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
3340 "ALLOCATABLE or procedure pointer",
3341 gfc_current_intrinsic_arg
[0]->name
,
3342 gfc_current_intrinsic
, &mold
->where
);
3346 if (attr
.allocatable
3347 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3348 "allocatable MOLD at %L", &mold
->where
))
3352 if (gfc_is_coindexed (mold
))
3354 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
3355 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3356 gfc_current_intrinsic
, &mold
->where
);
3365 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3367 if (!array_check (array
, 0))
3370 if (!type_check (mask
, 1, BT_LOGICAL
))
3373 if (!gfc_check_conformance (array
, mask
,
3374 "arguments '%s' and '%s' for intrinsic '%s'",
3375 gfc_current_intrinsic_arg
[0]->name
,
3376 gfc_current_intrinsic_arg
[1]->name
,
3377 gfc_current_intrinsic
))
3382 mpz_t array_size
, vector_size
;
3383 bool have_array_size
, have_vector_size
;
3385 if (!same_type_check (array
, 0, vector
, 2))
3388 if (!rank_check (vector
, 2, 1))
3391 /* VECTOR requires at least as many elements as MASK
3392 has .TRUE. values. */
3393 have_array_size
= gfc_array_size(array
, &array_size
);
3394 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3396 if (have_vector_size
3397 && (mask
->expr_type
== EXPR_ARRAY
3398 || (mask
->expr_type
== EXPR_CONSTANT
3399 && have_array_size
)))
3401 int mask_true_values
= 0;
3403 if (mask
->expr_type
== EXPR_ARRAY
)
3405 gfc_constructor
*mask_ctor
;
3406 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3409 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3411 mask_true_values
= 0;
3415 if (mask_ctor
->expr
->value
.logical
)
3418 mask_ctor
= gfc_constructor_next (mask_ctor
);
3421 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3422 mask_true_values
= mpz_get_si (array_size
);
3424 if (mpz_get_si (vector_size
) < mask_true_values
)
3426 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3427 "provide at least as many elements as there "
3428 "are .TRUE. values in '%s' (%ld/%d)",
3429 gfc_current_intrinsic_arg
[2]->name
,
3430 gfc_current_intrinsic
, &vector
->where
,
3431 gfc_current_intrinsic_arg
[1]->name
,
3432 mpz_get_si (vector_size
), mask_true_values
);
3437 if (have_array_size
)
3438 mpz_clear (array_size
);
3439 if (have_vector_size
)
3440 mpz_clear (vector_size
);
3448 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3450 if (!type_check (mask
, 0, BT_LOGICAL
))
3453 if (!array_check (mask
, 0))
3456 if (!dim_rank_check (dim
, mask
, false))
3464 gfc_check_precision (gfc_expr
*x
)
3466 if (!real_or_complex_check (x
, 0))
3474 gfc_check_present (gfc_expr
*a
)
3478 if (!variable_check (a
, 0, true))
3481 sym
= a
->symtree
->n
.sym
;
3482 if (!sym
->attr
.dummy
)
3484 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3485 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3486 gfc_current_intrinsic
, &a
->where
);
3490 if (!sym
->attr
.optional
)
3492 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3493 "an OPTIONAL dummy variable",
3494 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3499 /* 13.14.82 PRESENT(A)
3501 Argument. A shall be the name of an optional dummy argument that is
3502 accessible in the subprogram in which the PRESENT function reference
3506 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3507 && (a
->ref
->u
.ar
.type
== AR_FULL
3508 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3509 && a
->ref
->u
.ar
.as
->rank
== 0))))
3511 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3512 "subobject of '%s'", gfc_current_intrinsic_arg
[0]->name
,
3513 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3522 gfc_check_radix (gfc_expr
*x
)
3524 if (!int_or_real_check (x
, 0))
3532 gfc_check_range (gfc_expr
*x
)
3534 if (!numeric_check (x
, 0))
3542 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3544 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3545 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3547 bool is_variable
= true;
3549 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3550 if (a
->expr_type
== EXPR_FUNCTION
)
3551 is_variable
= a
->value
.function
.esym
3552 ? a
->value
.function
.esym
->result
->attr
.pointer
3553 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3555 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3556 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3559 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3560 "object", &a
->where
);
3568 /* real, float, sngl. */
3570 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3572 if (!numeric_check (a
, 0))
3575 if (!kind_check (kind
, 1, BT_REAL
))
3583 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3585 if (!type_check (path1
, 0, BT_CHARACTER
))
3587 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3590 if (!type_check (path2
, 1, BT_CHARACTER
))
3592 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3600 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3602 if (!type_check (path1
, 0, BT_CHARACTER
))
3604 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3607 if (!type_check (path2
, 1, BT_CHARACTER
))
3609 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3615 if (!type_check (status
, 2, BT_INTEGER
))
3618 if (!scalar_check (status
, 2))
3626 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3628 if (!type_check (x
, 0, BT_CHARACTER
))
3631 if (!scalar_check (x
, 0))
3634 if (!type_check (y
, 0, BT_INTEGER
))
3637 if (!scalar_check (y
, 1))
3645 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3646 gfc_expr
*pad
, gfc_expr
*order
)
3652 if (!array_check (source
, 0))
3655 if (!rank_check (shape
, 1, 1))
3658 if (!type_check (shape
, 1, BT_INTEGER
))
3661 if (!gfc_array_size (shape
, &size
))
3663 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3664 "array of constant size", &shape
->where
);
3668 shape_size
= mpz_get_ui (size
);
3671 if (shape_size
<= 0)
3673 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3674 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3678 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3680 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3681 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3684 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3688 for (i
= 0; i
< shape_size
; ++i
)
3690 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3691 if (e
->expr_type
!= EXPR_CONSTANT
)
3694 gfc_extract_int (e
, &extent
);
3697 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3698 "negative element (%d)",
3699 gfc_current_intrinsic_arg
[1]->name
,
3700 gfc_current_intrinsic
, &e
->where
, extent
);
3708 if (!same_type_check (source
, 0, pad
, 2))
3711 if (!array_check (pad
, 2))
3717 if (!array_check (order
, 3))
3720 if (!type_check (order
, 3, BT_INTEGER
))
3723 if (order
->expr_type
== EXPR_ARRAY
)
3725 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3728 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3731 gfc_array_size (order
, &size
);
3732 order_size
= mpz_get_ui (size
);
3735 if (order_size
!= shape_size
)
3737 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3738 "has wrong number of elements (%d/%d)",
3739 gfc_current_intrinsic_arg
[3]->name
,
3740 gfc_current_intrinsic
, &order
->where
,
3741 order_size
, shape_size
);
3745 for (i
= 1; i
<= order_size
; ++i
)
3747 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3748 if (e
->expr_type
!= EXPR_CONSTANT
)
3751 gfc_extract_int (e
, &dim
);
3753 if (dim
< 1 || dim
> order_size
)
3755 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3756 "has out-of-range dimension (%d)",
3757 gfc_current_intrinsic_arg
[3]->name
,
3758 gfc_current_intrinsic
, &e
->where
, dim
);
3762 if (perm
[dim
-1] != 0)
3764 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3765 "invalid permutation of dimensions (dimension "
3767 gfc_current_intrinsic_arg
[3]->name
,
3768 gfc_current_intrinsic
, &e
->where
, dim
);
3777 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3778 && gfc_is_constant_expr (shape
)
3779 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3780 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3782 /* Check the match in size between source and destination. */
3783 if (gfc_array_size (source
, &nelems
))
3789 mpz_init_set_ui (size
, 1);
3790 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3791 c
; c
= gfc_constructor_next (c
))
3792 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3794 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3800 gfc_error ("Without padding, there are not enough elements "
3801 "in the intrinsic RESHAPE source at %L to match "
3802 "the shape", &source
->where
);
3813 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3815 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3817 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3818 "cannot be of type %s",
3819 gfc_current_intrinsic_arg
[0]->name
,
3820 gfc_current_intrinsic
,
3821 &a
->where
, gfc_typename (&a
->ts
));
3825 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3827 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3828 "must be of an extensible type",
3829 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3834 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3836 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3837 "cannot be of type %s",
3838 gfc_current_intrinsic_arg
[0]->name
,
3839 gfc_current_intrinsic
,
3840 &b
->where
, gfc_typename (&b
->ts
));
3844 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3846 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3847 "must be of an extensible type",
3848 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3858 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3860 if (!type_check (x
, 0, BT_REAL
))
3863 if (!type_check (i
, 1, BT_INTEGER
))
3871 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3873 if (!type_check (x
, 0, BT_CHARACTER
))
3876 if (!type_check (y
, 1, BT_CHARACTER
))
3879 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
3882 if (!kind_check (kind
, 3, BT_INTEGER
))
3884 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3885 "with KIND argument at %L",
3886 gfc_current_intrinsic
, &kind
->where
))
3889 if (!same_type_check (x
, 0, y
, 1))
3897 gfc_check_secnds (gfc_expr
*r
)
3899 if (!type_check (r
, 0, BT_REAL
))
3902 if (!kind_value_check (r
, 0, 4))
3905 if (!scalar_check (r
, 0))
3913 gfc_check_selected_char_kind (gfc_expr
*name
)
3915 if (!type_check (name
, 0, BT_CHARACTER
))
3918 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
3921 if (!scalar_check (name
, 0))
3929 gfc_check_selected_int_kind (gfc_expr
*r
)
3931 if (!type_check (r
, 0, BT_INTEGER
))
3934 if (!scalar_check (r
, 0))
3942 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3944 if (p
== NULL
&& r
== NULL
3945 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
3946 " neither 'P' nor 'R' argument at %L",
3947 gfc_current_intrinsic_where
))
3952 if (!type_check (p
, 0, BT_INTEGER
))
3955 if (!scalar_check (p
, 0))
3961 if (!type_check (r
, 1, BT_INTEGER
))
3964 if (!scalar_check (r
, 1))
3970 if (!type_check (radix
, 1, BT_INTEGER
))
3973 if (!scalar_check (radix
, 1))
3976 if (!gfc_notify_std (GFC_STD_F2008
, "'%s' intrinsic with "
3977 "RADIX argument at %L", gfc_current_intrinsic
,
3987 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3989 if (!type_check (x
, 0, BT_REAL
))
3992 if (!type_check (i
, 1, BT_INTEGER
))
4000 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4004 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4007 ar
= gfc_find_array_ref (source
);
4009 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4011 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
4012 "an assumed size array", &source
->where
);
4016 if (!kind_check (kind
, 1, BT_INTEGER
))
4018 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4019 "with KIND argument at %L",
4020 gfc_current_intrinsic
, &kind
->where
))
4028 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4030 if (!type_check (i
, 0, BT_INTEGER
))
4033 if (!type_check (shift
, 0, BT_INTEGER
))
4036 if (!nonnegative_check ("SHIFT", shift
))
4039 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4047 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4049 if (!int_or_real_check (a
, 0))
4052 if (!same_type_check (a
, 0, b
, 1))
4060 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4062 if (!array_check (array
, 0))
4065 if (!dim_check (dim
, 1, true))
4068 if (!dim_rank_check (dim
, array
, 0))
4071 if (!kind_check (kind
, 2, BT_INTEGER
))
4073 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4074 "with KIND argument at %L",
4075 gfc_current_intrinsic
, &kind
->where
))
4084 gfc_check_sizeof (gfc_expr
*arg
)
4086 if (arg
->ts
.type
== BT_PROCEDURE
)
4088 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
4089 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4094 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4095 if (arg
->ts
.type
== BT_ASSUMED
4096 && (arg
->symtree
->n
.sym
->as
== NULL
4097 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4098 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4099 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4101 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
4102 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4107 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4108 && arg
->symtree
->n
.sym
->as
!= NULL
4109 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4110 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4112 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
4113 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4114 gfc_current_intrinsic
, &arg
->where
);
4122 /* Check whether an expression is interoperable. When returning false,
4123 msg is set to a string telling why the expression is not interoperable,
4124 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4125 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4126 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4127 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4131 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4135 if (expr
->ts
.type
== BT_CLASS
)
4137 *msg
= "Expression is polymorphic";
4141 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4142 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4144 *msg
= "Expression is a noninteroperable derived type";
4148 if (expr
->ts
.type
== BT_PROCEDURE
)
4150 *msg
= "Procedure unexpected as argument";
4154 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4157 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4158 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4160 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4164 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4165 && expr
->ts
.kind
!= 1)
4167 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4171 if (expr
->ts
.type
== BT_CHARACTER
) {
4172 if (expr
->ts
.deferred
)
4174 /* TS 29113 allows deferred-length strings as dummy arguments,
4175 but it is not an interoperable type. */
4176 *msg
= "Expression shall not be a deferred-length string";
4180 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4181 && !gfc_simplify_expr (expr
, 0))
4182 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4184 if (!c_loc
&& expr
->ts
.u
.cl
4185 && (!expr
->ts
.u
.cl
->length
4186 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4187 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4189 *msg
= "Type shall have a character length of 1";
4194 /* Note: The following checks are about interoperatable variables, Fortran
4195 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4196 is allowed, e.g. assumed-shape arrays with TS 29113. */
4198 if (gfc_is_coarray (expr
))
4200 *msg
= "Coarrays are not interoperable";
4204 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4206 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4207 if (ar
->type
!= AR_FULL
)
4209 *msg
= "Only whole-arrays are interoperable";
4212 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4213 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4215 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4225 gfc_check_c_sizeof (gfc_expr
*arg
)
4229 if (!is_c_interoperable (arg
, &msg
, false, false))
4231 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
4232 "interoperable data entity: %s",
4233 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4238 if (arg
->ts
.type
== BT_ASSUMED
)
4240 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
4242 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4247 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4248 && arg
->symtree
->n
.sym
->as
!= NULL
4249 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4250 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4252 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
4253 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4254 gfc_current_intrinsic
, &arg
->where
);
4263 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4265 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4266 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4267 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4268 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4270 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4271 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4275 if (!scalar_check (c_ptr_1
, 0))
4279 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4280 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4281 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4282 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4284 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4285 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4286 gfc_typename (&c_ptr_1
->ts
),
4287 gfc_typename (&c_ptr_2
->ts
));
4291 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4299 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4301 symbol_attribute attr
;
4304 if (cptr
->ts
.type
!= BT_DERIVED
4305 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4306 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4308 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4309 "type TYPE(C_PTR)", &cptr
->where
);
4313 if (!scalar_check (cptr
, 0))
4316 attr
= gfc_expr_attr (fptr
);
4320 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4325 if (fptr
->ts
.type
== BT_CLASS
)
4327 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4332 if (gfc_is_coindexed (fptr
))
4334 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4335 "coindexed", &fptr
->where
);
4339 if (fptr
->rank
== 0 && shape
)
4341 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4342 "FPTR", &fptr
->where
);
4345 else if (fptr
->rank
&& !shape
)
4347 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4348 "FPTR at %L", &fptr
->where
);
4352 if (shape
&& !rank_check (shape
, 2, 1))
4355 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4361 if (gfc_array_size (shape
, &size
))
4363 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4366 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4367 "size as the RANK of FPTR", &shape
->where
);
4374 if (fptr
->ts
.type
== BT_CLASS
)
4376 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4380 if (!is_c_interoperable (fptr
, &msg
, false, true))
4381 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4382 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4389 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4391 symbol_attribute attr
;
4393 if (cptr
->ts
.type
!= BT_DERIVED
4394 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4395 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4397 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4398 "type TYPE(C_FUNPTR)", &cptr
->where
);
4402 if (!scalar_check (cptr
, 0))
4405 attr
= gfc_expr_attr (fptr
);
4407 if (!attr
.proc_pointer
)
4409 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4410 "pointer", &fptr
->where
);
4414 if (gfc_is_coindexed (fptr
))
4416 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4417 "coindexed", &fptr
->where
);
4421 if (!attr
.is_bind_c
)
4422 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4423 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4430 gfc_check_c_funloc (gfc_expr
*x
)
4432 symbol_attribute attr
;
4434 if (gfc_is_coindexed (x
))
4436 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4437 "coindexed", &x
->where
);
4441 attr
= gfc_expr_attr (x
);
4443 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4444 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4446 gfc_namespace
*ns
= gfc_current_ns
;
4448 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4449 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4451 gfc_error ("Function result '%s' at %L is invalid as X argument "
4452 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4457 if (attr
.flavor
!= FL_PROCEDURE
)
4459 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4460 "or a procedure pointer", &x
->where
);
4464 if (!attr
.is_bind_c
)
4465 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4466 "at %L to C_FUNLOC", &x
->where
);
4472 gfc_check_c_loc (gfc_expr
*x
)
4474 symbol_attribute attr
;
4477 if (gfc_is_coindexed (x
))
4479 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4483 if (x
->ts
.type
== BT_CLASS
)
4485 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4490 attr
= gfc_expr_attr (x
);
4493 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4494 || attr
.flavor
== FL_PARAMETER
))
4496 gfc_error ("Argument X at %L to C_LOC shall have either "
4497 "the POINTER or the TARGET attribute", &x
->where
);
4501 if (x
->ts
.type
== BT_CHARACTER
4502 && gfc_var_strlen (x
) == 0)
4504 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4505 "string", &x
->where
);
4509 if (!is_c_interoperable (x
, &msg
, true, false))
4511 if (x
->ts
.type
== BT_CLASS
)
4513 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4519 && !gfc_notify_std (GFC_STD_F2008_TS
,
4520 "Noninteroperable array at %L as"
4521 " argument to C_LOC: %s", &x
->where
, msg
))
4524 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4526 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4528 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4529 && !attr
.allocatable
4530 && !gfc_notify_std (GFC_STD_F2008
,
4531 "Array of interoperable type at %L "
4532 "to C_LOC which is nonallocatable and neither "
4533 "assumed size nor explicit size", &x
->where
))
4535 else if (ar
->type
!= AR_FULL
4536 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4537 "to C_LOC", &x
->where
))
4546 gfc_check_sleep_sub (gfc_expr
*seconds
)
4548 if (!type_check (seconds
, 0, BT_INTEGER
))
4551 if (!scalar_check (seconds
, 0))
4558 gfc_check_sngl (gfc_expr
*a
)
4560 if (!type_check (a
, 0, BT_REAL
))
4563 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4564 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4565 "REAL argument to %s intrinsic at %L",
4566 gfc_current_intrinsic
, &a
->where
))
4573 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4575 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4577 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
4578 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4579 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4587 if (!dim_check (dim
, 1, false))
4590 /* dim_rank_check() does not apply here. */
4592 && dim
->expr_type
== EXPR_CONSTANT
4593 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4594 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4596 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
4597 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4598 gfc_current_intrinsic
, &dim
->where
);
4602 if (!type_check (ncopies
, 2, BT_INTEGER
))
4605 if (!scalar_check (ncopies
, 2))
4612 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4616 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4618 if (!type_check (unit
, 0, BT_INTEGER
))
4621 if (!scalar_check (unit
, 0))
4624 if (!type_check (c
, 1, BT_CHARACTER
))
4626 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4632 if (!type_check (status
, 2, BT_INTEGER
)
4633 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4634 || !scalar_check (status
, 2))
4642 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4644 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4649 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4651 if (!type_check (c
, 0, BT_CHARACTER
))
4653 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4659 if (!type_check (status
, 1, BT_INTEGER
)
4660 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4661 || !scalar_check (status
, 1))
4669 gfc_check_fgetput (gfc_expr
*c
)
4671 return gfc_check_fgetput_sub (c
, NULL
);
4676 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4678 if (!type_check (unit
, 0, BT_INTEGER
))
4681 if (!scalar_check (unit
, 0))
4684 if (!type_check (offset
, 1, BT_INTEGER
))
4687 if (!scalar_check (offset
, 1))
4690 if (!type_check (whence
, 2, BT_INTEGER
))
4693 if (!scalar_check (whence
, 2))
4699 if (!type_check (status
, 3, BT_INTEGER
))
4702 if (!kind_value_check (status
, 3, 4))
4705 if (!scalar_check (status
, 3))
4714 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4716 if (!type_check (unit
, 0, BT_INTEGER
))
4719 if (!scalar_check (unit
, 0))
4722 if (!type_check (array
, 1, BT_INTEGER
)
4723 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4726 if (!array_check (array
, 1))
4734 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4736 if (!type_check (unit
, 0, BT_INTEGER
))
4739 if (!scalar_check (unit
, 0))
4742 if (!type_check (array
, 1, BT_INTEGER
)
4743 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4746 if (!array_check (array
, 1))
4752 if (!type_check (status
, 2, BT_INTEGER
)
4753 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4756 if (!scalar_check (status
, 2))
4764 gfc_check_ftell (gfc_expr
*unit
)
4766 if (!type_check (unit
, 0, BT_INTEGER
))
4769 if (!scalar_check (unit
, 0))
4777 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
4779 if (!type_check (unit
, 0, BT_INTEGER
))
4782 if (!scalar_check (unit
, 0))
4785 if (!type_check (offset
, 1, BT_INTEGER
))
4788 if (!scalar_check (offset
, 1))
4796 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
4798 if (!type_check (name
, 0, BT_CHARACTER
))
4800 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4803 if (!type_check (array
, 1, BT_INTEGER
)
4804 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4807 if (!array_check (array
, 1))
4815 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
4817 if (!type_check (name
, 0, BT_CHARACTER
))
4819 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4822 if (!type_check (array
, 1, BT_INTEGER
)
4823 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4826 if (!array_check (array
, 1))
4832 if (!type_check (status
, 2, BT_INTEGER
)
4833 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4836 if (!scalar_check (status
, 2))
4844 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
4848 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4850 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4854 if (!coarray_check (coarray
, 0))
4859 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4860 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
4864 if (gfc_array_size (sub
, &nelems
))
4866 int corank
= gfc_get_corank (coarray
);
4868 if (mpz_cmp_ui (nelems
, corank
) != 0)
4870 gfc_error ("The number of array elements of the SUB argument to "
4871 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4872 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
4884 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
4886 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4888 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4894 if (!type_check (distance
, 0, BT_INTEGER
))
4897 if (!nonnegative_check ("DISTANCE", distance
))
4900 if (!scalar_check (distance
, 0))
4903 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
4904 "NUM_IMAGES at %L", &distance
->where
))
4910 if (!type_check (failed
, 1, BT_LOGICAL
))
4913 if (!scalar_check (failed
, 1))
4916 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
4917 "NUM_IMAGES at %L", &distance
->where
))
4926 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
4928 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4930 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4934 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
4937 if (dim
!= NULL
&& coarray
== NULL
)
4939 gfc_error ("DIM argument without COARRAY argument not allowed for "
4940 "THIS_IMAGE intrinsic at %L", &dim
->where
);
4944 if (distance
&& (coarray
|| dim
))
4946 gfc_error ("The DISTANCE argument may not be specified together with the "
4947 "COARRAY or DIM argument in intrinsic at %L",
4952 /* Assume that we have "this_image (distance)". */
4953 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
4957 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
4966 if (!type_check (distance
, 2, BT_INTEGER
))
4969 if (!nonnegative_check ("DISTANCE", distance
))
4972 if (!scalar_check (distance
, 2))
4975 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
4976 "THIS_IMAGE at %L", &distance
->where
))
4982 if (!coarray_check (coarray
, 0))
4987 if (!dim_check (dim
, 1, false))
4990 if (!dim_corank_check (dim
, coarray
))
4997 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4998 by gfc_simplify_transfer. Return false if we cannot do so. */
5001 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5002 size_t *source_size
, size_t *result_size
,
5003 size_t *result_length_p
)
5005 size_t result_elt_size
;
5007 if (source
->expr_type
== EXPR_FUNCTION
)
5010 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5013 /* Calculate the size of the source. */
5014 *source_size
= gfc_target_expr_size (source
);
5015 if (*source_size
== 0)
5018 /* Determine the size of the element. */
5019 result_elt_size
= gfc_element_size (mold
);
5020 if (result_elt_size
== 0)
5023 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5028 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5031 result_length
= *source_size
/ result_elt_size
;
5032 if (result_length
* result_elt_size
< *source_size
)
5036 *result_size
= result_length
* result_elt_size
;
5037 if (result_length_p
)
5038 *result_length_p
= result_length
;
5041 *result_size
= result_elt_size
;
5048 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5053 if (mold
->ts
.type
== BT_HOLLERITH
)
5055 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
5056 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5062 if (!type_check (size
, 2, BT_INTEGER
))
5065 if (!scalar_check (size
, 2))
5068 if (!nonoptional_check (size
, 2))
5072 if (!gfc_option
.warn_surprising
)
5075 /* If we can't calculate the sizes, we cannot check any more.
5076 Return true for that case. */
5078 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5079 &result_size
, NULL
))
5082 if (source_size
< result_size
)
5083 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5084 "source size %ld < result size %ld", &source
->where
,
5085 (long) source_size
, (long) result_size
);
5092 gfc_check_transpose (gfc_expr
*matrix
)
5094 if (!rank_check (matrix
, 0, 2))
5102 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5104 if (!array_check (array
, 0))
5107 if (!dim_check (dim
, 1, false))
5110 if (!dim_rank_check (dim
, array
, 0))
5113 if (!kind_check (kind
, 2, BT_INTEGER
))
5115 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
5116 "with KIND argument at %L",
5117 gfc_current_intrinsic
, &kind
->where
))
5125 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5127 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
5129 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
5133 if (!coarray_check (coarray
, 0))
5138 if (!dim_check (dim
, 1, false))
5141 if (!dim_corank_check (dim
, coarray
))
5145 if (!kind_check (kind
, 2, BT_INTEGER
))
5153 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5157 if (!rank_check (vector
, 0, 1))
5160 if (!array_check (mask
, 1))
5163 if (!type_check (mask
, 1, BT_LOGICAL
))
5166 if (!same_type_check (vector
, 0, field
, 2))
5169 if (mask
->expr_type
== EXPR_ARRAY
5170 && gfc_array_size (vector
, &vector_size
))
5172 int mask_true_count
= 0;
5173 gfc_constructor
*mask_ctor
;
5174 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5177 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5179 mask_true_count
= 0;
5183 if (mask_ctor
->expr
->value
.logical
)
5186 mask_ctor
= gfc_constructor_next (mask_ctor
);
5189 if (mpz_get_si (vector_size
) < mask_true_count
)
5191 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
5192 "provide at least as many elements as there "
5193 "are .TRUE. values in '%s' (%ld/%d)",
5194 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5195 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5196 mpz_get_si (vector_size
), mask_true_count
);
5200 mpz_clear (vector_size
);
5203 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5205 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
5206 "the same rank as '%s' or be a scalar",
5207 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5208 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5212 if (mask
->rank
== field
->rank
)
5215 for (i
= 0; i
< field
->rank
; i
++)
5216 if (! identical_dimen_shape (mask
, i
, field
, i
))
5218 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
5219 "must have identical shape.",
5220 gfc_current_intrinsic_arg
[2]->name
,
5221 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5231 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5233 if (!type_check (x
, 0, BT_CHARACTER
))
5236 if (!same_type_check (x
, 0, y
, 1))
5239 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5242 if (!kind_check (kind
, 3, BT_INTEGER
))
5244 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
5245 "with KIND argument at %L",
5246 gfc_current_intrinsic
, &kind
->where
))
5254 gfc_check_trim (gfc_expr
*x
)
5256 if (!type_check (x
, 0, BT_CHARACTER
))
5259 if (!scalar_check (x
, 0))
5267 gfc_check_ttynam (gfc_expr
*unit
)
5269 if (!scalar_check (unit
, 0))
5272 if (!type_check (unit
, 0, BT_INTEGER
))
5279 /* Common check function for the half a dozen intrinsics that have a
5280 single real argument. */
5283 gfc_check_x (gfc_expr
*x
)
5285 if (!type_check (x
, 0, BT_REAL
))
5292 /************* Check functions for intrinsic subroutines *************/
5295 gfc_check_cpu_time (gfc_expr
*time
)
5297 if (!scalar_check (time
, 0))
5300 if (!type_check (time
, 0, BT_REAL
))
5303 if (!variable_check (time
, 0, false))
5311 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5312 gfc_expr
*zone
, gfc_expr
*values
)
5316 if (!type_check (date
, 0, BT_CHARACTER
))
5318 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5320 if (!scalar_check (date
, 0))
5322 if (!variable_check (date
, 0, false))
5328 if (!type_check (time
, 1, BT_CHARACTER
))
5330 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5332 if (!scalar_check (time
, 1))
5334 if (!variable_check (time
, 1, false))
5340 if (!type_check (zone
, 2, BT_CHARACTER
))
5342 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5344 if (!scalar_check (zone
, 2))
5346 if (!variable_check (zone
, 2, false))
5352 if (!type_check (values
, 3, BT_INTEGER
))
5354 if (!array_check (values
, 3))
5356 if (!rank_check (values
, 3, 1))
5358 if (!variable_check (values
, 3, false))
5367 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5368 gfc_expr
*to
, gfc_expr
*topos
)
5370 if (!type_check (from
, 0, BT_INTEGER
))
5373 if (!type_check (frompos
, 1, BT_INTEGER
))
5376 if (!type_check (len
, 2, BT_INTEGER
))
5379 if (!same_type_check (from
, 0, to
, 3))
5382 if (!variable_check (to
, 3, false))
5385 if (!type_check (topos
, 4, BT_INTEGER
))
5388 if (!nonnegative_check ("frompos", frompos
))
5391 if (!nonnegative_check ("topos", topos
))
5394 if (!nonnegative_check ("len", len
))
5397 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5400 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5408 gfc_check_random_number (gfc_expr
*harvest
)
5410 if (!type_check (harvest
, 0, BT_REAL
))
5413 if (!variable_check (harvest
, 0, false))
5421 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5423 unsigned int nargs
= 0, kiss_size
;
5424 locus
*where
= NULL
;
5425 mpz_t put_size
, get_size
;
5426 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
5428 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
5430 /* Keep the number of bytes in sync with kiss_size in
5431 libgfortran/intrinsics/random.c. */
5432 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
5436 if (size
->expr_type
!= EXPR_VARIABLE
5437 || !size
->symtree
->n
.sym
->attr
.optional
)
5440 if (!scalar_check (size
, 0))
5443 if (!type_check (size
, 0, BT_INTEGER
))
5446 if (!variable_check (size
, 0, false))
5449 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5455 if (put
->expr_type
!= EXPR_VARIABLE
5456 || !put
->symtree
->n
.sym
->attr
.optional
)
5459 where
= &put
->where
;
5462 if (!array_check (put
, 1))
5465 if (!rank_check (put
, 1, 1))
5468 if (!type_check (put
, 1, BT_INTEGER
))
5471 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5474 if (gfc_array_size (put
, &put_size
)
5475 && mpz_get_ui (put_size
) < kiss_size
)
5476 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5477 "too small (%i/%i)",
5478 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5479 where
, (int) mpz_get_ui (put_size
), kiss_size
);
5484 if (get
->expr_type
!= EXPR_VARIABLE
5485 || !get
->symtree
->n
.sym
->attr
.optional
)
5488 where
= &get
->where
;
5491 if (!array_check (get
, 2))
5494 if (!rank_check (get
, 2, 1))
5497 if (!type_check (get
, 2, BT_INTEGER
))
5500 if (!variable_check (get
, 2, false))
5503 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5506 if (gfc_array_size (get
, &get_size
)
5507 && mpz_get_ui (get_size
) < kiss_size
)
5508 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5509 "too small (%i/%i)",
5510 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5511 where
, (int) mpz_get_ui (get_size
), kiss_size
);
5514 /* RANDOM_SEED may not have more than one non-optional argument. */
5516 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5523 gfc_check_second_sub (gfc_expr
*time
)
5525 if (!scalar_check (time
, 0))
5528 if (!type_check (time
, 0, BT_REAL
))
5531 if (!kind_value_check (time
, 0, 4))
5538 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5539 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5540 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5541 count_max are all optional arguments */
5544 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5545 gfc_expr
*count_max
)
5549 if (!scalar_check (count
, 0))
5552 if (!type_check (count
, 0, BT_INTEGER
))
5555 if (count
->ts
.kind
!= gfc_default_integer_kind
5556 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5557 "SYSTEM_CLOCK at %L has non-default kind",
5561 if (!variable_check (count
, 0, false))
5565 if (count_rate
!= NULL
)
5567 if (!scalar_check (count_rate
, 1))
5570 if (!variable_check (count_rate
, 1, false))
5573 if (count_rate
->ts
.type
== BT_REAL
)
5575 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5576 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5581 if (!type_check (count_rate
, 1, BT_INTEGER
))
5584 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5585 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5586 "SYSTEM_CLOCK at %L has non-default kind",
5587 &count_rate
->where
))
5593 if (count_max
!= NULL
)
5595 if (!scalar_check (count_max
, 2))
5598 if (!type_check (count_max
, 2, BT_INTEGER
))
5601 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5602 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5603 "SYSTEM_CLOCK at %L has non-default kind",
5607 if (!variable_check (count_max
, 2, false))
5616 gfc_check_irand (gfc_expr
*x
)
5621 if (!scalar_check (x
, 0))
5624 if (!type_check (x
, 0, BT_INTEGER
))
5627 if (!kind_value_check (x
, 0, 4))
5635 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5637 if (!scalar_check (seconds
, 0))
5639 if (!type_check (seconds
, 0, BT_INTEGER
))
5642 if (!int_or_proc_check (handler
, 1))
5644 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5650 if (!scalar_check (status
, 2))
5652 if (!type_check (status
, 2, BT_INTEGER
))
5654 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5662 gfc_check_rand (gfc_expr
*x
)
5667 if (!scalar_check (x
, 0))
5670 if (!type_check (x
, 0, BT_INTEGER
))
5673 if (!kind_value_check (x
, 0, 4))
5681 gfc_check_srand (gfc_expr
*x
)
5683 if (!scalar_check (x
, 0))
5686 if (!type_check (x
, 0, BT_INTEGER
))
5689 if (!kind_value_check (x
, 0, 4))
5697 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5699 if (!scalar_check (time
, 0))
5701 if (!type_check (time
, 0, BT_INTEGER
))
5704 if (!type_check (result
, 1, BT_CHARACTER
))
5706 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5714 gfc_check_dtime_etime (gfc_expr
*x
)
5716 if (!array_check (x
, 0))
5719 if (!rank_check (x
, 0, 1))
5722 if (!variable_check (x
, 0, false))
5725 if (!type_check (x
, 0, BT_REAL
))
5728 if (!kind_value_check (x
, 0, 4))
5736 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5738 if (!array_check (values
, 0))
5741 if (!rank_check (values
, 0, 1))
5744 if (!variable_check (values
, 0, false))
5747 if (!type_check (values
, 0, BT_REAL
))
5750 if (!kind_value_check (values
, 0, 4))
5753 if (!scalar_check (time
, 1))
5756 if (!type_check (time
, 1, BT_REAL
))
5759 if (!kind_value_check (time
, 1, 4))
5767 gfc_check_fdate_sub (gfc_expr
*date
)
5769 if (!type_check (date
, 0, BT_CHARACTER
))
5771 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5779 gfc_check_gerror (gfc_expr
*msg
)
5781 if (!type_check (msg
, 0, BT_CHARACTER
))
5783 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5791 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
5793 if (!type_check (cwd
, 0, BT_CHARACTER
))
5795 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
5801 if (!scalar_check (status
, 1))
5804 if (!type_check (status
, 1, BT_INTEGER
))
5812 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
5814 if (!type_check (pos
, 0, BT_INTEGER
))
5817 if (pos
->ts
.kind
> gfc_default_integer_kind
)
5819 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
5820 "not wider than the default kind (%d)",
5821 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5822 &pos
->where
, gfc_default_integer_kind
);
5826 if (!type_check (value
, 1, BT_CHARACTER
))
5828 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
5836 gfc_check_getlog (gfc_expr
*msg
)
5838 if (!type_check (msg
, 0, BT_CHARACTER
))
5840 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
5848 gfc_check_exit (gfc_expr
*status
)
5853 if (!type_check (status
, 0, BT_INTEGER
))
5856 if (!scalar_check (status
, 0))
5864 gfc_check_flush (gfc_expr
*unit
)
5869 if (!type_check (unit
, 0, BT_INTEGER
))
5872 if (!scalar_check (unit
, 0))
5880 gfc_check_free (gfc_expr
*i
)
5882 if (!type_check (i
, 0, BT_INTEGER
))
5885 if (!scalar_check (i
, 0))
5893 gfc_check_hostnm (gfc_expr
*name
)
5895 if (!type_check (name
, 0, BT_CHARACTER
))
5897 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5905 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
5907 if (!type_check (name
, 0, BT_CHARACTER
))
5909 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5915 if (!scalar_check (status
, 1))
5918 if (!type_check (status
, 1, BT_INTEGER
))
5926 gfc_check_itime_idate (gfc_expr
*values
)
5928 if (!array_check (values
, 0))
5931 if (!rank_check (values
, 0, 1))
5934 if (!variable_check (values
, 0, false))
5937 if (!type_check (values
, 0, BT_INTEGER
))
5940 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
5948 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
5950 if (!type_check (time
, 0, BT_INTEGER
))
5953 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
5956 if (!scalar_check (time
, 0))
5959 if (!array_check (values
, 1))
5962 if (!rank_check (values
, 1, 1))
5965 if (!variable_check (values
, 1, false))
5968 if (!type_check (values
, 1, BT_INTEGER
))
5971 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
5979 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
5981 if (!scalar_check (unit
, 0))
5984 if (!type_check (unit
, 0, BT_INTEGER
))
5987 if (!type_check (name
, 1, BT_CHARACTER
))
5989 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
5997 gfc_check_isatty (gfc_expr
*unit
)
6002 if (!type_check (unit
, 0, BT_INTEGER
))
6005 if (!scalar_check (unit
, 0))
6013 gfc_check_isnan (gfc_expr
*x
)
6015 if (!type_check (x
, 0, BT_REAL
))
6023 gfc_check_perror (gfc_expr
*string
)
6025 if (!type_check (string
, 0, BT_CHARACTER
))
6027 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6035 gfc_check_umask (gfc_expr
*mask
)
6037 if (!type_check (mask
, 0, BT_INTEGER
))
6040 if (!scalar_check (mask
, 0))
6048 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6050 if (!type_check (mask
, 0, BT_INTEGER
))
6053 if (!scalar_check (mask
, 0))
6059 if (!scalar_check (old
, 1))
6062 if (!type_check (old
, 1, BT_INTEGER
))
6070 gfc_check_unlink (gfc_expr
*name
)
6072 if (!type_check (name
, 0, BT_CHARACTER
))
6074 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6082 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6084 if (!type_check (name
, 0, BT_CHARACTER
))
6086 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6092 if (!scalar_check (status
, 1))
6095 if (!type_check (status
, 1, BT_INTEGER
))
6103 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6105 if (!scalar_check (number
, 0))
6107 if (!type_check (number
, 0, BT_INTEGER
))
6110 if (!int_or_proc_check (handler
, 1))
6112 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6120 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6122 if (!scalar_check (number
, 0))
6124 if (!type_check (number
, 0, BT_INTEGER
))
6127 if (!int_or_proc_check (handler
, 1))
6129 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6135 if (!type_check (status
, 2, BT_INTEGER
))
6137 if (!scalar_check (status
, 2))
6145 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6147 if (!type_check (cmd
, 0, BT_CHARACTER
))
6149 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6152 if (!scalar_check (status
, 1))
6155 if (!type_check (status
, 1, BT_INTEGER
))
6158 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6165 /* This is used for the GNU intrinsics AND, OR and XOR. */
6167 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6169 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6171 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
6172 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6173 gfc_current_intrinsic
, &i
->where
);
6177 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6179 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
6180 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6181 gfc_current_intrinsic
, &j
->where
);
6185 if (i
->ts
.type
!= j
->ts
.type
)
6187 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
6188 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6189 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6194 if (!scalar_check (i
, 0))
6197 if (!scalar_check (j
, 1))
6205 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6207 if (a
->ts
.type
== BT_ASSUMED
)
6209 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
6210 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6215 if (a
->ts
.type
== BT_PROCEDURE
)
6217 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
6218 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6219 gfc_current_intrinsic
, &a
->where
);
6226 if (!type_check (kind
, 1, BT_INTEGER
))
6229 if (!scalar_check (kind
, 1))
6232 if (kind
->expr_type
!= EXPR_CONSTANT
)
6234 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
6235 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,