2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 /* Users sometime use a subroutine designator as an actual argument to
76 an intrinsic subprogram that expects an argument with a numeric type. */
77 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
80 if (gfc_numeric_ts (&e
->ts
))
83 /* If the expression has not got a type, check if its namespace can
84 offer a default type. */
85 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
86 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
87 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
88 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
90 e
->ts
= e
->symtree
->n
.sym
->ts
;
96 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
97 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
104 /* Check that an expression is integer or real. */
107 int_or_real_check (gfc_expr
*e
, int n
)
109 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
111 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
112 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
113 gfc_current_intrinsic
, &e
->where
);
121 /* Check that an expression is real or complex. */
124 real_or_complex_check (gfc_expr
*e
, int n
)
126 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
128 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
129 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
130 gfc_current_intrinsic
, &e
->where
);
138 /* Check that an expression is INTEGER or PROCEDURE. */
141 int_or_proc_check (gfc_expr
*e
, int n
)
143 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
145 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
146 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
147 gfc_current_intrinsic
, &e
->where
);
155 /* Check that the expression is an optional constant integer
156 and that it specifies a valid kind for that type. */
159 kind_check (gfc_expr
*k
, int n
, bt type
)
166 if (!type_check (k
, n
, BT_INTEGER
))
169 if (!scalar_check (k
, n
))
172 if (!gfc_check_init_expr (k
))
174 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
175 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
180 if (gfc_extract_int (k
, &kind
)
181 || gfc_validate_kind (type
, kind
, true) < 0)
183 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
192 /* Make sure the expression is a double precision real. */
195 double_check (gfc_expr
*d
, int n
)
197 if (!type_check (d
, n
, BT_REAL
))
200 if (d
->ts
.kind
!= gfc_default_double_kind
)
202 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
203 "precision", gfc_current_intrinsic_arg
[n
]->name
,
204 gfc_current_intrinsic
, &d
->where
);
213 coarray_check (gfc_expr
*e
, int n
)
215 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
216 && CLASS_DATA (e
)->attr
.codimension
217 && CLASS_DATA (e
)->as
->corank
)
219 gfc_add_class_array_ref (e
);
223 if (!gfc_is_coarray (e
))
225 gfc_error ("Expected coarray variable as %qs argument to the %s "
226 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
227 gfc_current_intrinsic
, &e
->where
);
235 /* Make sure the expression is a logical array. */
238 logical_array_check (gfc_expr
*array
, int n
)
240 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
242 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
243 "array", gfc_current_intrinsic_arg
[n
]->name
,
244 gfc_current_intrinsic
, &array
->where
);
252 /* Make sure an expression is an array. */
255 array_check (gfc_expr
*e
, int n
)
257 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
258 && CLASS_DATA (e
)->attr
.dimension
259 && CLASS_DATA (e
)->as
->rank
)
261 gfc_add_class_array_ref (e
);
265 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
268 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
269 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
276 /* If expr is a constant, then check to ensure that it is greater than
280 nonnegative_check (const char *arg
, gfc_expr
*expr
)
284 if (expr
->expr_type
== EXPR_CONSTANT
)
286 gfc_extract_int (expr
, &i
);
289 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
298 /* If expr is a constant, then check to ensure that it is greater than zero. */
301 positive_check (int n
, gfc_expr
*expr
)
305 if (expr
->expr_type
== EXPR_CONSTANT
)
307 gfc_extract_int (expr
, &i
);
310 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
311 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
321 /* If expr2 is constant, then check that the value is less than
322 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
325 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
326 gfc_expr
*expr2
, bool or_equal
)
330 if (expr2
->expr_type
== EXPR_CONSTANT
)
332 gfc_extract_int (expr2
, &i2
);
333 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
335 /* For ISHFT[C], check that |shift| <= bit_size(i). */
341 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
343 gfc_error ("The absolute value of SHIFT at %L must be less "
344 "than or equal to BIT_SIZE(%qs)",
345 &expr2
->where
, arg1
);
352 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
354 gfc_error ("%qs at %L must be less than "
355 "or equal to BIT_SIZE(%qs)",
356 arg2
, &expr2
->where
, arg1
);
362 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
364 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
365 arg2
, &expr2
->where
, arg1
);
375 /* If expr is constant, then check that the value is less than or equal
376 to the bit_size of the kind k. */
379 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
383 if (expr
->expr_type
!= EXPR_CONSTANT
)
386 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
387 gfc_extract_int (expr
, &val
);
389 if (val
> gfc_integer_kinds
[i
].bit_size
)
391 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
392 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
400 /* If expr2 and expr3 are constants, then check that the value is less than
401 or equal to bit_size(expr1). */
404 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
405 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
409 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
411 gfc_extract_int (expr2
, &i2
);
412 gfc_extract_int (expr3
, &i3
);
414 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
415 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
417 gfc_error ("%<%s + %s%> at %L must be less than or equal "
419 arg2
, arg3
, &expr2
->where
, arg1
);
427 /* Make sure two expressions have the same type. */
430 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
, bool assoc
= false)
432 gfc_typespec
*ets
= &e
->ts
;
433 gfc_typespec
*fts
= &f
->ts
;
437 /* Procedure pointer component expressions have the type of the interface
438 procedure. If they are being tested for association with a procedure
439 pointer (ie. not a component), the type of the procedure must be
441 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
442 ets
= &e
->symtree
->n
.sym
->ts
;
443 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
444 fts
= &f
->symtree
->n
.sym
->ts
;
447 if (gfc_compare_types (ets
, fts
))
450 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
451 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
452 gfc_current_intrinsic
, &f
->where
,
453 gfc_current_intrinsic_arg
[n
]->name
);
459 /* Make sure that an expression has a certain (nonzero) rank. */
462 rank_check (gfc_expr
*e
, int n
, int rank
)
467 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
468 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
475 /* Make sure a variable expression is not an optional dummy argument. */
478 nonoptional_check (gfc_expr
*e
, int n
)
480 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
482 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
483 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
487 /* TODO: Recursive check on nonoptional variables? */
493 /* Check for ALLOCATABLE attribute. */
496 allocatable_check (gfc_expr
*e
, int n
)
498 symbol_attribute attr
;
500 attr
= gfc_variable_attr (e
, NULL
);
501 if (!attr
.allocatable
|| attr
.associate_var
)
503 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
504 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
513 /* Check that an expression has a particular kind. */
516 kind_value_check (gfc_expr
*e
, int n
, int k
)
521 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
522 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
529 /* Make sure an expression is a variable. */
532 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
534 if (e
->expr_type
== EXPR_VARIABLE
535 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
536 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
537 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
540 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
541 && CLASS_DATA (e
->symtree
->n
.sym
)
542 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
543 : e
->symtree
->n
.sym
->attr
.pointer
;
545 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
547 if (pointer
&& ref
->type
== REF_COMPONENT
)
549 if (ref
->type
== REF_COMPONENT
550 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
551 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
552 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
553 && ref
->u
.c
.component
->attr
.pointer
)))
559 gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
560 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
561 gfc_current_intrinsic
, &e
->where
);
566 if (e
->expr_type
== EXPR_VARIABLE
567 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
568 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
571 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
572 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
575 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
576 if (ns
->proc_name
== e
->symtree
->n
.sym
)
580 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
581 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
587 /* Check the common DIM parameter for correctness. */
590 dim_check (gfc_expr
*dim
, int n
, bool optional
)
595 if (!type_check (dim
, n
, BT_INTEGER
))
598 if (!scalar_check (dim
, n
))
601 if (!optional
&& !nonoptional_check (dim
, n
))
608 /* If a coarray DIM parameter is a constant, make sure that it is greater than
609 zero and less than or equal to the corank of the given array. */
612 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
616 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
618 if (dim
->expr_type
!= EXPR_CONSTANT
)
621 if (array
->ts
.type
== BT_CLASS
)
624 corank
= gfc_get_corank (array
);
626 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
627 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
629 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
630 "codimension index", gfc_current_intrinsic
, &dim
->where
);
639 /* If a DIM parameter is a constant, make sure that it is greater than
640 zero and less than or equal to the rank of the given array. If
641 allow_assumed is zero then dim must be less than the rank of the array
642 for assumed size arrays. */
645 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
653 if (dim
->expr_type
!= EXPR_CONSTANT
)
656 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
657 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
658 rank
= array
->rank
+ 1;
662 /* Assumed-rank array. */
664 rank
= GFC_MAX_DIMENSIONS
;
666 if (array
->expr_type
== EXPR_VARIABLE
)
668 ar
= gfc_find_array_ref (array
);
669 if (ar
->as
->type
== AS_ASSUMED_SIZE
671 && ar
->type
!= AR_ELEMENT
672 && ar
->type
!= AR_SECTION
)
676 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
677 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
679 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
680 "dimension index", gfc_current_intrinsic
, &dim
->where
);
689 /* Compare the size of a along dimension ai with the size of b along
690 dimension bi, returning 0 if they are known not to be identical,
691 and 1 if they are identical, or if this cannot be determined. */
694 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
696 mpz_t a_size
, b_size
;
699 gcc_assert (a
->rank
> ai
);
700 gcc_assert (b
->rank
> bi
);
704 if (gfc_array_dimen_size (a
, ai
, &a_size
))
706 if (gfc_array_dimen_size (b
, bi
, &b_size
))
708 if (mpz_cmp (a_size
, b_size
) != 0)
718 /* Calculate the length of a character variable, including substrings.
719 Strip away parentheses if necessary. Return -1 if no length could
723 gfc_var_strlen (const gfc_expr
*a
)
727 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
730 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
740 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
741 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
743 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
745 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
746 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
748 else if (ra
->u
.ss
.start
749 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
755 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
756 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
757 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
758 else if (a
->expr_type
== EXPR_CONSTANT
759 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
760 return a
->value
.character
.length
;
766 /* Check whether two character expressions have the same length;
767 returns true if they have or if the length cannot be determined,
768 otherwise return false and raise a gfc_error. */
771 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
775 len_a
= gfc_var_strlen(a
);
776 len_b
= gfc_var_strlen(b
);
778 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
782 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
783 len_a
, len_b
, name
, &a
->where
);
789 /***** Check functions *****/
791 /* Check subroutine suitable for intrinsics taking a real argument and
792 a kind argument for the result. */
795 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
797 if (!type_check (a
, 0, BT_REAL
))
799 if (!kind_check (kind
, 1, type
))
806 /* Check subroutine suitable for ceiling, floor and nint. */
809 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
811 return check_a_kind (a
, kind
, BT_INTEGER
);
815 /* Check subroutine suitable for aint, anint. */
818 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
820 return check_a_kind (a
, kind
, BT_REAL
);
825 gfc_check_abs (gfc_expr
*a
)
827 if (!numeric_check (a
, 0))
835 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
837 if (!type_check (a
, 0, BT_INTEGER
))
839 if (!kind_check (kind
, 1, BT_CHARACTER
))
847 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
849 if (!type_check (name
, 0, BT_CHARACTER
)
850 || !scalar_check (name
, 0))
852 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
855 if (!type_check (mode
, 1, BT_CHARACTER
)
856 || !scalar_check (mode
, 1))
858 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
866 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
868 if (!logical_array_check (mask
, 0))
871 if (!dim_check (dim
, 1, false))
874 if (!dim_rank_check (dim
, mask
, 0))
882 gfc_check_allocated (gfc_expr
*array
)
884 /* Tests on allocated components of coarrays need to detour the check to
885 argument of the _caf_get. */
886 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
887 && array
->value
.function
.isym
888 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
890 array
= array
->value
.function
.actual
->expr
;
895 if (!variable_check (array
, 0, false))
897 if (!allocatable_check (array
, 0))
904 /* Common check function where the first argument must be real or
905 integer and the second argument must be the same as the first. */
908 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
910 if (!int_or_real_check (a
, 0))
913 if (a
->ts
.type
!= p
->ts
.type
)
915 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
916 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
917 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
922 if (a
->ts
.kind
!= p
->ts
.kind
)
924 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
934 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
936 if (!double_check (x
, 0) || !double_check (y
, 1))
944 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
946 symbol_attribute attr1
, attr2
;
951 where
= &pointer
->where
;
953 if (pointer
->expr_type
== EXPR_NULL
)
956 attr1
= gfc_expr_attr (pointer
);
958 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
960 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
961 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
967 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
969 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
970 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
971 gfc_current_intrinsic
, &pointer
->where
);
975 /* Target argument is optional. */
979 where
= &target
->where
;
980 if (target
->expr_type
== EXPR_NULL
)
983 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
984 attr2
= gfc_expr_attr (target
);
987 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
988 "or target VARIABLE or FUNCTION",
989 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
994 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
996 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
997 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
998 gfc_current_intrinsic
, &target
->where
);
1003 if (attr1
.pointer
&& gfc_is_coindexed (target
))
1005 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1006 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1007 gfc_current_intrinsic
, &target
->where
);
1012 if (!same_type_check (pointer
, 0, target
, 1, true))
1014 if (!rank_check (target
, 0, pointer
->rank
))
1016 if (target
->rank
> 0)
1018 for (i
= 0; i
< target
->rank
; i
++)
1019 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1021 gfc_error ("Array section with a vector subscript at %L shall not "
1022 "be the target of a pointer",
1032 gfc_error ("NULL pointer at %L is not permitted as actual argument "
1033 "of %qs intrinsic function", where
, gfc_current_intrinsic
);
1040 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1042 /* gfc_notify_std would be a waste of time as the return value
1043 is seemingly used only for the generic resolution. The error
1044 will be: Too many arguments. */
1045 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1048 return gfc_check_atan2 (y
, x
);
1053 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1055 if (!type_check (y
, 0, BT_REAL
))
1057 if (!same_type_check (y
, 0, x
, 1))
1065 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1066 gfc_expr
*stat
, int stat_no
)
1068 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1071 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1072 && !(atom
->ts
.type
== BT_LOGICAL
1073 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1075 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1076 "integer of ATOMIC_INT_KIND or a logical of "
1077 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1081 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1083 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1084 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1088 if (atom
->ts
.type
!= value
->ts
.type
)
1090 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1091 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1092 gfc_current_intrinsic
, &value
->where
,
1093 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1099 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1101 if (!scalar_check (stat
, stat_no
))
1103 if (!variable_check (stat
, stat_no
, false))
1105 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1108 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1109 gfc_current_intrinsic
, &stat
->where
))
1118 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1120 if (atom
->expr_type
== EXPR_FUNCTION
1121 && atom
->value
.function
.isym
1122 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1123 atom
= atom
->value
.function
.actual
->expr
;
1125 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1127 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1128 "definable", gfc_current_intrinsic
, &atom
->where
);
1132 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1137 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1139 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1141 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1142 "integer of ATOMIC_INT_KIND", &atom
->where
,
1143 gfc_current_intrinsic
);
1147 return gfc_check_atomic_def (atom
, value
, stat
);
1152 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1154 if (atom
->expr_type
== EXPR_FUNCTION
1155 && atom
->value
.function
.isym
1156 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1157 atom
= atom
->value
.function
.actual
->expr
;
1159 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1161 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1162 "definable", gfc_current_intrinsic
, &value
->where
);
1166 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1171 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1173 /* IMAGE has to be a positive, scalar integer. */
1174 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1175 || !positive_check (0, image
))
1180 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1181 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1190 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1194 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1195 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1204 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1205 || !positive_check (1, kind
))
1208 /* Get the kind, reporting error on non-constant or overflow. */
1209 gfc_current_locus
= kind
->where
;
1210 if (gfc_extract_int (kind
, &k
, 1))
1212 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1214 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1215 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1216 gfc_current_intrinsic
, &kind
->where
);
1225 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1226 gfc_expr
*new_val
, gfc_expr
*stat
)
1228 if (atom
->expr_type
== EXPR_FUNCTION
1229 && atom
->value
.function
.isym
1230 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1231 atom
= atom
->value
.function
.actual
->expr
;
1233 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1236 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1239 if (!same_type_check (atom
, 0, old
, 1))
1242 if (!same_type_check (atom
, 0, compare
, 2))
1245 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1247 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1248 "definable", gfc_current_intrinsic
, &atom
->where
);
1252 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1254 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1255 "definable", gfc_current_intrinsic
, &old
->where
);
1263 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1265 if (event
->ts
.type
!= BT_DERIVED
1266 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1267 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1269 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1270 "shall be of type EVENT_TYPE", &event
->where
);
1274 if (!scalar_check (event
, 0))
1277 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1279 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1280 "shall be definable", &count
->where
);
1284 if (!type_check (count
, 1, BT_INTEGER
))
1287 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1288 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1290 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1292 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1293 "shall have at least the range of the default integer",
1300 if (!type_check (stat
, 2, BT_INTEGER
))
1302 if (!scalar_check (stat
, 2))
1304 if (!variable_check (stat
, 2, false))
1307 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1308 gfc_current_intrinsic
, &stat
->where
))
1317 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1320 if (atom
->expr_type
== EXPR_FUNCTION
1321 && atom
->value
.function
.isym
1322 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1323 atom
= atom
->value
.function
.actual
->expr
;
1325 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1327 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1328 "integer of ATOMIC_INT_KIND", &atom
->where
,
1329 gfc_current_intrinsic
);
1333 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1336 if (!scalar_check (old
, 2))
1339 if (!same_type_check (atom
, 0, old
, 2))
1342 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1344 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1345 "definable", gfc_current_intrinsic
, &atom
->where
);
1349 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1351 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1352 "definable", gfc_current_intrinsic
, &old
->where
);
1360 /* BESJN and BESYN functions. */
1363 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1365 if (!type_check (n
, 0, BT_INTEGER
))
1367 if (n
->expr_type
== EXPR_CONSTANT
)
1370 gfc_extract_int (n
, &i
);
1371 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1372 "N at %L", &n
->where
))
1376 if (!type_check (x
, 1, BT_REAL
))
1383 /* Transformational version of the Bessel JN and YN functions. */
1386 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1388 if (!type_check (n1
, 0, BT_INTEGER
))
1390 if (!scalar_check (n1
, 0))
1392 if (!nonnegative_check ("N1", n1
))
1395 if (!type_check (n2
, 1, BT_INTEGER
))
1397 if (!scalar_check (n2
, 1))
1399 if (!nonnegative_check ("N2", n2
))
1402 if (!type_check (x
, 2, BT_REAL
))
1404 if (!scalar_check (x
, 2))
1412 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1414 if (!type_check (i
, 0, BT_INTEGER
))
1417 if (!type_check (j
, 1, BT_INTEGER
))
1425 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1427 if (!type_check (i
, 0, BT_INTEGER
))
1430 if (!type_check (pos
, 1, BT_INTEGER
))
1433 if (!nonnegative_check ("pos", pos
))
1436 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1444 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1446 if (!type_check (i
, 0, BT_INTEGER
))
1448 if (!kind_check (kind
, 1, BT_CHARACTER
))
1456 gfc_check_chdir (gfc_expr
*dir
)
1458 if (!type_check (dir
, 0, BT_CHARACTER
))
1460 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1468 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1470 if (!type_check (dir
, 0, BT_CHARACTER
))
1472 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1478 if (!type_check (status
, 1, BT_INTEGER
))
1480 if (!scalar_check (status
, 1))
1488 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1490 if (!type_check (name
, 0, BT_CHARACTER
))
1492 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1495 if (!type_check (mode
, 1, BT_CHARACTER
))
1497 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1505 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1507 if (!type_check (name
, 0, BT_CHARACTER
))
1509 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1512 if (!type_check (mode
, 1, BT_CHARACTER
))
1514 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1520 if (!type_check (status
, 2, BT_INTEGER
))
1523 if (!scalar_check (status
, 2))
1531 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1533 if (!numeric_check (x
, 0))
1538 if (!numeric_check (y
, 1))
1541 if (x
->ts
.type
== BT_COMPLEX
)
1543 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1544 "present if %<x%> is COMPLEX",
1545 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1550 if (y
->ts
.type
== BT_COMPLEX
)
1552 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1553 "of either REAL or INTEGER",
1554 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1561 if (!kind_check (kind
, 2, BT_COMPLEX
))
1564 if (!kind
&& warn_conversion
1565 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1566 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1567 "COMPLEX(%d) at %L might lose precision, consider using "
1568 "the KIND argument", gfc_typename (&x
->ts
),
1569 gfc_default_real_kind
, &x
->where
);
1570 else if (y
&& !kind
&& warn_conversion
1571 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1572 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1573 "COMPLEX(%d) at %L might lose precision, consider using "
1574 "the KIND argument", gfc_typename (&y
->ts
),
1575 gfc_default_real_kind
, &y
->where
);
1581 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1582 gfc_expr
*errmsg
, bool co_reduce
)
1584 if (!variable_check (a
, 0, false))
1587 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1591 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1592 if (gfc_has_vector_subscript (a
))
1594 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1595 "subroutine %s shall not have a vector subscript",
1596 &a
->where
, gfc_current_intrinsic
);
1600 if (gfc_is_coindexed (a
))
1602 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1603 "coindexed", &a
->where
, gfc_current_intrinsic
);
1607 if (image_idx
!= NULL
)
1609 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1611 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1617 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1619 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1621 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1623 if (stat
->ts
.kind
!= 4)
1625 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1626 "variable", &stat
->where
);
1633 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1635 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1637 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1639 if (errmsg
->ts
.kind
!= 1)
1641 gfc_error ("The errmsg= argument at %L must be a default-kind "
1642 "character variable", &errmsg
->where
);
1647 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1649 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1659 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1662 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1664 gfc_error ("Support for the A argument at %L which is polymorphic A "
1665 "argument or has allocatable components is not yet "
1666 "implemented", &a
->where
);
1669 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1674 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1675 gfc_expr
*stat
, gfc_expr
*errmsg
)
1677 symbol_attribute attr
;
1678 gfc_formal_arglist
*formal
;
1681 if (a
->ts
.type
== BT_CLASS
)
1683 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1688 if (gfc_expr_attr (a
).alloc_comp
)
1690 gfc_error ("Support for the A argument at %L with allocatable components"
1691 " is not yet implemented", &a
->where
);
1695 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1698 if (!gfc_resolve_expr (op
))
1701 attr
= gfc_expr_attr (op
);
1702 if (!attr
.pure
|| !attr
.function
)
1704 gfc_error ("OPERATOR argument at %L must be a PURE function",
1711 /* None of the intrinsics fulfills the criteria of taking two arguments,
1712 returning the same type and kind as the arguments and being permitted
1713 as actual argument. */
1714 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1715 op
->symtree
->n
.sym
->name
, &op
->where
);
1719 if (gfc_is_proc_ptr_comp (op
))
1721 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1722 sym
= comp
->ts
.interface
;
1725 sym
= op
->symtree
->n
.sym
;
1727 formal
= sym
->formal
;
1729 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1731 gfc_error ("The function passed as OPERATOR at %L shall have two "
1732 "arguments", &op
->where
);
1736 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1737 gfc_set_default_type (sym
->result
, 0, NULL
);
1739 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1741 gfc_error ("The A argument at %L has type %s but the function passed as "
1742 "OPERATOR at %L returns %s",
1743 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1744 gfc_typename (&sym
->result
->ts
));
1747 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1748 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1750 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1751 "%s and %s but shall have type %s", &op
->where
,
1752 gfc_typename (&formal
->sym
->ts
),
1753 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1756 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1757 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1758 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1759 || formal
->next
->sym
->attr
.pointer
)
1761 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1762 "nonallocatable nonpointer arguments and return a "
1763 "nonallocatable nonpointer scalar", &op
->where
);
1767 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1769 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1770 "attribute either for none or both arguments", &op
->where
);
1774 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1776 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1777 "attribute either for none or both arguments", &op
->where
);
1781 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1783 gfc_error ("The function passed as OPERATOR at %L shall have the "
1784 "ASYNCHRONOUS attribute either for none or both arguments",
1789 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1791 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1792 "OPTIONAL attribute for either of the arguments", &op
->where
);
1796 if (a
->ts
.type
== BT_CHARACTER
)
1799 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1802 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1803 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1805 cl
= formal
->sym
->ts
.u
.cl
;
1806 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1807 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1809 cl
= formal
->next
->sym
->ts
.u
.cl
;
1810 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1811 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1814 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1815 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1818 && ((formal_size1
&& actual_size
!= formal_size1
)
1819 || (formal_size2
&& actual_size
!= formal_size2
)))
1821 gfc_error ("The character length of the A argument at %L and of the "
1822 "arguments of the OPERATOR at %L shall be the same",
1823 &a
->where
, &op
->where
);
1826 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1828 gfc_error ("The character length of the A argument at %L and of the "
1829 "function result of the OPERATOR at %L shall be the same",
1830 &a
->where
, &op
->where
);
1840 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1843 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1844 && a
->ts
.type
!= BT_CHARACTER
)
1846 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1847 "integer, real or character",
1848 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1852 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1857 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1860 if (!numeric_check (a
, 0))
1862 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1867 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1869 if (!int_or_real_check (x
, 0))
1871 if (!scalar_check (x
, 0))
1874 if (!int_or_real_check (y
, 1))
1876 if (!scalar_check (y
, 1))
1884 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1886 if (!logical_array_check (mask
, 0))
1888 if (!dim_check (dim
, 1, false))
1890 if (!dim_rank_check (dim
, mask
, 0))
1892 if (!kind_check (kind
, 2, BT_INTEGER
))
1894 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1895 "with KIND argument at %L",
1896 gfc_current_intrinsic
, &kind
->where
))
1904 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1906 if (!array_check (array
, 0))
1909 if (!type_check (shift
, 1, BT_INTEGER
))
1912 if (!dim_check (dim
, 2, true))
1915 if (!dim_rank_check (dim
, array
, false))
1918 if (array
->rank
== 1 || shift
->rank
== 0)
1920 if (!scalar_check (shift
, 1))
1923 else if (shift
->rank
== array
->rank
- 1)
1928 else if (dim
->expr_type
== EXPR_CONSTANT
)
1929 gfc_extract_int (dim
, &d
);
1936 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1939 if (!identical_dimen_shape (array
, i
, shift
, j
))
1941 gfc_error ("%qs argument of %qs intrinsic at %L has "
1942 "invalid shape in dimension %d (%ld/%ld)",
1943 gfc_current_intrinsic_arg
[1]->name
,
1944 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1945 mpz_get_si (array
->shape
[i
]),
1946 mpz_get_si (shift
->shape
[j
]));
1956 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
1957 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1958 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1967 gfc_check_ctime (gfc_expr
*time
)
1969 if (!scalar_check (time
, 0))
1972 if (!type_check (time
, 0, BT_INTEGER
))
1979 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1981 if (!double_check (y
, 0) || !double_check (x
, 1))
1988 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1990 if (!numeric_check (x
, 0))
1995 if (!numeric_check (y
, 1))
1998 if (x
->ts
.type
== BT_COMPLEX
)
2000 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2001 "present if %<x%> is COMPLEX",
2002 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2007 if (y
->ts
.type
== BT_COMPLEX
)
2009 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2010 "of either REAL or INTEGER",
2011 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2022 gfc_check_dble (gfc_expr
*x
)
2024 if (!numeric_check (x
, 0))
2032 gfc_check_digits (gfc_expr
*x
)
2034 if (!int_or_real_check (x
, 0))
2042 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2044 switch (vector_a
->ts
.type
)
2047 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2054 if (!numeric_check (vector_b
, 1))
2059 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2060 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2061 gfc_current_intrinsic
, &vector_a
->where
);
2065 if (!rank_check (vector_a
, 0, 1))
2068 if (!rank_check (vector_b
, 1, 1))
2071 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2073 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2074 "intrinsic %<dot_product%>",
2075 gfc_current_intrinsic_arg
[0]->name
,
2076 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2085 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2087 if (!type_check (x
, 0, BT_REAL
)
2088 || !type_check (y
, 1, BT_REAL
))
2091 if (x
->ts
.kind
!= gfc_default_real_kind
)
2093 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2094 "real", gfc_current_intrinsic_arg
[0]->name
,
2095 gfc_current_intrinsic
, &x
->where
);
2099 if (y
->ts
.kind
!= gfc_default_real_kind
)
2101 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2102 "real", gfc_current_intrinsic_arg
[1]->name
,
2103 gfc_current_intrinsic
, &y
->where
);
2112 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2114 if (!type_check (i
, 0, BT_INTEGER
))
2117 if (!type_check (j
, 1, BT_INTEGER
))
2120 if (i
->is_boz
&& j
->is_boz
)
2122 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2123 "constants", &i
->where
, &j
->where
);
2127 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
2130 if (!type_check (shift
, 2, BT_INTEGER
))
2133 if (!nonnegative_check ("SHIFT", shift
))
2138 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
2140 i
->ts
.kind
= j
->ts
.kind
;
2144 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2146 j
->ts
.kind
= i
->ts
.kind
;
2154 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2157 if (!array_check (array
, 0))
2160 if (!type_check (shift
, 1, BT_INTEGER
))
2163 if (!dim_check (dim
, 3, true))
2166 if (!dim_rank_check (dim
, array
, false))
2169 if (array
->rank
== 1 || shift
->rank
== 0)
2171 if (!scalar_check (shift
, 1))
2174 else if (shift
->rank
== array
->rank
- 1)
2179 else if (dim
->expr_type
== EXPR_CONSTANT
)
2180 gfc_extract_int (dim
, &d
);
2187 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2190 if (!identical_dimen_shape (array
, i
, shift
, j
))
2192 gfc_error ("%qs argument of %qs intrinsic at %L has "
2193 "invalid shape in dimension %d (%ld/%ld)",
2194 gfc_current_intrinsic_arg
[1]->name
,
2195 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2196 mpz_get_si (array
->shape
[i
]),
2197 mpz_get_si (shift
->shape
[j
]));
2207 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2208 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2209 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2213 if (boundary
!= NULL
)
2215 if (!same_type_check (array
, 0, boundary
, 2))
2218 if (array
->rank
== 1 || boundary
->rank
== 0)
2220 if (!scalar_check (boundary
, 2))
2223 else if (boundary
->rank
== array
->rank
- 1)
2225 if (!gfc_check_conformance (shift
, boundary
,
2226 "arguments '%s' and '%s' for "
2228 gfc_current_intrinsic_arg
[1]->name
,
2229 gfc_current_intrinsic_arg
[2]->name
,
2230 gfc_current_intrinsic
))
2235 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2236 "rank %d or be a scalar",
2237 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2238 &shift
->where
, array
->rank
- 1);
2247 gfc_check_float (gfc_expr
*a
)
2249 if (!type_check (a
, 0, BT_INTEGER
))
2252 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2253 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2254 "kind argument to %s intrinsic at %L",
2255 gfc_current_intrinsic
, &a
->where
))
2261 /* A single complex argument. */
2264 gfc_check_fn_c (gfc_expr
*a
)
2266 if (!type_check (a
, 0, BT_COMPLEX
))
2273 /* A single real argument. */
2276 gfc_check_fn_r (gfc_expr
*a
)
2278 if (!type_check (a
, 0, BT_REAL
))
2284 /* A single double argument. */
2287 gfc_check_fn_d (gfc_expr
*a
)
2289 if (!double_check (a
, 0))
2295 /* A single real or complex argument. */
2298 gfc_check_fn_rc (gfc_expr
*a
)
2300 if (!real_or_complex_check (a
, 0))
2308 gfc_check_fn_rc2008 (gfc_expr
*a
)
2310 if (!real_or_complex_check (a
, 0))
2313 if (a
->ts
.type
== BT_COMPLEX
2314 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2315 "of %qs intrinsic at %L",
2316 gfc_current_intrinsic_arg
[0]->name
,
2317 gfc_current_intrinsic
, &a
->where
))
2325 gfc_check_fnum (gfc_expr
*unit
)
2327 if (!type_check (unit
, 0, BT_INTEGER
))
2330 if (!scalar_check (unit
, 0))
2338 gfc_check_huge (gfc_expr
*x
)
2340 if (!int_or_real_check (x
, 0))
2348 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2350 if (!type_check (x
, 0, BT_REAL
))
2352 if (!same_type_check (x
, 0, y
, 1))
2359 /* Check that the single argument is an integer. */
2362 gfc_check_i (gfc_expr
*i
)
2364 if (!type_check (i
, 0, BT_INTEGER
))
2372 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2374 if (!type_check (i
, 0, BT_INTEGER
))
2377 if (!type_check (j
, 1, BT_INTEGER
))
2380 if (i
->ts
.kind
!= j
->ts
.kind
)
2382 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2392 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2394 if (!type_check (i
, 0, BT_INTEGER
))
2397 if (!type_check (pos
, 1, BT_INTEGER
))
2400 if (!type_check (len
, 2, BT_INTEGER
))
2403 if (!nonnegative_check ("pos", pos
))
2406 if (!nonnegative_check ("len", len
))
2409 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2417 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2421 if (!type_check (c
, 0, BT_CHARACTER
))
2424 if (!kind_check (kind
, 1, BT_INTEGER
))
2427 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2428 "with KIND argument at %L",
2429 gfc_current_intrinsic
, &kind
->where
))
2432 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2438 /* Substring references don't have the charlength set. */
2440 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2443 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2447 /* Check that the argument is length one. Non-constant lengths
2448 can't be checked here, so assume they are ok. */
2449 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2451 /* If we already have a length for this expression then use it. */
2452 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2454 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2461 start
= ref
->u
.ss
.start
;
2462 end
= ref
->u
.ss
.end
;
2465 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2466 || start
->expr_type
!= EXPR_CONSTANT
)
2469 i
= mpz_get_si (end
->value
.integer
) + 1
2470 - mpz_get_si (start
->value
.integer
);
2478 gfc_error ("Argument of %s at %L must be of length one",
2479 gfc_current_intrinsic
, &c
->where
);
2488 gfc_check_idnint (gfc_expr
*a
)
2490 if (!double_check (a
, 0))
2498 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2500 if (!type_check (i
, 0, BT_INTEGER
))
2503 if (!type_check (j
, 1, BT_INTEGER
))
2506 if (i
->ts
.kind
!= j
->ts
.kind
)
2508 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2518 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2521 if (!type_check (string
, 0, BT_CHARACTER
)
2522 || !type_check (substring
, 1, BT_CHARACTER
))
2525 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2528 if (!kind_check (kind
, 3, BT_INTEGER
))
2530 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2531 "with KIND argument at %L",
2532 gfc_current_intrinsic
, &kind
->where
))
2535 if (string
->ts
.kind
!= substring
->ts
.kind
)
2537 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2538 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2539 gfc_current_intrinsic
, &substring
->where
,
2540 gfc_current_intrinsic_arg
[0]->name
);
2549 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2551 if (!numeric_check (x
, 0))
2554 if (!kind_check (kind
, 1, BT_INTEGER
))
2562 gfc_check_intconv (gfc_expr
*x
)
2564 if (!numeric_check (x
, 0))
2572 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2574 if (!type_check (i
, 0, BT_INTEGER
))
2577 if (!type_check (j
, 1, BT_INTEGER
))
2580 if (i
->ts
.kind
!= j
->ts
.kind
)
2582 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2592 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2594 if (!type_check (i
, 0, BT_INTEGER
)
2595 || !type_check (shift
, 1, BT_INTEGER
))
2598 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2606 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2608 if (!type_check (i
, 0, BT_INTEGER
)
2609 || !type_check (shift
, 1, BT_INTEGER
))
2616 if (!type_check (size
, 2, BT_INTEGER
))
2619 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2622 if (size
->expr_type
== EXPR_CONSTANT
)
2624 gfc_extract_int (size
, &i3
);
2627 gfc_error ("SIZE at %L must be positive", &size
->where
);
2631 if (shift
->expr_type
== EXPR_CONSTANT
)
2633 gfc_extract_int (shift
, &i2
);
2639 gfc_error ("The absolute value of SHIFT at %L must be less "
2640 "than or equal to SIZE at %L", &shift
->where
,
2647 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2655 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2657 if (!type_check (pid
, 0, BT_INTEGER
))
2660 if (!type_check (sig
, 1, BT_INTEGER
))
2668 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2670 if (!type_check (pid
, 0, BT_INTEGER
))
2673 if (!scalar_check (pid
, 0))
2676 if (!type_check (sig
, 1, BT_INTEGER
))
2679 if (!scalar_check (sig
, 1))
2685 if (!type_check (status
, 2, BT_INTEGER
))
2688 if (!scalar_check (status
, 2))
2696 gfc_check_kind (gfc_expr
*x
)
2698 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
2700 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2701 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2702 gfc_current_intrinsic
, &x
->where
);
2705 if (x
->ts
.type
== BT_PROCEDURE
)
2707 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2708 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2718 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2720 if (!array_check (array
, 0))
2723 if (!dim_check (dim
, 1, false))
2726 if (!dim_rank_check (dim
, array
, 1))
2729 if (!kind_check (kind
, 2, BT_INTEGER
))
2731 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2732 "with KIND argument at %L",
2733 gfc_current_intrinsic
, &kind
->where
))
2741 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2743 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2745 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2749 if (!coarray_check (coarray
, 0))
2754 if (!dim_check (dim
, 1, false))
2757 if (!dim_corank_check (dim
, coarray
))
2761 if (!kind_check (kind
, 2, BT_INTEGER
))
2769 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2771 if (!type_check (s
, 0, BT_CHARACTER
))
2774 if (!kind_check (kind
, 1, BT_INTEGER
))
2776 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2777 "with KIND argument at %L",
2778 gfc_current_intrinsic
, &kind
->where
))
2786 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2788 if (!type_check (a
, 0, BT_CHARACTER
))
2790 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2793 if (!type_check (b
, 1, BT_CHARACTER
))
2795 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2803 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2805 if (!type_check (path1
, 0, BT_CHARACTER
))
2807 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2810 if (!type_check (path2
, 1, BT_CHARACTER
))
2812 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2820 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2822 if (!type_check (path1
, 0, BT_CHARACTER
))
2824 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2827 if (!type_check (path2
, 1, BT_CHARACTER
))
2829 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2835 if (!type_check (status
, 2, BT_INTEGER
))
2838 if (!scalar_check (status
, 2))
2846 gfc_check_loc (gfc_expr
*expr
)
2848 return variable_check (expr
, 0, true);
2853 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2855 if (!type_check (path1
, 0, BT_CHARACTER
))
2857 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2860 if (!type_check (path2
, 1, BT_CHARACTER
))
2862 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2870 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2872 if (!type_check (path1
, 0, BT_CHARACTER
))
2874 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2877 if (!type_check (path2
, 1, BT_CHARACTER
))
2879 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2885 if (!type_check (status
, 2, BT_INTEGER
))
2888 if (!scalar_check (status
, 2))
2896 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2898 if (!type_check (a
, 0, BT_LOGICAL
))
2900 if (!kind_check (kind
, 1, BT_LOGICAL
))
2907 /* Min/max family. */
2910 min_max_args (gfc_actual_arglist
*args
)
2912 gfc_actual_arglist
*arg
;
2913 int i
, j
, nargs
, *nlabels
, nlabelless
;
2914 bool a1
= false, a2
= false;
2916 if (args
== NULL
|| args
->next
== NULL
)
2918 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
2919 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2926 if (!args
->next
->name
)
2930 for (arg
= args
; arg
; arg
= arg
->next
)
2937 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2939 nlabels
= XALLOCAVEC (int, nargs
);
2940 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2946 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2948 n
= strtol (&arg
->name
[1], &endp
, 10);
2949 if (endp
[0] != '\0')
2953 if (n
<= nlabelless
)
2966 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
2967 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2968 gfc_current_intrinsic_where
);
2972 /* Check for duplicates. */
2973 for (i
= 0; i
< nargs
; i
++)
2974 for (j
= i
+ 1; j
< nargs
; j
++)
2975 if (nlabels
[i
] == nlabels
[j
])
2981 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
2982 &arg
->expr
->where
, gfc_current_intrinsic
);
2986 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
2987 &arg
->expr
->where
, gfc_current_intrinsic
);
2993 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2995 gfc_actual_arglist
*arg
, *tmp
;
2999 if (!min_max_args (arglist
))
3002 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3005 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3007 if (x
->ts
.type
== type
)
3009 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3010 "kinds at %L", &x
->where
))
3015 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3016 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3017 gfc_basic_typename (type
), kind
);
3022 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3023 if (!gfc_check_conformance (tmp
->expr
, x
,
3024 "arguments 'a%d' and 'a%d' for "
3025 "intrinsic '%s'", m
, n
,
3026 gfc_current_intrinsic
))
3035 gfc_check_min_max (gfc_actual_arglist
*arg
)
3039 if (!min_max_args (arg
))
3044 if (x
->ts
.type
== BT_CHARACTER
)
3046 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3047 "with CHARACTER argument at %L",
3048 gfc_current_intrinsic
, &x
->where
))
3051 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3053 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3054 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3058 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3063 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3065 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3070 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3072 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3077 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3079 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3083 /* End of min/max family. */
3086 gfc_check_malloc (gfc_expr
*size
)
3088 if (!type_check (size
, 0, BT_INTEGER
))
3091 if (!scalar_check (size
, 0))
3099 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3101 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3103 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3104 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3105 gfc_current_intrinsic
, &matrix_a
->where
);
3109 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3111 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3112 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3113 gfc_current_intrinsic
, &matrix_b
->where
);
3117 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3118 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3120 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3121 gfc_current_intrinsic
, &matrix_a
->where
,
3122 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3126 switch (matrix_a
->rank
)
3129 if (!rank_check (matrix_b
, 1, 2))
3131 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3132 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3134 gfc_error ("Different shape on dimension 1 for arguments %qs "
3135 "and %qs at %L for intrinsic matmul",
3136 gfc_current_intrinsic_arg
[0]->name
,
3137 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3143 if (matrix_b
->rank
!= 2)
3145 if (!rank_check (matrix_b
, 1, 1))
3148 /* matrix_b has rank 1 or 2 here. Common check for the cases
3149 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3150 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3151 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3153 gfc_error ("Different shape on dimension 2 for argument %qs and "
3154 "dimension 1 for argument %qs at %L for intrinsic "
3155 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3156 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3162 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3163 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3164 gfc_current_intrinsic
, &matrix_a
->where
);
3172 /* Whoever came up with this interface was probably on something.
3173 The possibilities for the occupation of the second and third
3180 NULL MASK minloc(array, mask=m)
3183 I.e. in the case of minloc(array,mask), mask will be in the second
3184 position of the argument list and we'll have to fix that up. */
3187 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3189 gfc_expr
*a
, *m
, *d
, *k
;
3192 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
3196 m
= ap
->next
->next
->expr
;
3197 k
= ap
->next
->next
->next
->expr
;
3199 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3200 && ap
->next
->name
== NULL
)
3204 ap
->next
->expr
= NULL
;
3205 ap
->next
->next
->expr
= m
;
3208 if (!dim_check (d
, 1, false))
3211 if (!dim_rank_check (d
, a
, 0))
3214 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3218 && !gfc_check_conformance (a
, m
,
3219 "arguments '%s' and '%s' for intrinsic %s",
3220 gfc_current_intrinsic_arg
[0]->name
,
3221 gfc_current_intrinsic_arg
[2]->name
,
3222 gfc_current_intrinsic
))
3225 if (!kind_check (k
, 1, BT_INTEGER
))
3232 /* Similar to minloc/maxloc, the argument list might need to be
3233 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3234 difference is that MINLOC/MAXLOC take an additional KIND argument.
3235 The possibilities are:
3241 NULL MASK minval(array, mask=m)
3244 I.e. in the case of minval(array,mask), mask will be in the second
3245 position of the argument list and we'll have to fix that up. */
3248 check_reduction (gfc_actual_arglist
*ap
)
3250 gfc_expr
*a
, *m
, *d
;
3254 m
= ap
->next
->next
->expr
;
3256 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3257 && ap
->next
->name
== NULL
)
3261 ap
->next
->expr
= NULL
;
3262 ap
->next
->next
->expr
= m
;
3265 if (!dim_check (d
, 1, false))
3268 if (!dim_rank_check (d
, a
, 0))
3271 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3275 && !gfc_check_conformance (a
, m
,
3276 "arguments '%s' and '%s' for intrinsic %s",
3277 gfc_current_intrinsic_arg
[0]->name
,
3278 gfc_current_intrinsic_arg
[2]->name
,
3279 gfc_current_intrinsic
))
3287 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3289 if (!int_or_real_check (ap
->expr
, 0)
3290 || !array_check (ap
->expr
, 0))
3293 return check_reduction (ap
);
3298 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3300 if (!numeric_check (ap
->expr
, 0)
3301 || !array_check (ap
->expr
, 0))
3304 return check_reduction (ap
);
3308 /* For IANY, IALL and IPARITY. */
3311 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3315 if (!type_check (i
, 0, BT_INTEGER
))
3318 if (!nonnegative_check ("I", i
))
3321 if (!kind_check (kind
, 1, BT_INTEGER
))
3325 gfc_extract_int (kind
, &k
);
3327 k
= gfc_default_integer_kind
;
3329 if (!less_than_bitsizekind ("I", i
, k
))
3337 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3339 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3341 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3342 gfc_current_intrinsic_arg
[0]->name
,
3343 gfc_current_intrinsic
, &ap
->expr
->where
);
3347 if (!array_check (ap
->expr
, 0))
3350 return check_reduction (ap
);
3355 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3357 if (!same_type_check (tsource
, 0, fsource
, 1))
3360 if (!type_check (mask
, 2, BT_LOGICAL
))
3363 if (tsource
->ts
.type
== BT_CHARACTER
)
3364 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3371 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3373 if (!type_check (i
, 0, BT_INTEGER
))
3376 if (!type_check (j
, 1, BT_INTEGER
))
3379 if (!type_check (mask
, 2, BT_INTEGER
))
3382 if (!same_type_check (i
, 0, j
, 1))
3385 if (!same_type_check (i
, 0, mask
, 2))
3393 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3395 if (!variable_check (from
, 0, false))
3397 if (!allocatable_check (from
, 0))
3399 if (gfc_is_coindexed (from
))
3401 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3402 "coindexed", &from
->where
);
3406 if (!variable_check (to
, 1, false))
3408 if (!allocatable_check (to
, 1))
3410 if (gfc_is_coindexed (to
))
3412 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3413 "coindexed", &to
->where
);
3417 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3419 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3420 "polymorphic if FROM is polymorphic",
3425 if (!same_type_check (to
, 1, from
, 0))
3428 if (to
->rank
!= from
->rank
)
3430 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3431 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3436 /* IR F08/0040; cf. 12-006A. */
3437 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3439 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3440 "must have the same corank %d/%d", &to
->where
,
3441 gfc_get_corank (from
), gfc_get_corank (to
));
3445 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3446 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3447 and cmp2 are allocatable. After the allocation is transferred,
3448 the 'to' chain is broken by the nullification of the 'from'. A bit
3449 of reflection reveals that this can only occur for derived types
3450 with recursive allocatable components. */
3451 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3452 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3454 gfc_ref
*to_ref
, *from_ref
;
3456 from_ref
= from
->ref
;
3457 bool aliasing
= true;
3459 for (; from_ref
&& to_ref
;
3460 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3462 if (to_ref
->type
!= from
->ref
->type
)
3464 else if (to_ref
->type
== REF_ARRAY
3465 && to_ref
->u
.ar
.type
!= AR_FULL
3466 && from_ref
->u
.ar
.type
!= AR_FULL
)
3467 /* Play safe; assume sections and elements are different. */
3469 else if (to_ref
->type
== REF_COMPONENT
3470 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3479 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3480 "restrictions (F2003 12.4.1.7)", &to
->where
);
3485 /* CLASS arguments: Make sure the vtab of from is present. */
3486 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3487 gfc_find_vtab (&from
->ts
);
3494 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3496 if (!type_check (x
, 0, BT_REAL
))
3499 if (!type_check (s
, 1, BT_REAL
))
3502 if (s
->expr_type
== EXPR_CONSTANT
)
3504 if (mpfr_sgn (s
->value
.real
) == 0)
3506 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3517 gfc_check_new_line (gfc_expr
*a
)
3519 if (!type_check (a
, 0, BT_CHARACTER
))
3527 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3529 if (!type_check (array
, 0, BT_REAL
))
3532 if (!array_check (array
, 0))
3535 if (!dim_rank_check (dim
, array
, false))
3542 gfc_check_null (gfc_expr
*mold
)
3544 symbol_attribute attr
;
3549 if (!variable_check (mold
, 0, true))
3552 attr
= gfc_variable_attr (mold
, NULL
);
3554 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3556 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3557 "ALLOCATABLE or procedure pointer",
3558 gfc_current_intrinsic_arg
[0]->name
,
3559 gfc_current_intrinsic
, &mold
->where
);
3563 if (attr
.allocatable
3564 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3565 "allocatable MOLD at %L", &mold
->where
))
3569 if (gfc_is_coindexed (mold
))
3571 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3572 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3573 gfc_current_intrinsic
, &mold
->where
);
3582 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3584 if (!array_check (array
, 0))
3587 if (!type_check (mask
, 1, BT_LOGICAL
))
3590 if (!gfc_check_conformance (array
, mask
,
3591 "arguments '%s' and '%s' for intrinsic '%s'",
3592 gfc_current_intrinsic_arg
[0]->name
,
3593 gfc_current_intrinsic_arg
[1]->name
,
3594 gfc_current_intrinsic
))
3599 mpz_t array_size
, vector_size
;
3600 bool have_array_size
, have_vector_size
;
3602 if (!same_type_check (array
, 0, vector
, 2))
3605 if (!rank_check (vector
, 2, 1))
3608 /* VECTOR requires at least as many elements as MASK
3609 has .TRUE. values. */
3610 have_array_size
= gfc_array_size(array
, &array_size
);
3611 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3613 if (have_vector_size
3614 && (mask
->expr_type
== EXPR_ARRAY
3615 || (mask
->expr_type
== EXPR_CONSTANT
3616 && have_array_size
)))
3618 int mask_true_values
= 0;
3620 if (mask
->expr_type
== EXPR_ARRAY
)
3622 gfc_constructor
*mask_ctor
;
3623 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3626 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3628 mask_true_values
= 0;
3632 if (mask_ctor
->expr
->value
.logical
)
3635 mask_ctor
= gfc_constructor_next (mask_ctor
);
3638 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3639 mask_true_values
= mpz_get_si (array_size
);
3641 if (mpz_get_si (vector_size
) < mask_true_values
)
3643 gfc_error ("%qs argument of %qs intrinsic at %L must "
3644 "provide at least as many elements as there "
3645 "are .TRUE. values in %qs (%ld/%d)",
3646 gfc_current_intrinsic_arg
[2]->name
,
3647 gfc_current_intrinsic
, &vector
->where
,
3648 gfc_current_intrinsic_arg
[1]->name
,
3649 mpz_get_si (vector_size
), mask_true_values
);
3654 if (have_array_size
)
3655 mpz_clear (array_size
);
3656 if (have_vector_size
)
3657 mpz_clear (vector_size
);
3665 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3667 if (!type_check (mask
, 0, BT_LOGICAL
))
3670 if (!array_check (mask
, 0))
3673 if (!dim_rank_check (dim
, mask
, false))
3681 gfc_check_precision (gfc_expr
*x
)
3683 if (!real_or_complex_check (x
, 0))
3691 gfc_check_present (gfc_expr
*a
)
3695 if (!variable_check (a
, 0, true))
3698 sym
= a
->symtree
->n
.sym
;
3699 if (!sym
->attr
.dummy
)
3701 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3702 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3703 gfc_current_intrinsic
, &a
->where
);
3707 if (!sym
->attr
.optional
)
3709 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3710 "an OPTIONAL dummy variable",
3711 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3716 /* 13.14.82 PRESENT(A)
3718 Argument. A shall be the name of an optional dummy argument that is
3719 accessible in the subprogram in which the PRESENT function reference
3723 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3724 && (a
->ref
->u
.ar
.type
== AR_FULL
3725 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3726 && a
->ref
->u
.ar
.as
->rank
== 0))))
3728 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3729 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3730 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3739 gfc_check_radix (gfc_expr
*x
)
3741 if (!int_or_real_check (x
, 0))
3749 gfc_check_range (gfc_expr
*x
)
3751 if (!numeric_check (x
, 0))
3759 gfc_check_rank (gfc_expr
*a
)
3761 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3762 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3764 bool is_variable
= true;
3766 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3767 if (a
->expr_type
== EXPR_FUNCTION
)
3768 is_variable
= a
->value
.function
.esym
3769 ? a
->value
.function
.esym
->result
->attr
.pointer
3770 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3772 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3773 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3776 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3777 "object", &a
->where
);
3785 /* real, float, sngl. */
3787 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3789 if (!numeric_check (a
, 0))
3792 if (!kind_check (kind
, 1, BT_REAL
))
3800 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3802 if (!type_check (path1
, 0, BT_CHARACTER
))
3804 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3807 if (!type_check (path2
, 1, BT_CHARACTER
))
3809 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3817 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3819 if (!type_check (path1
, 0, BT_CHARACTER
))
3821 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3824 if (!type_check (path2
, 1, BT_CHARACTER
))
3826 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3832 if (!type_check (status
, 2, BT_INTEGER
))
3835 if (!scalar_check (status
, 2))
3843 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3845 if (!type_check (x
, 0, BT_CHARACTER
))
3848 if (!scalar_check (x
, 0))
3851 if (!type_check (y
, 0, BT_INTEGER
))
3854 if (!scalar_check (y
, 1))
3862 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3863 gfc_expr
*pad
, gfc_expr
*order
)
3869 if (!array_check (source
, 0))
3872 if (!rank_check (shape
, 1, 1))
3875 if (!type_check (shape
, 1, BT_INTEGER
))
3878 if (!gfc_array_size (shape
, &size
))
3880 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3881 "array of constant size", &shape
->where
);
3885 shape_size
= mpz_get_ui (size
);
3888 if (shape_size
<= 0)
3890 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3891 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3895 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3897 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
3898 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3901 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3905 for (i
= 0; i
< shape_size
; ++i
)
3907 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3908 if (e
->expr_type
!= EXPR_CONSTANT
)
3911 gfc_extract_int (e
, &extent
);
3914 gfc_error ("%qs argument of %qs intrinsic at %L has "
3915 "negative element (%d)",
3916 gfc_current_intrinsic_arg
[1]->name
,
3917 gfc_current_intrinsic
, &e
->where
, extent
);
3922 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
3923 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
3924 && shape
->ref
->u
.ar
.as
3925 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
3926 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
3927 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
3928 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
3929 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
3934 v
= shape
->symtree
->n
.sym
->value
;
3936 for (i
= 0; i
< shape_size
; i
++)
3938 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
3942 gfc_extract_int (e
, &extent
);
3946 gfc_error ("Element %d of actual argument of RESHAPE at %L "
3947 "cannot be negative", i
+ 1, &shape
->where
);
3955 if (!same_type_check (source
, 0, pad
, 2))
3958 if (!array_check (pad
, 2))
3964 if (!array_check (order
, 3))
3967 if (!type_check (order
, 3, BT_INTEGER
))
3970 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
3972 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3975 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3978 gfc_array_size (order
, &size
);
3979 order_size
= mpz_get_ui (size
);
3982 if (order_size
!= shape_size
)
3984 gfc_error ("%qs argument of %qs intrinsic at %L "
3985 "has wrong number of elements (%d/%d)",
3986 gfc_current_intrinsic_arg
[3]->name
,
3987 gfc_current_intrinsic
, &order
->where
,
3988 order_size
, shape_size
);
3992 for (i
= 1; i
<= order_size
; ++i
)
3994 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3995 if (e
->expr_type
!= EXPR_CONSTANT
)
3998 gfc_extract_int (e
, &dim
);
4000 if (dim
< 1 || dim
> order_size
)
4002 gfc_error ("%qs argument of %qs intrinsic at %L "
4003 "has out-of-range dimension (%d)",
4004 gfc_current_intrinsic_arg
[3]->name
,
4005 gfc_current_intrinsic
, &e
->where
, dim
);
4009 if (perm
[dim
-1] != 0)
4011 gfc_error ("%qs argument of %qs intrinsic at %L has "
4012 "invalid permutation of dimensions (dimension "
4014 gfc_current_intrinsic_arg
[3]->name
,
4015 gfc_current_intrinsic
, &e
->where
, dim
);
4024 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4025 && gfc_is_constant_expr (shape
)
4026 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4027 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4029 /* Check the match in size between source and destination. */
4030 if (gfc_array_size (source
, &nelems
))
4036 mpz_init_set_ui (size
, 1);
4037 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4038 c
; c
= gfc_constructor_next (c
))
4039 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4041 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4047 gfc_error ("Without padding, there are not enough elements "
4048 "in the intrinsic RESHAPE source at %L to match "
4049 "the shape", &source
->where
);
4060 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4062 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4064 gfc_error ("%qs argument of %qs intrinsic at %L "
4065 "cannot be of type %s",
4066 gfc_current_intrinsic_arg
[0]->name
,
4067 gfc_current_intrinsic
,
4068 &a
->where
, gfc_typename (&a
->ts
));
4072 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4074 gfc_error ("%qs argument of %qs intrinsic at %L "
4075 "must be of an extensible type",
4076 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4081 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4083 gfc_error ("%qs argument of %qs intrinsic at %L "
4084 "cannot be of type %s",
4085 gfc_current_intrinsic_arg
[0]->name
,
4086 gfc_current_intrinsic
,
4087 &b
->where
, gfc_typename (&b
->ts
));
4091 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4093 gfc_error ("%qs argument of %qs intrinsic at %L "
4094 "must be of an extensible type",
4095 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4105 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4107 if (!type_check (x
, 0, BT_REAL
))
4110 if (!type_check (i
, 1, BT_INTEGER
))
4118 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4120 if (!type_check (x
, 0, BT_CHARACTER
))
4123 if (!type_check (y
, 1, BT_CHARACTER
))
4126 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4129 if (!kind_check (kind
, 3, BT_INTEGER
))
4131 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4132 "with KIND argument at %L",
4133 gfc_current_intrinsic
, &kind
->where
))
4136 if (!same_type_check (x
, 0, y
, 1))
4144 gfc_check_secnds (gfc_expr
*r
)
4146 if (!type_check (r
, 0, BT_REAL
))
4149 if (!kind_value_check (r
, 0, 4))
4152 if (!scalar_check (r
, 0))
4160 gfc_check_selected_char_kind (gfc_expr
*name
)
4162 if (!type_check (name
, 0, BT_CHARACTER
))
4165 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4168 if (!scalar_check (name
, 0))
4176 gfc_check_selected_int_kind (gfc_expr
*r
)
4178 if (!type_check (r
, 0, BT_INTEGER
))
4181 if (!scalar_check (r
, 0))
4189 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4191 if (p
== NULL
&& r
== NULL
4192 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4193 " neither %<P%> nor %<R%> argument at %L",
4194 gfc_current_intrinsic_where
))
4199 if (!type_check (p
, 0, BT_INTEGER
))
4202 if (!scalar_check (p
, 0))
4208 if (!type_check (r
, 1, BT_INTEGER
))
4211 if (!scalar_check (r
, 1))
4217 if (!type_check (radix
, 1, BT_INTEGER
))
4220 if (!scalar_check (radix
, 1))
4223 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4224 "RADIX argument at %L", gfc_current_intrinsic
,
4234 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4236 if (!type_check (x
, 0, BT_REAL
))
4239 if (!type_check (i
, 1, BT_INTEGER
))
4247 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4251 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4254 ar
= gfc_find_array_ref (source
);
4256 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4258 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4259 "an assumed size array", &source
->where
);
4263 if (!kind_check (kind
, 1, BT_INTEGER
))
4265 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4266 "with KIND argument at %L",
4267 gfc_current_intrinsic
, &kind
->where
))
4275 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4277 if (!type_check (i
, 0, BT_INTEGER
))
4280 if (!type_check (shift
, 0, BT_INTEGER
))
4283 if (!nonnegative_check ("SHIFT", shift
))
4286 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4294 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4296 if (!int_or_real_check (a
, 0))
4299 if (!same_type_check (a
, 0, b
, 1))
4307 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4309 if (!array_check (array
, 0))
4312 if (!dim_check (dim
, 1, true))
4315 if (!dim_rank_check (dim
, array
, 0))
4318 if (!kind_check (kind
, 2, BT_INTEGER
))
4320 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4321 "with KIND argument at %L",
4322 gfc_current_intrinsic
, &kind
->where
))
4331 gfc_check_sizeof (gfc_expr
*arg
)
4333 if (arg
->ts
.type
== BT_PROCEDURE
)
4335 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4336 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4341 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4342 if (arg
->ts
.type
== BT_ASSUMED
4343 && (arg
->symtree
->n
.sym
->as
== NULL
4344 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4345 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4346 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4348 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4349 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4354 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4355 && arg
->symtree
->n
.sym
->as
!= NULL
4356 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4357 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4359 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4360 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4361 gfc_current_intrinsic
, &arg
->where
);
4369 /* Check whether an expression is interoperable. When returning false,
4370 msg is set to a string telling why the expression is not interoperable,
4371 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4372 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4373 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4374 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4378 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4382 if (expr
->ts
.type
== BT_CLASS
)
4384 *msg
= "Expression is polymorphic";
4388 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4389 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4391 *msg
= "Expression is a noninteroperable derived type";
4395 if (expr
->ts
.type
== BT_PROCEDURE
)
4397 *msg
= "Procedure unexpected as argument";
4401 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4404 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4405 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4407 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4411 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4412 && expr
->ts
.kind
!= 1)
4414 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4418 if (expr
->ts
.type
== BT_CHARACTER
) {
4419 if (expr
->ts
.deferred
)
4421 /* TS 29113 allows deferred-length strings as dummy arguments,
4422 but it is not an interoperable type. */
4423 *msg
= "Expression shall not be a deferred-length string";
4427 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4428 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4429 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4431 if (!c_loc
&& expr
->ts
.u
.cl
4432 && (!expr
->ts
.u
.cl
->length
4433 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4434 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4436 *msg
= "Type shall have a character length of 1";
4441 /* Note: The following checks are about interoperatable variables, Fortran
4442 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4443 is allowed, e.g. assumed-shape arrays with TS 29113. */
4445 if (gfc_is_coarray (expr
))
4447 *msg
= "Coarrays are not interoperable";
4451 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4453 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4454 if (ar
->type
!= AR_FULL
)
4456 *msg
= "Only whole-arrays are interoperable";
4459 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4460 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4462 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4472 gfc_check_c_sizeof (gfc_expr
*arg
)
4476 if (!is_c_interoperable (arg
, &msg
, false, false))
4478 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4479 "interoperable data entity: %s",
4480 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4485 if (arg
->ts
.type
== BT_ASSUMED
)
4487 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4489 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4494 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4495 && arg
->symtree
->n
.sym
->as
!= NULL
4496 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4497 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4499 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4500 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4501 gfc_current_intrinsic
, &arg
->where
);
4510 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4512 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4513 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4514 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4515 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4517 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4518 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4522 if (!scalar_check (c_ptr_1
, 0))
4526 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4527 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4528 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4529 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4531 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4532 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4533 gfc_typename (&c_ptr_1
->ts
),
4534 gfc_typename (&c_ptr_2
->ts
));
4538 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4546 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4548 symbol_attribute attr
;
4551 if (cptr
->ts
.type
!= BT_DERIVED
4552 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4553 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4555 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4556 "type TYPE(C_PTR)", &cptr
->where
);
4560 if (!scalar_check (cptr
, 0))
4563 attr
= gfc_expr_attr (fptr
);
4567 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4572 if (fptr
->ts
.type
== BT_CLASS
)
4574 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4579 if (gfc_is_coindexed (fptr
))
4581 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4582 "coindexed", &fptr
->where
);
4586 if (fptr
->rank
== 0 && shape
)
4588 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4589 "FPTR", &fptr
->where
);
4592 else if (fptr
->rank
&& !shape
)
4594 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4595 "FPTR at %L", &fptr
->where
);
4599 if (shape
&& !rank_check (shape
, 2, 1))
4602 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4608 if (gfc_array_size (shape
, &size
))
4610 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4613 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4614 "size as the RANK of FPTR", &shape
->where
);
4621 if (fptr
->ts
.type
== BT_CLASS
)
4623 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4627 if (!is_c_interoperable (fptr
, &msg
, false, true))
4628 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4629 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4636 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4638 symbol_attribute attr
;
4640 if (cptr
->ts
.type
!= BT_DERIVED
4641 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4642 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4644 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4645 "type TYPE(C_FUNPTR)", &cptr
->where
);
4649 if (!scalar_check (cptr
, 0))
4652 attr
= gfc_expr_attr (fptr
);
4654 if (!attr
.proc_pointer
)
4656 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4657 "pointer", &fptr
->where
);
4661 if (gfc_is_coindexed (fptr
))
4663 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4664 "coindexed", &fptr
->where
);
4668 if (!attr
.is_bind_c
)
4669 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4670 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4677 gfc_check_c_funloc (gfc_expr
*x
)
4679 symbol_attribute attr
;
4681 if (gfc_is_coindexed (x
))
4683 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4684 "coindexed", &x
->where
);
4688 attr
= gfc_expr_attr (x
);
4690 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4691 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4693 gfc_namespace
*ns
= gfc_current_ns
;
4695 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4696 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4698 gfc_error ("Function result %qs at %L is invalid as X argument "
4699 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4704 if (attr
.flavor
!= FL_PROCEDURE
)
4706 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4707 "or a procedure pointer", &x
->where
);
4711 if (!attr
.is_bind_c
)
4712 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4713 "at %L to C_FUNLOC", &x
->where
);
4719 gfc_check_c_loc (gfc_expr
*x
)
4721 symbol_attribute attr
;
4724 if (gfc_is_coindexed (x
))
4726 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4730 if (x
->ts
.type
== BT_CLASS
)
4732 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4737 attr
= gfc_expr_attr (x
);
4740 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4741 || attr
.flavor
== FL_PARAMETER
))
4743 gfc_error ("Argument X at %L to C_LOC shall have either "
4744 "the POINTER or the TARGET attribute", &x
->where
);
4748 if (x
->ts
.type
== BT_CHARACTER
4749 && gfc_var_strlen (x
) == 0)
4751 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4752 "string", &x
->where
);
4756 if (!is_c_interoperable (x
, &msg
, true, false))
4758 if (x
->ts
.type
== BT_CLASS
)
4760 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4766 && !gfc_notify_std (GFC_STD_F2008_TS
,
4767 "Noninteroperable array at %L as"
4768 " argument to C_LOC: %s", &x
->where
, msg
))
4771 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4773 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4775 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4776 && !attr
.allocatable
4777 && !gfc_notify_std (GFC_STD_F2008
,
4778 "Array of interoperable type at %L "
4779 "to C_LOC which is nonallocatable and neither "
4780 "assumed size nor explicit size", &x
->where
))
4782 else if (ar
->type
!= AR_FULL
4783 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4784 "to C_LOC", &x
->where
))
4793 gfc_check_sleep_sub (gfc_expr
*seconds
)
4795 if (!type_check (seconds
, 0, BT_INTEGER
))
4798 if (!scalar_check (seconds
, 0))
4805 gfc_check_sngl (gfc_expr
*a
)
4807 if (!type_check (a
, 0, BT_REAL
))
4810 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4811 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4812 "REAL argument to %s intrinsic at %L",
4813 gfc_current_intrinsic
, &a
->where
))
4820 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4822 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4824 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4825 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4826 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4834 if (!dim_check (dim
, 1, false))
4837 /* dim_rank_check() does not apply here. */
4839 && dim
->expr_type
== EXPR_CONSTANT
4840 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4841 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4843 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4844 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4845 gfc_current_intrinsic
, &dim
->where
);
4849 if (!type_check (ncopies
, 2, BT_INTEGER
))
4852 if (!scalar_check (ncopies
, 2))
4859 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4863 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4865 if (!type_check (unit
, 0, BT_INTEGER
))
4868 if (!scalar_check (unit
, 0))
4871 if (!type_check (c
, 1, BT_CHARACTER
))
4873 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4879 if (!type_check (status
, 2, BT_INTEGER
)
4880 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4881 || !scalar_check (status
, 2))
4889 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4891 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4896 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4898 if (!type_check (c
, 0, BT_CHARACTER
))
4900 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4906 if (!type_check (status
, 1, BT_INTEGER
)
4907 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4908 || !scalar_check (status
, 1))
4916 gfc_check_fgetput (gfc_expr
*c
)
4918 return gfc_check_fgetput_sub (c
, NULL
);
4923 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4925 if (!type_check (unit
, 0, BT_INTEGER
))
4928 if (!scalar_check (unit
, 0))
4931 if (!type_check (offset
, 1, BT_INTEGER
))
4934 if (!scalar_check (offset
, 1))
4937 if (!type_check (whence
, 2, BT_INTEGER
))
4940 if (!scalar_check (whence
, 2))
4946 if (!type_check (status
, 3, BT_INTEGER
))
4949 if (!kind_value_check (status
, 3, 4))
4952 if (!scalar_check (status
, 3))
4961 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4963 if (!type_check (unit
, 0, BT_INTEGER
))
4966 if (!scalar_check (unit
, 0))
4969 if (!type_check (array
, 1, BT_INTEGER
)
4970 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4973 if (!array_check (array
, 1))
4981 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4983 if (!type_check (unit
, 0, BT_INTEGER
))
4986 if (!scalar_check (unit
, 0))
4989 if (!type_check (array
, 1, BT_INTEGER
)
4990 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4993 if (!array_check (array
, 1))
4999 if (!type_check (status
, 2, BT_INTEGER
)
5000 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5003 if (!scalar_check (status
, 2))
5011 gfc_check_ftell (gfc_expr
*unit
)
5013 if (!type_check (unit
, 0, BT_INTEGER
))
5016 if (!scalar_check (unit
, 0))
5024 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5026 if (!type_check (unit
, 0, BT_INTEGER
))
5029 if (!scalar_check (unit
, 0))
5032 if (!type_check (offset
, 1, BT_INTEGER
))
5035 if (!scalar_check (offset
, 1))
5043 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5045 if (!type_check (name
, 0, BT_CHARACTER
))
5047 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5050 if (!type_check (array
, 1, BT_INTEGER
)
5051 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5054 if (!array_check (array
, 1))
5062 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5064 if (!type_check (name
, 0, BT_CHARACTER
))
5066 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5069 if (!type_check (array
, 1, BT_INTEGER
)
5070 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5073 if (!array_check (array
, 1))
5079 if (!type_check (status
, 2, BT_INTEGER
)
5080 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5083 if (!scalar_check (status
, 2))
5091 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5095 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5097 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5101 if (!coarray_check (coarray
, 0))
5106 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5107 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5111 if (gfc_array_size (sub
, &nelems
))
5113 int corank
= gfc_get_corank (coarray
);
5115 if (mpz_cmp_ui (nelems
, corank
) != 0)
5117 gfc_error ("The number of array elements of the SUB argument to "
5118 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5119 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5131 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5133 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5135 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5141 if (!type_check (distance
, 0, BT_INTEGER
))
5144 if (!nonnegative_check ("DISTANCE", distance
))
5147 if (!scalar_check (distance
, 0))
5150 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5151 "NUM_IMAGES at %L", &distance
->where
))
5157 if (!type_check (failed
, 1, BT_LOGICAL
))
5160 if (!scalar_check (failed
, 1))
5163 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5164 "NUM_IMAGES at %L", &failed
->where
))
5173 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5175 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5177 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5181 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5184 if (dim
!= NULL
&& coarray
== NULL
)
5186 gfc_error ("DIM argument without COARRAY argument not allowed for "
5187 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5191 if (distance
&& (coarray
|| dim
))
5193 gfc_error ("The DISTANCE argument may not be specified together with the "
5194 "COARRAY or DIM argument in intrinsic at %L",
5199 /* Assume that we have "this_image (distance)". */
5200 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5204 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5213 if (!type_check (distance
, 2, BT_INTEGER
))
5216 if (!nonnegative_check ("DISTANCE", distance
))
5219 if (!scalar_check (distance
, 2))
5222 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5223 "THIS_IMAGE at %L", &distance
->where
))
5229 if (!coarray_check (coarray
, 0))
5234 if (!dim_check (dim
, 1, false))
5237 if (!dim_corank_check (dim
, coarray
))
5244 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5245 by gfc_simplify_transfer. Return false if we cannot do so. */
5248 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5249 size_t *source_size
, size_t *result_size
,
5250 size_t *result_length_p
)
5252 size_t result_elt_size
;
5254 if (source
->expr_type
== EXPR_FUNCTION
)
5257 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5260 /* Calculate the size of the source. */
5261 *source_size
= gfc_target_expr_size (source
);
5262 if (*source_size
== 0)
5265 /* Determine the size of the element. */
5266 result_elt_size
= gfc_element_size (mold
);
5267 if (result_elt_size
== 0)
5270 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5275 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5278 result_length
= *source_size
/ result_elt_size
;
5279 if (result_length
* result_elt_size
< *source_size
)
5283 *result_size
= result_length
* result_elt_size
;
5284 if (result_length_p
)
5285 *result_length_p
= result_length
;
5288 *result_size
= result_elt_size
;
5295 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5300 if (mold
->ts
.type
== BT_HOLLERITH
)
5302 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5303 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5309 if (!type_check (size
, 2, BT_INTEGER
))
5312 if (!scalar_check (size
, 2))
5315 if (!nonoptional_check (size
, 2))
5319 if (!warn_surprising
)
5322 /* If we can't calculate the sizes, we cannot check any more.
5323 Return true for that case. */
5325 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5326 &result_size
, NULL
))
5329 if (source_size
< result_size
)
5330 gfc_warning (OPT_Wsurprising
,
5331 "Intrinsic TRANSFER at %L has partly undefined result: "
5332 "source size %ld < result size %ld", &source
->where
,
5333 (long) source_size
, (long) result_size
);
5340 gfc_check_transpose (gfc_expr
*matrix
)
5342 if (!rank_check (matrix
, 0, 2))
5350 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5352 if (!array_check (array
, 0))
5355 if (!dim_check (dim
, 1, false))
5358 if (!dim_rank_check (dim
, array
, 0))
5361 if (!kind_check (kind
, 2, BT_INTEGER
))
5363 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5364 "with KIND argument at %L",
5365 gfc_current_intrinsic
, &kind
->where
))
5373 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5375 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5377 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5381 if (!coarray_check (coarray
, 0))
5386 if (!dim_check (dim
, 1, false))
5389 if (!dim_corank_check (dim
, coarray
))
5393 if (!kind_check (kind
, 2, BT_INTEGER
))
5401 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5405 if (!rank_check (vector
, 0, 1))
5408 if (!array_check (mask
, 1))
5411 if (!type_check (mask
, 1, BT_LOGICAL
))
5414 if (!same_type_check (vector
, 0, field
, 2))
5417 if (mask
->expr_type
== EXPR_ARRAY
5418 && gfc_array_size (vector
, &vector_size
))
5420 int mask_true_count
= 0;
5421 gfc_constructor
*mask_ctor
;
5422 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5425 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5427 mask_true_count
= 0;
5431 if (mask_ctor
->expr
->value
.logical
)
5434 mask_ctor
= gfc_constructor_next (mask_ctor
);
5437 if (mpz_get_si (vector_size
) < mask_true_count
)
5439 gfc_error ("%qs argument of %qs intrinsic at %L must "
5440 "provide at least as many elements as there "
5441 "are .TRUE. values in %qs (%ld/%d)",
5442 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5443 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5444 mpz_get_si (vector_size
), mask_true_count
);
5448 mpz_clear (vector_size
);
5451 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5453 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5454 "the same rank as %qs or be a scalar",
5455 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5456 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5460 if (mask
->rank
== field
->rank
)
5463 for (i
= 0; i
< field
->rank
; i
++)
5464 if (! identical_dimen_shape (mask
, i
, field
, i
))
5466 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5467 "must have identical shape.",
5468 gfc_current_intrinsic_arg
[2]->name
,
5469 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5479 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5481 if (!type_check (x
, 0, BT_CHARACTER
))
5484 if (!same_type_check (x
, 0, y
, 1))
5487 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5490 if (!kind_check (kind
, 3, BT_INTEGER
))
5492 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5493 "with KIND argument at %L",
5494 gfc_current_intrinsic
, &kind
->where
))
5502 gfc_check_trim (gfc_expr
*x
)
5504 if (!type_check (x
, 0, BT_CHARACTER
))
5507 if (!scalar_check (x
, 0))
5515 gfc_check_ttynam (gfc_expr
*unit
)
5517 if (!scalar_check (unit
, 0))
5520 if (!type_check (unit
, 0, BT_INTEGER
))
5527 /************* Check functions for intrinsic subroutines *************/
5530 gfc_check_cpu_time (gfc_expr
*time
)
5532 if (!scalar_check (time
, 0))
5535 if (!type_check (time
, 0, BT_REAL
))
5538 if (!variable_check (time
, 0, false))
5546 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5547 gfc_expr
*zone
, gfc_expr
*values
)
5551 if (!type_check (date
, 0, BT_CHARACTER
))
5553 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5555 if (!scalar_check (date
, 0))
5557 if (!variable_check (date
, 0, false))
5563 if (!type_check (time
, 1, BT_CHARACTER
))
5565 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5567 if (!scalar_check (time
, 1))
5569 if (!variable_check (time
, 1, false))
5575 if (!type_check (zone
, 2, BT_CHARACTER
))
5577 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5579 if (!scalar_check (zone
, 2))
5581 if (!variable_check (zone
, 2, false))
5587 if (!type_check (values
, 3, BT_INTEGER
))
5589 if (!array_check (values
, 3))
5591 if (!rank_check (values
, 3, 1))
5593 if (!variable_check (values
, 3, false))
5602 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5603 gfc_expr
*to
, gfc_expr
*topos
)
5605 if (!type_check (from
, 0, BT_INTEGER
))
5608 if (!type_check (frompos
, 1, BT_INTEGER
))
5611 if (!type_check (len
, 2, BT_INTEGER
))
5614 if (!same_type_check (from
, 0, to
, 3))
5617 if (!variable_check (to
, 3, false))
5620 if (!type_check (topos
, 4, BT_INTEGER
))
5623 if (!nonnegative_check ("frompos", frompos
))
5626 if (!nonnegative_check ("topos", topos
))
5629 if (!nonnegative_check ("len", len
))
5632 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5635 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5643 gfc_check_random_number (gfc_expr
*harvest
)
5645 if (!type_check (harvest
, 0, BT_REAL
))
5648 if (!variable_check (harvest
, 0, false))
5656 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5658 unsigned int nargs
= 0, seed_size
;
5659 locus
*where
= NULL
;
5660 mpz_t put_size
, get_size
;
5662 /* Keep the number of bytes in sync with master_state in
5663 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5664 part of the state too. */
5665 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5669 if (size
->expr_type
!= EXPR_VARIABLE
5670 || !size
->symtree
->n
.sym
->attr
.optional
)
5673 if (!scalar_check (size
, 0))
5676 if (!type_check (size
, 0, BT_INTEGER
))
5679 if (!variable_check (size
, 0, false))
5682 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5688 if (put
->expr_type
!= EXPR_VARIABLE
5689 || !put
->symtree
->n
.sym
->attr
.optional
)
5692 where
= &put
->where
;
5695 if (!array_check (put
, 1))
5698 if (!rank_check (put
, 1, 1))
5701 if (!type_check (put
, 1, BT_INTEGER
))
5704 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5707 if (gfc_array_size (put
, &put_size
)
5708 && mpz_get_ui (put_size
) < seed_size
)
5709 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5710 "too small (%i/%i)",
5711 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5712 where
, (int) mpz_get_ui (put_size
), seed_size
);
5717 if (get
->expr_type
!= EXPR_VARIABLE
5718 || !get
->symtree
->n
.sym
->attr
.optional
)
5721 where
= &get
->where
;
5724 if (!array_check (get
, 2))
5727 if (!rank_check (get
, 2, 1))
5730 if (!type_check (get
, 2, BT_INTEGER
))
5733 if (!variable_check (get
, 2, false))
5736 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5739 if (gfc_array_size (get
, &get_size
)
5740 && mpz_get_ui (get_size
) < seed_size
)
5741 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5742 "too small (%i/%i)",
5743 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5744 where
, (int) mpz_get_ui (get_size
), seed_size
);
5747 /* RANDOM_SEED may not have more than one non-optional argument. */
5749 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5755 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5759 int num_percent
, nargs
;
5762 if (e
->expr_type
!= EXPR_CONSTANT
)
5765 len
= e
->value
.character
.length
;
5766 if (e
->value
.character
.string
[len
-1] != '\0')
5767 gfc_internal_error ("fe_runtime_error string must be null terminated");
5770 for (i
=0; i
<len
-1; i
++)
5771 if (e
->value
.character
.string
[i
] == '%')
5775 for (; a
; a
= a
->next
)
5778 if (nargs
-1 != num_percent
)
5779 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5780 nargs
, num_percent
++);
5786 gfc_check_second_sub (gfc_expr
*time
)
5788 if (!scalar_check (time
, 0))
5791 if (!type_check (time
, 0, BT_REAL
))
5794 if (!kind_value_check (time
, 0, 4))
5801 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5802 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5803 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5804 count_max are all optional arguments */
5807 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5808 gfc_expr
*count_max
)
5812 if (!scalar_check (count
, 0))
5815 if (!type_check (count
, 0, BT_INTEGER
))
5818 if (count
->ts
.kind
!= gfc_default_integer_kind
5819 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5820 "SYSTEM_CLOCK at %L has non-default kind",
5824 if (!variable_check (count
, 0, false))
5828 if (count_rate
!= NULL
)
5830 if (!scalar_check (count_rate
, 1))
5833 if (!variable_check (count_rate
, 1, false))
5836 if (count_rate
->ts
.type
== BT_REAL
)
5838 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5839 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5844 if (!type_check (count_rate
, 1, BT_INTEGER
))
5847 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5848 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5849 "SYSTEM_CLOCK at %L has non-default kind",
5850 &count_rate
->where
))
5856 if (count_max
!= NULL
)
5858 if (!scalar_check (count_max
, 2))
5861 if (!type_check (count_max
, 2, BT_INTEGER
))
5864 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5865 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5866 "SYSTEM_CLOCK at %L has non-default kind",
5870 if (!variable_check (count_max
, 2, false))
5879 gfc_check_irand (gfc_expr
*x
)
5884 if (!scalar_check (x
, 0))
5887 if (!type_check (x
, 0, BT_INTEGER
))
5890 if (!kind_value_check (x
, 0, 4))
5898 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5900 if (!scalar_check (seconds
, 0))
5902 if (!type_check (seconds
, 0, BT_INTEGER
))
5905 if (!int_or_proc_check (handler
, 1))
5907 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5913 if (!scalar_check (status
, 2))
5915 if (!type_check (status
, 2, BT_INTEGER
))
5917 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5925 gfc_check_rand (gfc_expr
*x
)
5930 if (!scalar_check (x
, 0))
5933 if (!type_check (x
, 0, BT_INTEGER
))
5936 if (!kind_value_check (x
, 0, 4))
5944 gfc_check_srand (gfc_expr
*x
)
5946 if (!scalar_check (x
, 0))
5949 if (!type_check (x
, 0, BT_INTEGER
))
5952 if (!kind_value_check (x
, 0, 4))
5960 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5962 if (!scalar_check (time
, 0))
5964 if (!type_check (time
, 0, BT_INTEGER
))
5967 if (!type_check (result
, 1, BT_CHARACTER
))
5969 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5977 gfc_check_dtime_etime (gfc_expr
*x
)
5979 if (!array_check (x
, 0))
5982 if (!rank_check (x
, 0, 1))
5985 if (!variable_check (x
, 0, false))
5988 if (!type_check (x
, 0, BT_REAL
))
5991 if (!kind_value_check (x
, 0, 4))
5999 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6001 if (!array_check (values
, 0))
6004 if (!rank_check (values
, 0, 1))
6007 if (!variable_check (values
, 0, false))
6010 if (!type_check (values
, 0, BT_REAL
))
6013 if (!kind_value_check (values
, 0, 4))
6016 if (!scalar_check (time
, 1))
6019 if (!type_check (time
, 1, BT_REAL
))
6022 if (!kind_value_check (time
, 1, 4))
6030 gfc_check_fdate_sub (gfc_expr
*date
)
6032 if (!type_check (date
, 0, BT_CHARACTER
))
6034 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6042 gfc_check_gerror (gfc_expr
*msg
)
6044 if (!type_check (msg
, 0, BT_CHARACTER
))
6046 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6054 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6056 if (!type_check (cwd
, 0, BT_CHARACTER
))
6058 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6064 if (!scalar_check (status
, 1))
6067 if (!type_check (status
, 1, BT_INTEGER
))
6075 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6077 if (!type_check (pos
, 0, BT_INTEGER
))
6080 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6082 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6083 "not wider than the default kind (%d)",
6084 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6085 &pos
->where
, gfc_default_integer_kind
);
6089 if (!type_check (value
, 1, BT_CHARACTER
))
6091 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6099 gfc_check_getlog (gfc_expr
*msg
)
6101 if (!type_check (msg
, 0, BT_CHARACTER
))
6103 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6111 gfc_check_exit (gfc_expr
*status
)
6116 if (!type_check (status
, 0, BT_INTEGER
))
6119 if (!scalar_check (status
, 0))
6127 gfc_check_flush (gfc_expr
*unit
)
6132 if (!type_check (unit
, 0, BT_INTEGER
))
6135 if (!scalar_check (unit
, 0))
6143 gfc_check_free (gfc_expr
*i
)
6145 if (!type_check (i
, 0, BT_INTEGER
))
6148 if (!scalar_check (i
, 0))
6156 gfc_check_hostnm (gfc_expr
*name
)
6158 if (!type_check (name
, 0, BT_CHARACTER
))
6160 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6168 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6170 if (!type_check (name
, 0, BT_CHARACTER
))
6172 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6178 if (!scalar_check (status
, 1))
6181 if (!type_check (status
, 1, BT_INTEGER
))
6189 gfc_check_itime_idate (gfc_expr
*values
)
6191 if (!array_check (values
, 0))
6194 if (!rank_check (values
, 0, 1))
6197 if (!variable_check (values
, 0, false))
6200 if (!type_check (values
, 0, BT_INTEGER
))
6203 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6211 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6213 if (!type_check (time
, 0, BT_INTEGER
))
6216 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6219 if (!scalar_check (time
, 0))
6222 if (!array_check (values
, 1))
6225 if (!rank_check (values
, 1, 1))
6228 if (!variable_check (values
, 1, false))
6231 if (!type_check (values
, 1, BT_INTEGER
))
6234 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6242 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6244 if (!scalar_check (unit
, 0))
6247 if (!type_check (unit
, 0, BT_INTEGER
))
6250 if (!type_check (name
, 1, BT_CHARACTER
))
6252 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6260 gfc_check_isatty (gfc_expr
*unit
)
6265 if (!type_check (unit
, 0, BT_INTEGER
))
6268 if (!scalar_check (unit
, 0))
6276 gfc_check_isnan (gfc_expr
*x
)
6278 if (!type_check (x
, 0, BT_REAL
))
6286 gfc_check_perror (gfc_expr
*string
)
6288 if (!type_check (string
, 0, BT_CHARACTER
))
6290 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6298 gfc_check_umask (gfc_expr
*mask
)
6300 if (!type_check (mask
, 0, BT_INTEGER
))
6303 if (!scalar_check (mask
, 0))
6311 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6313 if (!type_check (mask
, 0, BT_INTEGER
))
6316 if (!scalar_check (mask
, 0))
6322 if (!scalar_check (old
, 1))
6325 if (!type_check (old
, 1, BT_INTEGER
))
6333 gfc_check_unlink (gfc_expr
*name
)
6335 if (!type_check (name
, 0, BT_CHARACTER
))
6337 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6345 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6347 if (!type_check (name
, 0, BT_CHARACTER
))
6349 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6355 if (!scalar_check (status
, 1))
6358 if (!type_check (status
, 1, BT_INTEGER
))
6366 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6368 if (!scalar_check (number
, 0))
6370 if (!type_check (number
, 0, BT_INTEGER
))
6373 if (!int_or_proc_check (handler
, 1))
6375 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6383 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6385 if (!scalar_check (number
, 0))
6387 if (!type_check (number
, 0, BT_INTEGER
))
6390 if (!int_or_proc_check (handler
, 1))
6392 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6398 if (!type_check (status
, 2, BT_INTEGER
))
6400 if (!scalar_check (status
, 2))
6408 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6410 if (!type_check (cmd
, 0, BT_CHARACTER
))
6412 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6415 if (!scalar_check (status
, 1))
6418 if (!type_check (status
, 1, BT_INTEGER
))
6421 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6428 /* This is used for the GNU intrinsics AND, OR and XOR. */
6430 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6432 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6434 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6435 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6436 gfc_current_intrinsic
, &i
->where
);
6440 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6442 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6443 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6444 gfc_current_intrinsic
, &j
->where
);
6448 if (i
->ts
.type
!= j
->ts
.type
)
6450 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6451 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6452 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6457 if (!scalar_check (i
, 0))
6460 if (!scalar_check (j
, 1))
6468 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6471 if (a
->expr_type
== EXPR_NULL
)
6473 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6474 "argument to STORAGE_SIZE, because it returns a "
6475 "disassociated pointer", &a
->where
);
6479 if (a
->ts
.type
== BT_ASSUMED
)
6481 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6482 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6487 if (a
->ts
.type
== BT_PROCEDURE
)
6489 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6490 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6491 gfc_current_intrinsic
, &a
->where
);
6498 if (!type_check (kind
, 1, BT_INTEGER
))
6501 if (!scalar_check (kind
, 1))
6504 if (kind
->expr_type
!= EXPR_CONSTANT
)
6506 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6507 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,