2 Copyright (C) 2002-2018 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
);
120 /* Check that an expression is integer or real; allow character for
124 int_or_real_or_char_check_f2003 (gfc_expr
*e
, int n
)
126 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
128 if (e
->ts
.type
== BT_CHARACTER
)
129 return gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Character for "
130 "%qs argument of %qs intrinsic at %L",
131 gfc_current_intrinsic_arg
[n
]->name
,
132 gfc_current_intrinsic
, &e
->where
);
135 if (gfc_option
.allow_std
& GFC_STD_F2003
)
136 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
137 "or REAL or CHARACTER",
138 gfc_current_intrinsic_arg
[n
]->name
,
139 gfc_current_intrinsic
, &e
->where
);
141 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
142 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
143 gfc_current_intrinsic
, &e
->where
);
152 /* Check that an expression is real or complex. */
155 real_or_complex_check (gfc_expr
*e
, int n
)
157 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
159 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
160 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
161 gfc_current_intrinsic
, &e
->where
);
169 /* Check that an expression is INTEGER or PROCEDURE. */
172 int_or_proc_check (gfc_expr
*e
, int n
)
174 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
176 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
177 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
178 gfc_current_intrinsic
, &e
->where
);
186 /* Check that the expression is an optional constant integer
187 and that it specifies a valid kind for that type. */
190 kind_check (gfc_expr
*k
, int n
, bt type
)
197 if (!type_check (k
, n
, BT_INTEGER
))
200 if (!scalar_check (k
, n
))
203 if (!gfc_check_init_expr (k
))
205 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
206 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
211 if (gfc_extract_int (k
, &kind
)
212 || gfc_validate_kind (type
, kind
, true) < 0)
214 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
223 /* Make sure the expression is a double precision real. */
226 double_check (gfc_expr
*d
, int n
)
228 if (!type_check (d
, n
, BT_REAL
))
231 if (d
->ts
.kind
!= gfc_default_double_kind
)
233 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
234 "precision", gfc_current_intrinsic_arg
[n
]->name
,
235 gfc_current_intrinsic
, &d
->where
);
244 coarray_check (gfc_expr
*e
, int n
)
246 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
247 && CLASS_DATA (e
)->attr
.codimension
248 && CLASS_DATA (e
)->as
->corank
)
250 gfc_add_class_array_ref (e
);
254 if (!gfc_is_coarray (e
))
256 gfc_error ("Expected coarray variable as %qs argument to the %s "
257 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
258 gfc_current_intrinsic
, &e
->where
);
266 /* Make sure the expression is a logical array. */
269 logical_array_check (gfc_expr
*array
, int n
)
271 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
273 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
274 "array", gfc_current_intrinsic_arg
[n
]->name
,
275 gfc_current_intrinsic
, &array
->where
);
283 /* Make sure an expression is an array. */
286 array_check (gfc_expr
*e
, int n
)
288 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
289 && CLASS_DATA (e
)->attr
.dimension
290 && CLASS_DATA (e
)->as
->rank
)
292 gfc_add_class_array_ref (e
);
296 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
299 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
300 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
307 /* If expr is a constant, then check to ensure that it is greater than
311 nonnegative_check (const char *arg
, gfc_expr
*expr
)
315 if (expr
->expr_type
== EXPR_CONSTANT
)
317 gfc_extract_int (expr
, &i
);
320 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
329 /* If expr is a constant, then check to ensure that it is greater than zero. */
332 positive_check (int n
, gfc_expr
*expr
)
336 if (expr
->expr_type
== EXPR_CONSTANT
)
338 gfc_extract_int (expr
, &i
);
341 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
342 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
352 /* If expr2 is constant, then check that the value is less than
353 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
356 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
357 gfc_expr
*expr2
, bool or_equal
)
361 if (expr2
->expr_type
== EXPR_CONSTANT
)
363 gfc_extract_int (expr2
, &i2
);
364 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
366 /* For ISHFT[C], check that |shift| <= bit_size(i). */
372 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
374 gfc_error ("The absolute value of SHIFT at %L must be less "
375 "than or equal to BIT_SIZE(%qs)",
376 &expr2
->where
, arg1
);
383 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
385 gfc_error ("%qs at %L must be less than "
386 "or equal to BIT_SIZE(%qs)",
387 arg2
, &expr2
->where
, arg1
);
393 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
395 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
396 arg2
, &expr2
->where
, arg1
);
406 /* If expr is constant, then check that the value is less than or equal
407 to the bit_size of the kind k. */
410 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
414 if (expr
->expr_type
!= EXPR_CONSTANT
)
417 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
418 gfc_extract_int (expr
, &val
);
420 if (val
> gfc_integer_kinds
[i
].bit_size
)
422 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
423 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
431 /* If expr2 and expr3 are constants, then check that the value is less than
432 or equal to bit_size(expr1). */
435 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
436 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
440 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
442 gfc_extract_int (expr2
, &i2
);
443 gfc_extract_int (expr3
, &i3
);
445 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
446 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
448 gfc_error ("%<%s + %s%> at %L must be less than or equal "
450 arg2
, arg3
, &expr2
->where
, arg1
);
458 /* Make sure two expressions have the same type. */
461 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
, bool assoc
= false)
463 gfc_typespec
*ets
= &e
->ts
;
464 gfc_typespec
*fts
= &f
->ts
;
468 /* Procedure pointer component expressions have the type of the interface
469 procedure. If they are being tested for association with a procedure
470 pointer (ie. not a component), the type of the procedure must be
472 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
473 ets
= &e
->symtree
->n
.sym
->ts
;
474 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
475 fts
= &f
->symtree
->n
.sym
->ts
;
478 if (gfc_compare_types (ets
, fts
))
481 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
482 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
483 gfc_current_intrinsic
, &f
->where
,
484 gfc_current_intrinsic_arg
[n
]->name
);
490 /* Make sure that an expression has a certain (nonzero) rank. */
493 rank_check (gfc_expr
*e
, int n
, int rank
)
498 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
499 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
506 /* Make sure a variable expression is not an optional dummy argument. */
509 nonoptional_check (gfc_expr
*e
, int n
)
511 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
513 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
514 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
518 /* TODO: Recursive check on nonoptional variables? */
524 /* Check for ALLOCATABLE attribute. */
527 allocatable_check (gfc_expr
*e
, int n
)
529 symbol_attribute attr
;
531 attr
= gfc_variable_attr (e
, NULL
);
532 if (!attr
.allocatable
|| attr
.associate_var
)
534 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
535 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
544 /* Check that an expression has a particular kind. */
547 kind_value_check (gfc_expr
*e
, int n
, int k
)
552 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
553 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
560 /* Make sure an expression is a variable. */
563 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
565 if (e
->expr_type
== EXPR_VARIABLE
566 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
567 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
568 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
571 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
572 && CLASS_DATA (e
->symtree
->n
.sym
)
573 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
574 : e
->symtree
->n
.sym
->attr
.pointer
;
576 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
578 if (pointer
&& ref
->type
== REF_COMPONENT
)
580 if (ref
->type
== REF_COMPONENT
581 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
582 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
583 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
584 && ref
->u
.c
.component
->attr
.pointer
)))
590 gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
591 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
592 gfc_current_intrinsic
, &e
->where
);
597 if (e
->expr_type
== EXPR_VARIABLE
598 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
599 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
602 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
603 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
606 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
607 if (ns
->proc_name
== e
->symtree
->n
.sym
)
611 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
612 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
618 /* Check the common DIM parameter for correctness. */
621 dim_check (gfc_expr
*dim
, int n
, bool optional
)
626 if (!type_check (dim
, n
, BT_INTEGER
))
629 if (!scalar_check (dim
, n
))
632 if (!optional
&& !nonoptional_check (dim
, n
))
639 /* If a coarray DIM parameter is a constant, make sure that it is greater than
640 zero and less than or equal to the corank of the given array. */
643 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
647 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
649 if (dim
->expr_type
!= EXPR_CONSTANT
)
652 if (array
->ts
.type
== BT_CLASS
)
655 corank
= gfc_get_corank (array
);
657 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
658 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
660 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
661 "codimension index", gfc_current_intrinsic
, &dim
->where
);
670 /* If a DIM parameter is a constant, make sure that it is greater than
671 zero and less than or equal to the rank of the given array. If
672 allow_assumed is zero then dim must be less than the rank of the array
673 for assumed size arrays. */
676 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
684 if (dim
->expr_type
!= EXPR_CONSTANT
)
687 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
688 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
689 rank
= array
->rank
+ 1;
693 /* Assumed-rank array. */
695 rank
= GFC_MAX_DIMENSIONS
;
697 if (array
->expr_type
== EXPR_VARIABLE
)
699 ar
= gfc_find_array_ref (array
);
700 if (ar
->as
->type
== AS_ASSUMED_SIZE
702 && ar
->type
!= AR_ELEMENT
703 && ar
->type
!= AR_SECTION
)
707 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
708 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
710 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
711 "dimension index", gfc_current_intrinsic
, &dim
->where
);
720 /* Compare the size of a along dimension ai with the size of b along
721 dimension bi, returning 0 if they are known not to be identical,
722 and 1 if they are identical, or if this cannot be determined. */
725 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
727 mpz_t a_size
, b_size
;
730 gcc_assert (a
->rank
> ai
);
731 gcc_assert (b
->rank
> bi
);
735 if (gfc_array_dimen_size (a
, ai
, &a_size
))
737 if (gfc_array_dimen_size (b
, bi
, &b_size
))
739 if (mpz_cmp (a_size
, b_size
) != 0)
749 /* Calculate the length of a character variable, including substrings.
750 Strip away parentheses if necessary. Return -1 if no length could
754 gfc_var_strlen (const gfc_expr
*a
)
758 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
761 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
771 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
772 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
774 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
776 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
777 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
779 else if (ra
->u
.ss
.start
780 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
786 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
787 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
788 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
789 else if (a
->expr_type
== EXPR_CONSTANT
790 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
791 return a
->value
.character
.length
;
797 /* Check whether two character expressions have the same length;
798 returns true if they have or if the length cannot be determined,
799 otherwise return false and raise a gfc_error. */
802 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
806 len_a
= gfc_var_strlen(a
);
807 len_b
= gfc_var_strlen(b
);
809 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
813 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
814 len_a
, len_b
, name
, &a
->where
);
820 /***** Check functions *****/
822 /* Check subroutine suitable for intrinsics taking a real argument and
823 a kind argument for the result. */
826 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
828 if (!type_check (a
, 0, BT_REAL
))
830 if (!kind_check (kind
, 1, type
))
837 /* Check subroutine suitable for ceiling, floor and nint. */
840 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
842 return check_a_kind (a
, kind
, BT_INTEGER
);
846 /* Check subroutine suitable for aint, anint. */
849 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
851 return check_a_kind (a
, kind
, BT_REAL
);
856 gfc_check_abs (gfc_expr
*a
)
858 if (!numeric_check (a
, 0))
866 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
868 if (!type_check (a
, 0, BT_INTEGER
))
870 if (!kind_check (kind
, 1, BT_CHARACTER
))
878 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
880 if (!type_check (name
, 0, BT_CHARACTER
)
881 || !scalar_check (name
, 0))
883 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
886 if (!type_check (mode
, 1, BT_CHARACTER
)
887 || !scalar_check (mode
, 1))
889 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
897 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
899 if (!logical_array_check (mask
, 0))
902 if (!dim_check (dim
, 1, false))
905 if (!dim_rank_check (dim
, mask
, 0))
913 gfc_check_allocated (gfc_expr
*array
)
915 /* Tests on allocated components of coarrays need to detour the check to
916 argument of the _caf_get. */
917 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
918 && array
->value
.function
.isym
919 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
921 array
= array
->value
.function
.actual
->expr
;
926 if (!variable_check (array
, 0, false))
928 if (!allocatable_check (array
, 0))
935 /* Common check function where the first argument must be real or
936 integer and the second argument must be the same as the first. */
939 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
941 if (!int_or_real_check (a
, 0))
944 if (a
->ts
.type
!= p
->ts
.type
)
946 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
947 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
948 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
953 if (a
->ts
.kind
!= p
->ts
.kind
)
955 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
965 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
967 if (!double_check (x
, 0) || !double_check (y
, 1))
975 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
977 symbol_attribute attr1
, attr2
;
982 where
= &pointer
->where
;
984 if (pointer
->expr_type
== EXPR_NULL
)
987 attr1
= gfc_expr_attr (pointer
);
989 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
991 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
992 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
998 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
1000 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1001 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
1002 gfc_current_intrinsic
, &pointer
->where
);
1006 /* Target argument is optional. */
1010 where
= &target
->where
;
1011 if (target
->expr_type
== EXPR_NULL
)
1014 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
1015 attr2
= gfc_expr_attr (target
);
1018 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1019 "or target VARIABLE or FUNCTION",
1020 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1025 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
1027 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1028 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
1029 gfc_current_intrinsic
, &target
->where
);
1034 if (attr1
.pointer
&& gfc_is_coindexed (target
))
1036 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1037 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1038 gfc_current_intrinsic
, &target
->where
);
1043 if (!same_type_check (pointer
, 0, target
, 1, true))
1045 if (!rank_check (target
, 0, pointer
->rank
))
1047 if (target
->rank
> 0)
1049 for (i
= 0; i
< target
->rank
; i
++)
1050 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1052 gfc_error ("Array section with a vector subscript at %L shall not "
1053 "be the target of a pointer",
1063 gfc_error ("NULL pointer at %L is not permitted as actual argument "
1064 "of %qs intrinsic function", where
, gfc_current_intrinsic
);
1071 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1073 /* gfc_notify_std would be a waste of time as the return value
1074 is seemingly used only for the generic resolution. The error
1075 will be: Too many arguments. */
1076 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1079 return gfc_check_atan2 (y
, x
);
1084 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1086 if (!type_check (y
, 0, BT_REAL
))
1088 if (!same_type_check (y
, 0, x
, 1))
1096 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1097 gfc_expr
*stat
, int stat_no
)
1099 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1102 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1103 && !(atom
->ts
.type
== BT_LOGICAL
1104 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1106 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1107 "integer of ATOMIC_INT_KIND or a logical of "
1108 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1112 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1114 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1115 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1119 if (atom
->ts
.type
!= value
->ts
.type
)
1121 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1122 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1123 gfc_current_intrinsic
, &value
->where
,
1124 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1130 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1132 if (!scalar_check (stat
, stat_no
))
1134 if (!variable_check (stat
, stat_no
, false))
1136 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1139 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1140 gfc_current_intrinsic
, &stat
->where
))
1149 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1151 if (atom
->expr_type
== EXPR_FUNCTION
1152 && atom
->value
.function
.isym
1153 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1154 atom
= atom
->value
.function
.actual
->expr
;
1156 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1158 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1159 "definable", gfc_current_intrinsic
, &atom
->where
);
1163 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1168 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1170 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1172 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1173 "integer of ATOMIC_INT_KIND", &atom
->where
,
1174 gfc_current_intrinsic
);
1178 return gfc_check_atomic_def (atom
, value
, stat
);
1183 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1185 if (atom
->expr_type
== EXPR_FUNCTION
1186 && atom
->value
.function
.isym
1187 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1188 atom
= atom
->value
.function
.actual
->expr
;
1190 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1192 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1193 "definable", gfc_current_intrinsic
, &value
->where
);
1197 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1202 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1204 /* IMAGE has to be a positive, scalar integer. */
1205 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1206 || !positive_check (0, image
))
1211 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1212 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1221 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1225 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1226 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1235 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1236 || !positive_check (1, kind
))
1239 /* Get the kind, reporting error on non-constant or overflow. */
1240 gfc_current_locus
= kind
->where
;
1241 if (gfc_extract_int (kind
, &k
, 1))
1243 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1245 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1246 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1247 gfc_current_intrinsic
, &kind
->where
);
1256 gfc_check_get_team (gfc_expr
*level
)
1260 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1261 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1270 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1271 gfc_expr
*new_val
, gfc_expr
*stat
)
1273 if (atom
->expr_type
== EXPR_FUNCTION
1274 && atom
->value
.function
.isym
1275 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1276 atom
= atom
->value
.function
.actual
->expr
;
1278 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1281 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1284 if (!same_type_check (atom
, 0, old
, 1))
1287 if (!same_type_check (atom
, 0, compare
, 2))
1290 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1292 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1293 "definable", gfc_current_intrinsic
, &atom
->where
);
1297 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1299 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1300 "definable", gfc_current_intrinsic
, &old
->where
);
1308 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1310 if (event
->ts
.type
!= BT_DERIVED
1311 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1312 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1314 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1315 "shall be of type EVENT_TYPE", &event
->where
);
1319 if (!scalar_check (event
, 0))
1322 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1324 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1325 "shall be definable", &count
->where
);
1329 if (!type_check (count
, 1, BT_INTEGER
))
1332 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1333 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1335 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1337 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1338 "shall have at least the range of the default integer",
1345 if (!type_check (stat
, 2, BT_INTEGER
))
1347 if (!scalar_check (stat
, 2))
1349 if (!variable_check (stat
, 2, false))
1352 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1353 gfc_current_intrinsic
, &stat
->where
))
1362 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1365 if (atom
->expr_type
== EXPR_FUNCTION
1366 && atom
->value
.function
.isym
1367 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1368 atom
= atom
->value
.function
.actual
->expr
;
1370 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1372 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1373 "integer of ATOMIC_INT_KIND", &atom
->where
,
1374 gfc_current_intrinsic
);
1378 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1381 if (!scalar_check (old
, 2))
1384 if (!same_type_check (atom
, 0, old
, 2))
1387 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1389 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1390 "definable", gfc_current_intrinsic
, &atom
->where
);
1394 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1396 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1397 "definable", gfc_current_intrinsic
, &old
->where
);
1405 /* BESJN and BESYN functions. */
1408 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1410 if (!type_check (n
, 0, BT_INTEGER
))
1412 if (n
->expr_type
== EXPR_CONSTANT
)
1415 gfc_extract_int (n
, &i
);
1416 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1417 "N at %L", &n
->where
))
1421 if (!type_check (x
, 1, BT_REAL
))
1428 /* Transformational version of the Bessel JN and YN functions. */
1431 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1433 if (!type_check (n1
, 0, BT_INTEGER
))
1435 if (!scalar_check (n1
, 0))
1437 if (!nonnegative_check ("N1", n1
))
1440 if (!type_check (n2
, 1, BT_INTEGER
))
1442 if (!scalar_check (n2
, 1))
1444 if (!nonnegative_check ("N2", n2
))
1447 if (!type_check (x
, 2, BT_REAL
))
1449 if (!scalar_check (x
, 2))
1457 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1459 if (!type_check (i
, 0, BT_INTEGER
))
1462 if (!type_check (j
, 1, BT_INTEGER
))
1470 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1472 if (!type_check (i
, 0, BT_INTEGER
))
1475 if (!type_check (pos
, 1, BT_INTEGER
))
1478 if (!nonnegative_check ("pos", pos
))
1481 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1489 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1491 if (!type_check (i
, 0, BT_INTEGER
))
1493 if (!kind_check (kind
, 1, BT_CHARACTER
))
1501 gfc_check_chdir (gfc_expr
*dir
)
1503 if (!type_check (dir
, 0, BT_CHARACTER
))
1505 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1513 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1515 if (!type_check (dir
, 0, BT_CHARACTER
))
1517 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1523 if (!type_check (status
, 1, BT_INTEGER
))
1525 if (!scalar_check (status
, 1))
1533 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1535 if (!type_check (name
, 0, BT_CHARACTER
))
1537 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1540 if (!type_check (mode
, 1, BT_CHARACTER
))
1542 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1550 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1552 if (!type_check (name
, 0, BT_CHARACTER
))
1554 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1557 if (!type_check (mode
, 1, BT_CHARACTER
))
1559 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1565 if (!type_check (status
, 2, BT_INTEGER
))
1568 if (!scalar_check (status
, 2))
1576 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1578 if (!numeric_check (x
, 0))
1583 if (!numeric_check (y
, 1))
1586 if (x
->ts
.type
== BT_COMPLEX
)
1588 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1589 "present if %<x%> is COMPLEX",
1590 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1595 if (y
->ts
.type
== BT_COMPLEX
)
1597 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1598 "of either REAL or INTEGER",
1599 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1606 if (!kind_check (kind
, 2, BT_COMPLEX
))
1609 if (!kind
&& warn_conversion
1610 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1611 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1612 "COMPLEX(%d) at %L might lose precision, consider using "
1613 "the KIND argument", gfc_typename (&x
->ts
),
1614 gfc_default_real_kind
, &x
->where
);
1615 else if (y
&& !kind
&& warn_conversion
1616 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1617 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1618 "COMPLEX(%d) at %L might lose precision, consider using "
1619 "the KIND argument", gfc_typename (&y
->ts
),
1620 gfc_default_real_kind
, &y
->where
);
1626 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1627 gfc_expr
*errmsg
, bool co_reduce
)
1629 if (!variable_check (a
, 0, false))
1632 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1636 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1637 if (gfc_has_vector_subscript (a
))
1639 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1640 "subroutine %s shall not have a vector subscript",
1641 &a
->where
, gfc_current_intrinsic
);
1645 if (gfc_is_coindexed (a
))
1647 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1648 "coindexed", &a
->where
, gfc_current_intrinsic
);
1652 if (image_idx
!= NULL
)
1654 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1656 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1662 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1664 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1666 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1668 if (stat
->ts
.kind
!= 4)
1670 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1671 "variable", &stat
->where
);
1678 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1680 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1682 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1684 if (errmsg
->ts
.kind
!= 1)
1686 gfc_error ("The errmsg= argument at %L must be a default-kind "
1687 "character variable", &errmsg
->where
);
1692 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1694 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1704 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1707 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1709 gfc_error ("Support for the A argument at %L which is polymorphic A "
1710 "argument or has allocatable components is not yet "
1711 "implemented", &a
->where
);
1714 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1719 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1720 gfc_expr
*stat
, gfc_expr
*errmsg
)
1722 symbol_attribute attr
;
1723 gfc_formal_arglist
*formal
;
1726 if (a
->ts
.type
== BT_CLASS
)
1728 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1733 if (gfc_expr_attr (a
).alloc_comp
)
1735 gfc_error ("Support for the A argument at %L with allocatable components"
1736 " is not yet implemented", &a
->where
);
1740 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1743 if (!gfc_resolve_expr (op
))
1746 attr
= gfc_expr_attr (op
);
1747 if (!attr
.pure
|| !attr
.function
)
1749 gfc_error ("OPERATOR argument at %L must be a PURE function",
1756 /* None of the intrinsics fulfills the criteria of taking two arguments,
1757 returning the same type and kind as the arguments and being permitted
1758 as actual argument. */
1759 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1760 op
->symtree
->n
.sym
->name
, &op
->where
);
1764 if (gfc_is_proc_ptr_comp (op
))
1766 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1767 sym
= comp
->ts
.interface
;
1770 sym
= op
->symtree
->n
.sym
;
1772 formal
= sym
->formal
;
1774 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1776 gfc_error ("The function passed as OPERATOR at %L shall have two "
1777 "arguments", &op
->where
);
1781 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1782 gfc_set_default_type (sym
->result
, 0, NULL
);
1784 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1786 gfc_error ("The A argument at %L has type %s but the function passed as "
1787 "OPERATOR at %L returns %s",
1788 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1789 gfc_typename (&sym
->result
->ts
));
1792 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1793 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1795 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1796 "%s and %s but shall have type %s", &op
->where
,
1797 gfc_typename (&formal
->sym
->ts
),
1798 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1801 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1802 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1803 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1804 || formal
->next
->sym
->attr
.pointer
)
1806 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1807 "nonallocatable nonpointer arguments and return a "
1808 "nonallocatable nonpointer scalar", &op
->where
);
1812 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1814 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1815 "attribute either for none or both arguments", &op
->where
);
1819 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1821 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1822 "attribute either for none or both arguments", &op
->where
);
1826 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1828 gfc_error ("The function passed as OPERATOR at %L shall have the "
1829 "ASYNCHRONOUS attribute either for none or both arguments",
1834 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1836 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1837 "OPTIONAL attribute for either of the arguments", &op
->where
);
1841 if (a
->ts
.type
== BT_CHARACTER
)
1844 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1847 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1848 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1850 cl
= formal
->sym
->ts
.u
.cl
;
1851 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1852 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1854 cl
= formal
->next
->sym
->ts
.u
.cl
;
1855 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1856 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1859 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1860 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1863 && ((formal_size1
&& actual_size
!= formal_size1
)
1864 || (formal_size2
&& actual_size
!= formal_size2
)))
1866 gfc_error ("The character length of the A argument at %L and of the "
1867 "arguments of the OPERATOR at %L shall be the same",
1868 &a
->where
, &op
->where
);
1871 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1873 gfc_error ("The character length of the A argument at %L and of the "
1874 "function result of the OPERATOR at %L shall be the same",
1875 &a
->where
, &op
->where
);
1885 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1888 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1889 && a
->ts
.type
!= BT_CHARACTER
)
1891 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1892 "integer, real or character",
1893 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1897 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1902 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1905 if (!numeric_check (a
, 0))
1907 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1912 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1914 if (!int_or_real_check (x
, 0))
1916 if (!scalar_check (x
, 0))
1919 if (!int_or_real_check (y
, 1))
1921 if (!scalar_check (y
, 1))
1929 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1931 if (!logical_array_check (mask
, 0))
1933 if (!dim_check (dim
, 1, false))
1935 if (!dim_rank_check (dim
, mask
, 0))
1937 if (!kind_check (kind
, 2, BT_INTEGER
))
1939 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1940 "with KIND argument at %L",
1941 gfc_current_intrinsic
, &kind
->where
))
1949 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1951 if (!array_check (array
, 0))
1954 if (!type_check (shift
, 1, BT_INTEGER
))
1957 if (!dim_check (dim
, 2, true))
1960 if (!dim_rank_check (dim
, array
, false))
1963 if (array
->rank
== 1 || shift
->rank
== 0)
1965 if (!scalar_check (shift
, 1))
1968 else if (shift
->rank
== array
->rank
- 1)
1973 else if (dim
->expr_type
== EXPR_CONSTANT
)
1974 gfc_extract_int (dim
, &d
);
1981 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1984 if (!identical_dimen_shape (array
, i
, shift
, j
))
1986 gfc_error ("%qs argument of %qs intrinsic at %L has "
1987 "invalid shape in dimension %d (%ld/%ld)",
1988 gfc_current_intrinsic_arg
[1]->name
,
1989 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1990 mpz_get_si (array
->shape
[i
]),
1991 mpz_get_si (shift
->shape
[j
]));
2001 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2002 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2003 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2012 gfc_check_ctime (gfc_expr
*time
)
2014 if (!scalar_check (time
, 0))
2017 if (!type_check (time
, 0, BT_INTEGER
))
2024 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2026 if (!double_check (y
, 0) || !double_check (x
, 1))
2033 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2035 if (!numeric_check (x
, 0))
2040 if (!numeric_check (y
, 1))
2043 if (x
->ts
.type
== BT_COMPLEX
)
2045 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2046 "present if %<x%> is COMPLEX",
2047 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2052 if (y
->ts
.type
== BT_COMPLEX
)
2054 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2055 "of either REAL or INTEGER",
2056 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2067 gfc_check_dble (gfc_expr
*x
)
2069 if (!numeric_check (x
, 0))
2077 gfc_check_digits (gfc_expr
*x
)
2079 if (!int_or_real_check (x
, 0))
2087 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2089 switch (vector_a
->ts
.type
)
2092 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2099 if (!numeric_check (vector_b
, 1))
2104 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2105 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2106 gfc_current_intrinsic
, &vector_a
->where
);
2110 if (!rank_check (vector_a
, 0, 1))
2113 if (!rank_check (vector_b
, 1, 1))
2116 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2118 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2119 "intrinsic %<dot_product%>",
2120 gfc_current_intrinsic_arg
[0]->name
,
2121 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2130 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2132 if (!type_check (x
, 0, BT_REAL
)
2133 || !type_check (y
, 1, BT_REAL
))
2136 if (x
->ts
.kind
!= gfc_default_real_kind
)
2138 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2139 "real", gfc_current_intrinsic_arg
[0]->name
,
2140 gfc_current_intrinsic
, &x
->where
);
2144 if (y
->ts
.kind
!= gfc_default_real_kind
)
2146 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2147 "real", gfc_current_intrinsic_arg
[1]->name
,
2148 gfc_current_intrinsic
, &y
->where
);
2157 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2159 if (!type_check (i
, 0, BT_INTEGER
))
2162 if (!type_check (j
, 1, BT_INTEGER
))
2165 if (i
->is_boz
&& j
->is_boz
)
2167 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2168 "constants", &i
->where
, &j
->where
);
2172 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
2175 if (!type_check (shift
, 2, BT_INTEGER
))
2178 if (!nonnegative_check ("SHIFT", shift
))
2183 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
2185 i
->ts
.kind
= j
->ts
.kind
;
2189 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2191 j
->ts
.kind
= i
->ts
.kind
;
2199 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2204 if (!array_check (array
, 0))
2207 if (!type_check (shift
, 1, BT_INTEGER
))
2210 if (!dim_check (dim
, 3, true))
2213 if (!dim_rank_check (dim
, array
, false))
2218 else if (dim
->expr_type
== EXPR_CONSTANT
)
2219 gfc_extract_int (dim
, &d
);
2223 if (array
->rank
== 1 || shift
->rank
== 0)
2225 if (!scalar_check (shift
, 1))
2228 else if (shift
->rank
== array
->rank
- 1)
2233 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2236 if (!identical_dimen_shape (array
, i
, shift
, j
))
2238 gfc_error ("%qs argument of %qs intrinsic at %L has "
2239 "invalid shape in dimension %d (%ld/%ld)",
2240 gfc_current_intrinsic_arg
[1]->name
,
2241 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2242 mpz_get_si (array
->shape
[i
]),
2243 mpz_get_si (shift
->shape
[j
]));
2253 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2254 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2255 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2259 if (boundary
!= NULL
)
2261 if (!same_type_check (array
, 0, boundary
, 2))
2264 /* Reject unequal string lengths and emit a better error message than
2265 gfc_check_same_strlen would. */
2266 if (array
->ts
.type
== BT_CHARACTER
)
2268 ssize_t len_a
, len_b
;
2270 len_a
= gfc_var_strlen (array
);
2271 len_b
= gfc_var_strlen (boundary
);
2272 if (len_a
!= -1 && len_b
!= -1 && len_a
!= len_b
)
2274 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2275 gfc_current_intrinsic_arg
[2]->name
,
2276 gfc_current_intrinsic_arg
[0]->name
,
2277 &boundary
->where
, gfc_current_intrinsic
);
2282 if (array
->rank
== 1 || boundary
->rank
== 0)
2284 if (!scalar_check (boundary
, 2))
2287 else if (boundary
->rank
== array
->rank
- 1)
2292 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2296 if (!identical_dimen_shape (array
, i
, boundary
, j
))
2298 gfc_error ("%qs argument of %qs intrinsic at %L has "
2299 "invalid shape in dimension %d (%ld/%ld)",
2300 gfc_current_intrinsic_arg
[2]->name
,
2301 gfc_current_intrinsic
, &shift
->where
, i
+1,
2302 mpz_get_si (array
->shape
[i
]),
2303 mpz_get_si (boundary
->shape
[j
]));
2313 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2314 "rank %d or be a scalar",
2315 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2316 &shift
->where
, array
->rank
- 1);
2322 switch (array
->ts
.type
)
2332 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2333 "of type %qs", gfc_current_intrinsic_arg
[2]->name
,
2334 gfc_current_intrinsic
, &array
->where
,
2335 gfc_current_intrinsic_arg
[0]->name
,
2336 gfc_typename (&array
->ts
));
2345 gfc_check_float (gfc_expr
*a
)
2347 if (!type_check (a
, 0, BT_INTEGER
))
2350 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2351 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2352 "kind argument to %s intrinsic at %L",
2353 gfc_current_intrinsic
, &a
->where
))
2359 /* A single complex argument. */
2362 gfc_check_fn_c (gfc_expr
*a
)
2364 if (!type_check (a
, 0, BT_COMPLEX
))
2371 /* A single real argument. */
2374 gfc_check_fn_r (gfc_expr
*a
)
2376 if (!type_check (a
, 0, BT_REAL
))
2382 /* A single double argument. */
2385 gfc_check_fn_d (gfc_expr
*a
)
2387 if (!double_check (a
, 0))
2393 /* A single real or complex argument. */
2396 gfc_check_fn_rc (gfc_expr
*a
)
2398 if (!real_or_complex_check (a
, 0))
2406 gfc_check_fn_rc2008 (gfc_expr
*a
)
2408 if (!real_or_complex_check (a
, 0))
2411 if (a
->ts
.type
== BT_COMPLEX
2412 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2413 "of %qs intrinsic at %L",
2414 gfc_current_intrinsic_arg
[0]->name
,
2415 gfc_current_intrinsic
, &a
->where
))
2423 gfc_check_fnum (gfc_expr
*unit
)
2425 if (!type_check (unit
, 0, BT_INTEGER
))
2428 if (!scalar_check (unit
, 0))
2436 gfc_check_huge (gfc_expr
*x
)
2438 if (!int_or_real_check (x
, 0))
2446 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2448 if (!type_check (x
, 0, BT_REAL
))
2450 if (!same_type_check (x
, 0, y
, 1))
2457 /* Check that the single argument is an integer. */
2460 gfc_check_i (gfc_expr
*i
)
2462 if (!type_check (i
, 0, BT_INTEGER
))
2470 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2472 if (!type_check (i
, 0, BT_INTEGER
))
2475 if (!type_check (j
, 1, BT_INTEGER
))
2478 if (i
->ts
.kind
!= j
->ts
.kind
)
2480 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2490 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2492 if (!type_check (i
, 0, BT_INTEGER
))
2495 if (!type_check (pos
, 1, BT_INTEGER
))
2498 if (!type_check (len
, 2, BT_INTEGER
))
2501 if (!nonnegative_check ("pos", pos
))
2504 if (!nonnegative_check ("len", len
))
2507 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2515 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2519 if (!type_check (c
, 0, BT_CHARACTER
))
2522 if (!kind_check (kind
, 1, BT_INTEGER
))
2525 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2526 "with KIND argument at %L",
2527 gfc_current_intrinsic
, &kind
->where
))
2530 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2536 /* Substring references don't have the charlength set. */
2538 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2541 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2545 /* Check that the argument is length one. Non-constant lengths
2546 can't be checked here, so assume they are ok. */
2547 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2549 /* If we already have a length for this expression then use it. */
2550 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2552 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2559 start
= ref
->u
.ss
.start
;
2560 end
= ref
->u
.ss
.end
;
2563 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2564 || start
->expr_type
!= EXPR_CONSTANT
)
2567 i
= mpz_get_si (end
->value
.integer
) + 1
2568 - mpz_get_si (start
->value
.integer
);
2576 gfc_error ("Argument of %s at %L must be of length one",
2577 gfc_current_intrinsic
, &c
->where
);
2586 gfc_check_idnint (gfc_expr
*a
)
2588 if (!double_check (a
, 0))
2596 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2598 if (!type_check (i
, 0, BT_INTEGER
))
2601 if (!type_check (j
, 1, BT_INTEGER
))
2604 if (i
->ts
.kind
!= j
->ts
.kind
)
2606 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2616 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2619 if (!type_check (string
, 0, BT_CHARACTER
)
2620 || !type_check (substring
, 1, BT_CHARACTER
))
2623 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2626 if (!kind_check (kind
, 3, BT_INTEGER
))
2628 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2629 "with KIND argument at %L",
2630 gfc_current_intrinsic
, &kind
->where
))
2633 if (string
->ts
.kind
!= substring
->ts
.kind
)
2635 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2636 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2637 gfc_current_intrinsic
, &substring
->where
,
2638 gfc_current_intrinsic_arg
[0]->name
);
2647 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2649 if (!numeric_check (x
, 0))
2652 if (!kind_check (kind
, 1, BT_INTEGER
))
2660 gfc_check_intconv (gfc_expr
*x
)
2662 if (!numeric_check (x
, 0))
2670 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2672 if (!type_check (i
, 0, BT_INTEGER
))
2675 if (!type_check (j
, 1, BT_INTEGER
))
2678 if (i
->ts
.kind
!= j
->ts
.kind
)
2680 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2690 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2692 if (!type_check (i
, 0, BT_INTEGER
)
2693 || !type_check (shift
, 1, BT_INTEGER
))
2696 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2704 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2706 if (!type_check (i
, 0, BT_INTEGER
)
2707 || !type_check (shift
, 1, BT_INTEGER
))
2714 if (!type_check (size
, 2, BT_INTEGER
))
2717 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2720 if (size
->expr_type
== EXPR_CONSTANT
)
2722 gfc_extract_int (size
, &i3
);
2725 gfc_error ("SIZE at %L must be positive", &size
->where
);
2729 if (shift
->expr_type
== EXPR_CONSTANT
)
2731 gfc_extract_int (shift
, &i2
);
2737 gfc_error ("The absolute value of SHIFT at %L must be less "
2738 "than or equal to SIZE at %L", &shift
->where
,
2745 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2753 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2755 if (!type_check (pid
, 0, BT_INTEGER
))
2758 if (!type_check (sig
, 1, BT_INTEGER
))
2766 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2768 if (!type_check (pid
, 0, BT_INTEGER
))
2771 if (!scalar_check (pid
, 0))
2774 if (!type_check (sig
, 1, BT_INTEGER
))
2777 if (!scalar_check (sig
, 1))
2783 if (!type_check (status
, 2, BT_INTEGER
))
2786 if (!scalar_check (status
, 2))
2794 gfc_check_kind (gfc_expr
*x
)
2796 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
2798 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2799 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2800 gfc_current_intrinsic
, &x
->where
);
2803 if (x
->ts
.type
== BT_PROCEDURE
)
2805 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2806 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2816 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2818 if (!array_check (array
, 0))
2821 if (!dim_check (dim
, 1, false))
2824 if (!dim_rank_check (dim
, array
, 1))
2827 if (!kind_check (kind
, 2, BT_INTEGER
))
2829 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2830 "with KIND argument at %L",
2831 gfc_current_intrinsic
, &kind
->where
))
2839 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2841 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2843 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2847 if (!coarray_check (coarray
, 0))
2852 if (!dim_check (dim
, 1, false))
2855 if (!dim_corank_check (dim
, coarray
))
2859 if (!kind_check (kind
, 2, BT_INTEGER
))
2867 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2869 if (!type_check (s
, 0, BT_CHARACTER
))
2872 if (!kind_check (kind
, 1, BT_INTEGER
))
2874 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2875 "with KIND argument at %L",
2876 gfc_current_intrinsic
, &kind
->where
))
2884 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2886 if (!type_check (a
, 0, BT_CHARACTER
))
2888 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2891 if (!type_check (b
, 1, BT_CHARACTER
))
2893 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2901 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2903 if (!type_check (path1
, 0, BT_CHARACTER
))
2905 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2908 if (!type_check (path2
, 1, BT_CHARACTER
))
2910 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2918 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2920 if (!type_check (path1
, 0, BT_CHARACTER
))
2922 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2925 if (!type_check (path2
, 1, BT_CHARACTER
))
2927 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2933 if (!type_check (status
, 2, BT_INTEGER
))
2936 if (!scalar_check (status
, 2))
2944 gfc_check_loc (gfc_expr
*expr
)
2946 return variable_check (expr
, 0, true);
2951 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2953 if (!type_check (path1
, 0, BT_CHARACTER
))
2955 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2958 if (!type_check (path2
, 1, BT_CHARACTER
))
2960 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2968 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2970 if (!type_check (path1
, 0, BT_CHARACTER
))
2972 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2975 if (!type_check (path2
, 1, BT_CHARACTER
))
2977 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2983 if (!type_check (status
, 2, BT_INTEGER
))
2986 if (!scalar_check (status
, 2))
2994 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2996 if (!type_check (a
, 0, BT_LOGICAL
))
2998 if (!kind_check (kind
, 1, BT_LOGICAL
))
3005 /* Min/max family. */
3008 min_max_args (gfc_actual_arglist
*args
)
3010 gfc_actual_arglist
*arg
;
3011 int i
, j
, nargs
, *nlabels
, nlabelless
;
3012 bool a1
= false, a2
= false;
3014 if (args
== NULL
|| args
->next
== NULL
)
3016 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3017 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
3024 if (!args
->next
->name
)
3028 for (arg
= args
; arg
; arg
= arg
->next
)
3035 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3037 nlabels
= XALLOCAVEC (int, nargs
);
3038 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
3044 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
3046 n
= strtol (&arg
->name
[1], &endp
, 10);
3047 if (endp
[0] != '\0')
3051 if (n
<= nlabelless
)
3064 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3065 !a1
? "a1" : "a2", gfc_current_intrinsic
,
3066 gfc_current_intrinsic_where
);
3070 /* Check for duplicates. */
3071 for (i
= 0; i
< nargs
; i
++)
3072 for (j
= i
+ 1; j
< nargs
; j
++)
3073 if (nlabels
[i
] == nlabels
[j
])
3079 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3080 &arg
->expr
->where
, gfc_current_intrinsic
);
3084 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3085 &arg
->expr
->where
, gfc_current_intrinsic
);
3091 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3093 gfc_actual_arglist
*arg
, *tmp
;
3097 if (!min_max_args (arglist
))
3100 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3103 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3105 if (x
->ts
.type
== type
)
3107 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3108 "kinds at %L", &x
->where
))
3113 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3114 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3115 gfc_basic_typename (type
), kind
);
3120 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3121 if (!gfc_check_conformance (tmp
->expr
, x
,
3122 "arguments 'a%d' and 'a%d' for "
3123 "intrinsic '%s'", m
, n
,
3124 gfc_current_intrinsic
))
3133 gfc_check_min_max (gfc_actual_arglist
*arg
)
3137 if (!min_max_args (arg
))
3142 if (x
->ts
.type
== BT_CHARACTER
)
3144 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3145 "with CHARACTER argument at %L",
3146 gfc_current_intrinsic
, &x
->where
))
3149 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3151 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3152 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3156 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3161 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3163 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3168 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3170 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3175 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3177 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3181 /* End of min/max family. */
3184 gfc_check_malloc (gfc_expr
*size
)
3186 if (!type_check (size
, 0, BT_INTEGER
))
3189 if (!scalar_check (size
, 0))
3197 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3199 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3201 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3202 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3203 gfc_current_intrinsic
, &matrix_a
->where
);
3207 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3209 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3210 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3211 gfc_current_intrinsic
, &matrix_b
->where
);
3215 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3216 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3218 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3219 gfc_current_intrinsic
, &matrix_a
->where
,
3220 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3224 switch (matrix_a
->rank
)
3227 if (!rank_check (matrix_b
, 1, 2))
3229 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3230 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3232 gfc_error ("Different shape on dimension 1 for arguments %qs "
3233 "and %qs at %L for intrinsic matmul",
3234 gfc_current_intrinsic_arg
[0]->name
,
3235 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3241 if (matrix_b
->rank
!= 2)
3243 if (!rank_check (matrix_b
, 1, 1))
3246 /* matrix_b has rank 1 or 2 here. Common check for the cases
3247 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3248 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3249 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3251 gfc_error ("Different shape on dimension 2 for argument %qs and "
3252 "dimension 1 for argument %qs at %L for intrinsic "
3253 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3254 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3260 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3261 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3262 gfc_current_intrinsic
, &matrix_a
->where
);
3270 /* Whoever came up with this interface was probably on something.
3271 The possibilities for the occupation of the second and third
3278 NULL MASK minloc(array, mask=m)
3281 I.e. in the case of minloc(array,mask), mask will be in the second
3282 position of the argument list and we'll have to fix that up. Also,
3283 add the BACK argument if that isn't present. */
3286 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3288 gfc_expr
*a
, *m
, *d
, *k
, *b
;
3291 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3295 m
= ap
->next
->next
->expr
;
3296 k
= ap
->next
->next
->next
->expr
;
3297 b
= ap
->next
->next
->next
->next
->expr
;
3301 if (!type_check (b
, 4, BT_LOGICAL
) || !scalar_check (b
,4))
3304 /* TODO: Remove this once BACK is actually implemented. */
3305 if (b
->expr_type
!= EXPR_CONSTANT
|| b
->value
.logical
!= 0)
3307 gfc_error ("BACK argument to %qs intrinsic not yet "
3308 "implemented", gfc_current_intrinsic
);
3314 b
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, 0);
3315 ap
->next
->next
->next
->next
->expr
= b
;
3318 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3319 && ap
->next
->name
== NULL
)
3323 ap
->next
->expr
= NULL
;
3324 ap
->next
->next
->expr
= m
;
3327 if (!dim_check (d
, 1, false))
3330 if (!dim_rank_check (d
, a
, 0))
3333 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3337 && !gfc_check_conformance (a
, m
,
3338 "arguments '%s' and '%s' for intrinsic %s",
3339 gfc_current_intrinsic_arg
[0]->name
,
3340 gfc_current_intrinsic_arg
[2]->name
,
3341 gfc_current_intrinsic
))
3344 if (!kind_check (k
, 1, BT_INTEGER
))
3351 /* Similar to minloc/maxloc, the argument list might need to be
3352 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3353 difference is that MINLOC/MAXLOC take an additional KIND argument.
3354 The possibilities are:
3360 NULL MASK minval(array, mask=m)
3363 I.e. in the case of minval(array,mask), mask will be in the second
3364 position of the argument list and we'll have to fix that up. */
3367 check_reduction (gfc_actual_arglist
*ap
)
3369 gfc_expr
*a
, *m
, *d
;
3373 m
= ap
->next
->next
->expr
;
3375 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3376 && ap
->next
->name
== NULL
)
3380 ap
->next
->expr
= NULL
;
3381 ap
->next
->next
->expr
= m
;
3384 if (!dim_check (d
, 1, false))
3387 if (!dim_rank_check (d
, a
, 0))
3390 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3394 && !gfc_check_conformance (a
, m
,
3395 "arguments '%s' and '%s' for intrinsic %s",
3396 gfc_current_intrinsic_arg
[0]->name
,
3397 gfc_current_intrinsic_arg
[2]->name
,
3398 gfc_current_intrinsic
))
3406 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3408 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
3409 || !array_check (ap
->expr
, 0))
3412 return check_reduction (ap
);
3417 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3419 if (!numeric_check (ap
->expr
, 0)
3420 || !array_check (ap
->expr
, 0))
3423 return check_reduction (ap
);
3427 /* For IANY, IALL and IPARITY. */
3430 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3434 if (!type_check (i
, 0, BT_INTEGER
))
3437 if (!nonnegative_check ("I", i
))
3440 if (!kind_check (kind
, 1, BT_INTEGER
))
3444 gfc_extract_int (kind
, &k
);
3446 k
= gfc_default_integer_kind
;
3448 if (!less_than_bitsizekind ("I", i
, k
))
3456 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3458 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3460 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3461 gfc_current_intrinsic_arg
[0]->name
,
3462 gfc_current_intrinsic
, &ap
->expr
->where
);
3466 if (!array_check (ap
->expr
, 0))
3469 return check_reduction (ap
);
3474 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3476 if (!same_type_check (tsource
, 0, fsource
, 1))
3479 if (!type_check (mask
, 2, BT_LOGICAL
))
3482 if (tsource
->ts
.type
== BT_CHARACTER
)
3483 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3490 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3492 if (!type_check (i
, 0, BT_INTEGER
))
3495 if (!type_check (j
, 1, BT_INTEGER
))
3498 if (!type_check (mask
, 2, BT_INTEGER
))
3501 if (!same_type_check (i
, 0, j
, 1))
3504 if (!same_type_check (i
, 0, mask
, 2))
3512 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3514 if (!variable_check (from
, 0, false))
3516 if (!allocatable_check (from
, 0))
3518 if (gfc_is_coindexed (from
))
3520 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3521 "coindexed", &from
->where
);
3525 if (!variable_check (to
, 1, false))
3527 if (!allocatable_check (to
, 1))
3529 if (gfc_is_coindexed (to
))
3531 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3532 "coindexed", &to
->where
);
3536 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3538 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3539 "polymorphic if FROM is polymorphic",
3544 if (!same_type_check (to
, 1, from
, 0))
3547 if (to
->rank
!= from
->rank
)
3549 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3550 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3555 /* IR F08/0040; cf. 12-006A. */
3556 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3558 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3559 "must have the same corank %d/%d", &to
->where
,
3560 gfc_get_corank (from
), gfc_get_corank (to
));
3564 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3565 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3566 and cmp2 are allocatable. After the allocation is transferred,
3567 the 'to' chain is broken by the nullification of the 'from'. A bit
3568 of reflection reveals that this can only occur for derived types
3569 with recursive allocatable components. */
3570 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3571 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3573 gfc_ref
*to_ref
, *from_ref
;
3575 from_ref
= from
->ref
;
3576 bool aliasing
= true;
3578 for (; from_ref
&& to_ref
;
3579 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3581 if (to_ref
->type
!= from
->ref
->type
)
3583 else if (to_ref
->type
== REF_ARRAY
3584 && to_ref
->u
.ar
.type
!= AR_FULL
3585 && from_ref
->u
.ar
.type
!= AR_FULL
)
3586 /* Play safe; assume sections and elements are different. */
3588 else if (to_ref
->type
== REF_COMPONENT
3589 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3598 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3599 "restrictions (F2003 12.4.1.7)", &to
->where
);
3604 /* CLASS arguments: Make sure the vtab of from is present. */
3605 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3606 gfc_find_vtab (&from
->ts
);
3613 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3615 if (!type_check (x
, 0, BT_REAL
))
3618 if (!type_check (s
, 1, BT_REAL
))
3621 if (s
->expr_type
== EXPR_CONSTANT
)
3623 if (mpfr_sgn (s
->value
.real
) == 0)
3625 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3636 gfc_check_new_line (gfc_expr
*a
)
3638 if (!type_check (a
, 0, BT_CHARACTER
))
3646 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3648 if (!type_check (array
, 0, BT_REAL
))
3651 if (!array_check (array
, 0))
3654 if (!dim_rank_check (dim
, array
, false))
3661 gfc_check_null (gfc_expr
*mold
)
3663 symbol_attribute attr
;
3668 if (!variable_check (mold
, 0, true))
3671 attr
= gfc_variable_attr (mold
, NULL
);
3673 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3675 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3676 "ALLOCATABLE or procedure pointer",
3677 gfc_current_intrinsic_arg
[0]->name
,
3678 gfc_current_intrinsic
, &mold
->where
);
3682 if (attr
.allocatable
3683 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3684 "allocatable MOLD at %L", &mold
->where
))
3688 if (gfc_is_coindexed (mold
))
3690 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3691 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3692 gfc_current_intrinsic
, &mold
->where
);
3701 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3703 if (!array_check (array
, 0))
3706 if (!type_check (mask
, 1, BT_LOGICAL
))
3709 if (!gfc_check_conformance (array
, mask
,
3710 "arguments '%s' and '%s' for intrinsic '%s'",
3711 gfc_current_intrinsic_arg
[0]->name
,
3712 gfc_current_intrinsic_arg
[1]->name
,
3713 gfc_current_intrinsic
))
3718 mpz_t array_size
, vector_size
;
3719 bool have_array_size
, have_vector_size
;
3721 if (!same_type_check (array
, 0, vector
, 2))
3724 if (!rank_check (vector
, 2, 1))
3727 /* VECTOR requires at least as many elements as MASK
3728 has .TRUE. values. */
3729 have_array_size
= gfc_array_size(array
, &array_size
);
3730 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3732 if (have_vector_size
3733 && (mask
->expr_type
== EXPR_ARRAY
3734 || (mask
->expr_type
== EXPR_CONSTANT
3735 && have_array_size
)))
3737 int mask_true_values
= 0;
3739 if (mask
->expr_type
== EXPR_ARRAY
)
3741 gfc_constructor
*mask_ctor
;
3742 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3745 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3747 mask_true_values
= 0;
3751 if (mask_ctor
->expr
->value
.logical
)
3754 mask_ctor
= gfc_constructor_next (mask_ctor
);
3757 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3758 mask_true_values
= mpz_get_si (array_size
);
3760 if (mpz_get_si (vector_size
) < mask_true_values
)
3762 gfc_error ("%qs argument of %qs intrinsic at %L must "
3763 "provide at least as many elements as there "
3764 "are .TRUE. values in %qs (%ld/%d)",
3765 gfc_current_intrinsic_arg
[2]->name
,
3766 gfc_current_intrinsic
, &vector
->where
,
3767 gfc_current_intrinsic_arg
[1]->name
,
3768 mpz_get_si (vector_size
), mask_true_values
);
3773 if (have_array_size
)
3774 mpz_clear (array_size
);
3775 if (have_vector_size
)
3776 mpz_clear (vector_size
);
3784 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3786 if (!type_check (mask
, 0, BT_LOGICAL
))
3789 if (!array_check (mask
, 0))
3792 if (!dim_rank_check (dim
, mask
, false))
3800 gfc_check_precision (gfc_expr
*x
)
3802 if (!real_or_complex_check (x
, 0))
3810 gfc_check_present (gfc_expr
*a
)
3814 if (!variable_check (a
, 0, true))
3817 sym
= a
->symtree
->n
.sym
;
3818 if (!sym
->attr
.dummy
)
3820 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3821 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3822 gfc_current_intrinsic
, &a
->where
);
3826 if (!sym
->attr
.optional
)
3828 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3829 "an OPTIONAL dummy variable",
3830 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3835 /* 13.14.82 PRESENT(A)
3837 Argument. A shall be the name of an optional dummy argument that is
3838 accessible in the subprogram in which the PRESENT function reference
3842 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3843 && (a
->ref
->u
.ar
.type
== AR_FULL
3844 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3845 && a
->ref
->u
.ar
.as
->rank
== 0))))
3847 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3848 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3849 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3858 gfc_check_radix (gfc_expr
*x
)
3860 if (!int_or_real_check (x
, 0))
3868 gfc_check_range (gfc_expr
*x
)
3870 if (!numeric_check (x
, 0))
3878 gfc_check_rank (gfc_expr
*a
)
3880 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3881 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3883 bool is_variable
= true;
3885 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3886 if (a
->expr_type
== EXPR_FUNCTION
)
3887 is_variable
= a
->value
.function
.esym
3888 ? a
->value
.function
.esym
->result
->attr
.pointer
3889 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3891 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3892 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3895 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3896 "object", &a
->where
);
3904 /* real, float, sngl. */
3906 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3908 if (!numeric_check (a
, 0))
3911 if (!kind_check (kind
, 1, BT_REAL
))
3919 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3921 if (!type_check (path1
, 0, BT_CHARACTER
))
3923 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3926 if (!type_check (path2
, 1, BT_CHARACTER
))
3928 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3936 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3938 if (!type_check (path1
, 0, BT_CHARACTER
))
3940 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3943 if (!type_check (path2
, 1, BT_CHARACTER
))
3945 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3951 if (!type_check (status
, 2, BT_INTEGER
))
3954 if (!scalar_check (status
, 2))
3962 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3964 if (!type_check (x
, 0, BT_CHARACTER
))
3967 if (!scalar_check (x
, 0))
3970 if (!type_check (y
, 0, BT_INTEGER
))
3973 if (!scalar_check (y
, 1))
3981 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3982 gfc_expr
*pad
, gfc_expr
*order
)
3988 if (!array_check (source
, 0))
3991 if (!rank_check (shape
, 1, 1))
3994 if (!type_check (shape
, 1, BT_INTEGER
))
3997 if (!gfc_array_size (shape
, &size
))
3999 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4000 "array of constant size", &shape
->where
);
4004 shape_size
= mpz_get_ui (size
);
4007 if (shape_size
<= 0)
4009 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4010 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4014 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4016 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4017 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4020 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
4024 for (i
= 0; i
< shape_size
; ++i
)
4026 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4027 if (e
->expr_type
!= EXPR_CONSTANT
)
4030 gfc_extract_int (e
, &extent
);
4033 gfc_error ("%qs argument of %qs intrinsic at %L has "
4034 "negative element (%d)",
4035 gfc_current_intrinsic_arg
[1]->name
,
4036 gfc_current_intrinsic
, &e
->where
, extent
);
4041 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4042 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4043 && shape
->ref
->u
.ar
.as
4044 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4045 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4046 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4047 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4048 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4053 v
= shape
->symtree
->n
.sym
->value
;
4055 for (i
= 0; i
< shape_size
; i
++)
4057 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4061 gfc_extract_int (e
, &extent
);
4065 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4066 "cannot be negative", i
+ 1, &shape
->where
);
4074 if (!same_type_check (source
, 0, pad
, 2))
4077 if (!array_check (pad
, 2))
4083 if (!array_check (order
, 3))
4086 if (!type_check (order
, 3, BT_INTEGER
))
4089 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4091 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4094 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4097 gfc_array_size (order
, &size
);
4098 order_size
= mpz_get_ui (size
);
4101 if (order_size
!= shape_size
)
4103 gfc_error ("%qs argument of %qs intrinsic at %L "
4104 "has wrong number of elements (%d/%d)",
4105 gfc_current_intrinsic_arg
[3]->name
,
4106 gfc_current_intrinsic
, &order
->where
,
4107 order_size
, shape_size
);
4111 for (i
= 1; i
<= order_size
; ++i
)
4113 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4114 if (e
->expr_type
!= EXPR_CONSTANT
)
4117 gfc_extract_int (e
, &dim
);
4119 if (dim
< 1 || dim
> order_size
)
4121 gfc_error ("%qs argument of %qs intrinsic at %L "
4122 "has out-of-range dimension (%d)",
4123 gfc_current_intrinsic_arg
[3]->name
,
4124 gfc_current_intrinsic
, &e
->where
, dim
);
4128 if (perm
[dim
-1] != 0)
4130 gfc_error ("%qs argument of %qs intrinsic at %L has "
4131 "invalid permutation of dimensions (dimension "
4133 gfc_current_intrinsic_arg
[3]->name
,
4134 gfc_current_intrinsic
, &e
->where
, dim
);
4143 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4144 && gfc_is_constant_expr (shape
)
4145 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4146 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4148 /* Check the match in size between source and destination. */
4149 if (gfc_array_size (source
, &nelems
))
4155 mpz_init_set_ui (size
, 1);
4156 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4157 c
; c
= gfc_constructor_next (c
))
4158 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4160 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4166 gfc_error ("Without padding, there are not enough elements "
4167 "in the intrinsic RESHAPE source at %L to match "
4168 "the shape", &source
->where
);
4179 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4181 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4183 gfc_error ("%qs argument of %qs intrinsic at %L "
4184 "cannot be of type %s",
4185 gfc_current_intrinsic_arg
[0]->name
,
4186 gfc_current_intrinsic
,
4187 &a
->where
, gfc_typename (&a
->ts
));
4191 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4193 gfc_error ("%qs argument of %qs intrinsic at %L "
4194 "must be of an extensible type",
4195 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4200 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4202 gfc_error ("%qs argument of %qs intrinsic at %L "
4203 "cannot be of type %s",
4204 gfc_current_intrinsic_arg
[0]->name
,
4205 gfc_current_intrinsic
,
4206 &b
->where
, gfc_typename (&b
->ts
));
4210 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4212 gfc_error ("%qs argument of %qs intrinsic at %L "
4213 "must be of an extensible type",
4214 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4224 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4226 if (!type_check (x
, 0, BT_REAL
))
4229 if (!type_check (i
, 1, BT_INTEGER
))
4237 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4239 if (!type_check (x
, 0, BT_CHARACTER
))
4242 if (!type_check (y
, 1, BT_CHARACTER
))
4245 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4248 if (!kind_check (kind
, 3, BT_INTEGER
))
4250 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4251 "with KIND argument at %L",
4252 gfc_current_intrinsic
, &kind
->where
))
4255 if (!same_type_check (x
, 0, y
, 1))
4263 gfc_check_secnds (gfc_expr
*r
)
4265 if (!type_check (r
, 0, BT_REAL
))
4268 if (!kind_value_check (r
, 0, 4))
4271 if (!scalar_check (r
, 0))
4279 gfc_check_selected_char_kind (gfc_expr
*name
)
4281 if (!type_check (name
, 0, BT_CHARACTER
))
4284 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4287 if (!scalar_check (name
, 0))
4295 gfc_check_selected_int_kind (gfc_expr
*r
)
4297 if (!type_check (r
, 0, BT_INTEGER
))
4300 if (!scalar_check (r
, 0))
4308 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4310 if (p
== NULL
&& r
== NULL
4311 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4312 " neither %<P%> nor %<R%> argument at %L",
4313 gfc_current_intrinsic_where
))
4318 if (!type_check (p
, 0, BT_INTEGER
))
4321 if (!scalar_check (p
, 0))
4327 if (!type_check (r
, 1, BT_INTEGER
))
4330 if (!scalar_check (r
, 1))
4336 if (!type_check (radix
, 1, BT_INTEGER
))
4339 if (!scalar_check (radix
, 1))
4342 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4343 "RADIX argument at %L", gfc_current_intrinsic
,
4353 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4355 if (!type_check (x
, 0, BT_REAL
))
4358 if (!type_check (i
, 1, BT_INTEGER
))
4366 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4370 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4373 ar
= gfc_find_array_ref (source
);
4375 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4377 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4378 "an assumed size array", &source
->where
);
4382 if (!kind_check (kind
, 1, BT_INTEGER
))
4384 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4385 "with KIND argument at %L",
4386 gfc_current_intrinsic
, &kind
->where
))
4394 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4396 if (!type_check (i
, 0, BT_INTEGER
))
4399 if (!type_check (shift
, 0, BT_INTEGER
))
4402 if (!nonnegative_check ("SHIFT", shift
))
4405 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4413 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4415 if (!int_or_real_check (a
, 0))
4418 if (!same_type_check (a
, 0, b
, 1))
4426 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4428 if (!array_check (array
, 0))
4431 if (!dim_check (dim
, 1, true))
4434 if (!dim_rank_check (dim
, array
, 0))
4437 if (!kind_check (kind
, 2, BT_INTEGER
))
4439 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4440 "with KIND argument at %L",
4441 gfc_current_intrinsic
, &kind
->where
))
4450 gfc_check_sizeof (gfc_expr
*arg
)
4452 if (arg
->ts
.type
== BT_PROCEDURE
)
4454 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4455 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4460 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4461 if (arg
->ts
.type
== BT_ASSUMED
4462 && (arg
->symtree
->n
.sym
->as
== NULL
4463 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4464 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4465 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4467 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4468 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4473 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4474 && arg
->symtree
->n
.sym
->as
!= NULL
4475 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4476 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4478 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4479 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4480 gfc_current_intrinsic
, &arg
->where
);
4488 /* Check whether an expression is interoperable. When returning false,
4489 msg is set to a string telling why the expression is not interoperable,
4490 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4491 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4492 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4493 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4497 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4501 if (expr
->ts
.type
== BT_CLASS
)
4503 *msg
= "Expression is polymorphic";
4507 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4508 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4510 *msg
= "Expression is a noninteroperable derived type";
4514 if (expr
->ts
.type
== BT_PROCEDURE
)
4516 *msg
= "Procedure unexpected as argument";
4520 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4523 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4524 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4526 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4530 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4531 && expr
->ts
.kind
!= 1)
4533 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4537 if (expr
->ts
.type
== BT_CHARACTER
) {
4538 if (expr
->ts
.deferred
)
4540 /* TS 29113 allows deferred-length strings as dummy arguments,
4541 but it is not an interoperable type. */
4542 *msg
= "Expression shall not be a deferred-length string";
4546 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4547 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4548 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4550 if (!c_loc
&& expr
->ts
.u
.cl
4551 && (!expr
->ts
.u
.cl
->length
4552 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4553 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4555 *msg
= "Type shall have a character length of 1";
4560 /* Note: The following checks are about interoperatable variables, Fortran
4561 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4562 is allowed, e.g. assumed-shape arrays with TS 29113. */
4564 if (gfc_is_coarray (expr
))
4566 *msg
= "Coarrays are not interoperable";
4570 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4572 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4573 if (ar
->type
!= AR_FULL
)
4575 *msg
= "Only whole-arrays are interoperable";
4578 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4579 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4581 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4591 gfc_check_c_sizeof (gfc_expr
*arg
)
4595 if (!is_c_interoperable (arg
, &msg
, false, false))
4597 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4598 "interoperable data entity: %s",
4599 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4604 if (arg
->ts
.type
== BT_ASSUMED
)
4606 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4608 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4613 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4614 && arg
->symtree
->n
.sym
->as
!= NULL
4615 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4616 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4618 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4619 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4620 gfc_current_intrinsic
, &arg
->where
);
4629 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4631 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4632 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4633 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4634 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4636 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4637 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4641 if (!scalar_check (c_ptr_1
, 0))
4645 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4646 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4647 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4648 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4650 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4651 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4652 gfc_typename (&c_ptr_1
->ts
),
4653 gfc_typename (&c_ptr_2
->ts
));
4657 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4665 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4667 symbol_attribute attr
;
4670 if (cptr
->ts
.type
!= BT_DERIVED
4671 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4672 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4674 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4675 "type TYPE(C_PTR)", &cptr
->where
);
4679 if (!scalar_check (cptr
, 0))
4682 attr
= gfc_expr_attr (fptr
);
4686 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4691 if (fptr
->ts
.type
== BT_CLASS
)
4693 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4698 if (gfc_is_coindexed (fptr
))
4700 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4701 "coindexed", &fptr
->where
);
4705 if (fptr
->rank
== 0 && shape
)
4707 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4708 "FPTR", &fptr
->where
);
4711 else if (fptr
->rank
&& !shape
)
4713 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4714 "FPTR at %L", &fptr
->where
);
4718 if (shape
&& !rank_check (shape
, 2, 1))
4721 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4727 if (gfc_array_size (shape
, &size
))
4729 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4732 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4733 "size as the RANK of FPTR", &shape
->where
);
4740 if (fptr
->ts
.type
== BT_CLASS
)
4742 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4746 if (!is_c_interoperable (fptr
, &msg
, false, true))
4747 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4748 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4755 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4757 symbol_attribute attr
;
4759 if (cptr
->ts
.type
!= BT_DERIVED
4760 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4761 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4763 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4764 "type TYPE(C_FUNPTR)", &cptr
->where
);
4768 if (!scalar_check (cptr
, 0))
4771 attr
= gfc_expr_attr (fptr
);
4773 if (!attr
.proc_pointer
)
4775 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4776 "pointer", &fptr
->where
);
4780 if (gfc_is_coindexed (fptr
))
4782 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4783 "coindexed", &fptr
->where
);
4787 if (!attr
.is_bind_c
)
4788 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4789 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4796 gfc_check_c_funloc (gfc_expr
*x
)
4798 symbol_attribute attr
;
4800 if (gfc_is_coindexed (x
))
4802 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4803 "coindexed", &x
->where
);
4807 attr
= gfc_expr_attr (x
);
4809 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4810 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4812 gfc_namespace
*ns
= gfc_current_ns
;
4814 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4815 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4817 gfc_error ("Function result %qs at %L is invalid as X argument "
4818 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4823 if (attr
.flavor
!= FL_PROCEDURE
)
4825 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4826 "or a procedure pointer", &x
->where
);
4830 if (!attr
.is_bind_c
)
4831 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4832 "at %L to C_FUNLOC", &x
->where
);
4838 gfc_check_c_loc (gfc_expr
*x
)
4840 symbol_attribute attr
;
4843 if (gfc_is_coindexed (x
))
4845 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4849 if (x
->ts
.type
== BT_CLASS
)
4851 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4856 attr
= gfc_expr_attr (x
);
4859 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4860 || attr
.flavor
== FL_PARAMETER
))
4862 gfc_error ("Argument X at %L to C_LOC shall have either "
4863 "the POINTER or the TARGET attribute", &x
->where
);
4867 if (x
->ts
.type
== BT_CHARACTER
4868 && gfc_var_strlen (x
) == 0)
4870 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4871 "string", &x
->where
);
4875 if (!is_c_interoperable (x
, &msg
, true, false))
4877 if (x
->ts
.type
== BT_CLASS
)
4879 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4885 && !gfc_notify_std (GFC_STD_F2008_TS
,
4886 "Noninteroperable array at %L as"
4887 " argument to C_LOC: %s", &x
->where
, msg
))
4890 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4892 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4894 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4895 && !attr
.allocatable
4896 && !gfc_notify_std (GFC_STD_F2008
,
4897 "Array of interoperable type at %L "
4898 "to C_LOC which is nonallocatable and neither "
4899 "assumed size nor explicit size", &x
->where
))
4901 else if (ar
->type
!= AR_FULL
4902 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4903 "to C_LOC", &x
->where
))
4912 gfc_check_sleep_sub (gfc_expr
*seconds
)
4914 if (!type_check (seconds
, 0, BT_INTEGER
))
4917 if (!scalar_check (seconds
, 0))
4924 gfc_check_sngl (gfc_expr
*a
)
4926 if (!type_check (a
, 0, BT_REAL
))
4929 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4930 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4931 "REAL argument to %s intrinsic at %L",
4932 gfc_current_intrinsic
, &a
->where
))
4939 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4941 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4943 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4944 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4945 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4953 if (!dim_check (dim
, 1, false))
4956 /* dim_rank_check() does not apply here. */
4958 && dim
->expr_type
== EXPR_CONSTANT
4959 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4960 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4962 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4963 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4964 gfc_current_intrinsic
, &dim
->where
);
4968 if (!type_check (ncopies
, 2, BT_INTEGER
))
4971 if (!scalar_check (ncopies
, 2))
4978 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4982 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4984 if (!type_check (unit
, 0, BT_INTEGER
))
4987 if (!scalar_check (unit
, 0))
4990 if (!type_check (c
, 1, BT_CHARACTER
))
4992 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4998 if (!type_check (status
, 2, BT_INTEGER
)
4999 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5000 || !scalar_check (status
, 2))
5008 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5010 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5015 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5017 if (!type_check (c
, 0, BT_CHARACTER
))
5019 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5025 if (!type_check (status
, 1, BT_INTEGER
)
5026 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5027 || !scalar_check (status
, 1))
5035 gfc_check_fgetput (gfc_expr
*c
)
5037 return gfc_check_fgetput_sub (c
, NULL
);
5042 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5044 if (!type_check (unit
, 0, BT_INTEGER
))
5047 if (!scalar_check (unit
, 0))
5050 if (!type_check (offset
, 1, BT_INTEGER
))
5053 if (!scalar_check (offset
, 1))
5056 if (!type_check (whence
, 2, BT_INTEGER
))
5059 if (!scalar_check (whence
, 2))
5065 if (!type_check (status
, 3, BT_INTEGER
))
5068 if (!kind_value_check (status
, 3, 4))
5071 if (!scalar_check (status
, 3))
5080 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5082 if (!type_check (unit
, 0, BT_INTEGER
))
5085 if (!scalar_check (unit
, 0))
5088 if (!type_check (array
, 1, BT_INTEGER
)
5089 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5092 if (!array_check (array
, 1))
5100 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5102 if (!type_check (unit
, 0, BT_INTEGER
))
5105 if (!scalar_check (unit
, 0))
5108 if (!type_check (array
, 1, BT_INTEGER
)
5109 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5112 if (!array_check (array
, 1))
5118 if (!type_check (status
, 2, BT_INTEGER
)
5119 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5122 if (!scalar_check (status
, 2))
5130 gfc_check_ftell (gfc_expr
*unit
)
5132 if (!type_check (unit
, 0, BT_INTEGER
))
5135 if (!scalar_check (unit
, 0))
5143 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5145 if (!type_check (unit
, 0, BT_INTEGER
))
5148 if (!scalar_check (unit
, 0))
5151 if (!type_check (offset
, 1, BT_INTEGER
))
5154 if (!scalar_check (offset
, 1))
5162 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5164 if (!type_check (name
, 0, BT_CHARACTER
))
5166 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5169 if (!type_check (array
, 1, BT_INTEGER
)
5170 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5173 if (!array_check (array
, 1))
5181 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5183 if (!type_check (name
, 0, BT_CHARACTER
))
5185 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5188 if (!type_check (array
, 1, BT_INTEGER
)
5189 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5192 if (!array_check (array
, 1))
5198 if (!type_check (status
, 2, BT_INTEGER
)
5199 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5202 if (!scalar_check (status
, 2))
5210 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5214 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5216 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5220 if (!coarray_check (coarray
, 0))
5225 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5226 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5230 if (gfc_array_size (sub
, &nelems
))
5232 int corank
= gfc_get_corank (coarray
);
5234 if (mpz_cmp_ui (nelems
, corank
) != 0)
5236 gfc_error ("The number of array elements of the SUB argument to "
5237 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5238 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5250 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5252 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5254 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5260 if (!type_check (distance
, 0, BT_INTEGER
))
5263 if (!nonnegative_check ("DISTANCE", distance
))
5266 if (!scalar_check (distance
, 0))
5269 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5270 "NUM_IMAGES at %L", &distance
->where
))
5276 if (!type_check (failed
, 1, BT_LOGICAL
))
5279 if (!scalar_check (failed
, 1))
5282 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5283 "NUM_IMAGES at %L", &failed
->where
))
5292 gfc_check_team_number (gfc_expr
*team
)
5294 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5296 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5302 if (team
->ts
.type
!= BT_DERIVED
5303 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
5304 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
5306 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
5307 "shall be of type TEAM_TYPE", &team
->where
);
5319 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5321 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5323 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5327 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5330 if (dim
!= NULL
&& coarray
== NULL
)
5332 gfc_error ("DIM argument without COARRAY argument not allowed for "
5333 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5337 if (distance
&& (coarray
|| dim
))
5339 gfc_error ("The DISTANCE argument may not be specified together with the "
5340 "COARRAY or DIM argument in intrinsic at %L",
5345 /* Assume that we have "this_image (distance)". */
5346 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5350 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5359 if (!type_check (distance
, 2, BT_INTEGER
))
5362 if (!nonnegative_check ("DISTANCE", distance
))
5365 if (!scalar_check (distance
, 2))
5368 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5369 "THIS_IMAGE at %L", &distance
->where
))
5375 if (!coarray_check (coarray
, 0))
5380 if (!dim_check (dim
, 1, false))
5383 if (!dim_corank_check (dim
, coarray
))
5390 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5391 by gfc_simplify_transfer. Return false if we cannot do so. */
5394 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5395 size_t *source_size
, size_t *result_size
,
5396 size_t *result_length_p
)
5398 size_t result_elt_size
;
5400 if (source
->expr_type
== EXPR_FUNCTION
)
5403 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5406 /* Calculate the size of the source. */
5407 *source_size
= gfc_target_expr_size (source
);
5408 if (*source_size
== 0)
5411 /* Determine the size of the element. */
5412 result_elt_size
= gfc_element_size (mold
);
5413 if (result_elt_size
== 0)
5416 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5421 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5424 result_length
= *source_size
/ result_elt_size
;
5425 if (result_length
* result_elt_size
< *source_size
)
5429 *result_size
= result_length
* result_elt_size
;
5430 if (result_length_p
)
5431 *result_length_p
= result_length
;
5434 *result_size
= result_elt_size
;
5441 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5446 if (mold
->ts
.type
== BT_HOLLERITH
)
5448 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5449 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5455 if (!type_check (size
, 2, BT_INTEGER
))
5458 if (!scalar_check (size
, 2))
5461 if (!nonoptional_check (size
, 2))
5465 if (!warn_surprising
)
5468 /* If we can't calculate the sizes, we cannot check any more.
5469 Return true for that case. */
5471 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5472 &result_size
, NULL
))
5475 if (source_size
< result_size
)
5476 gfc_warning (OPT_Wsurprising
,
5477 "Intrinsic TRANSFER at %L has partly undefined result: "
5478 "source size %ld < result size %ld", &source
->where
,
5479 (long) source_size
, (long) result_size
);
5486 gfc_check_transpose (gfc_expr
*matrix
)
5488 if (!rank_check (matrix
, 0, 2))
5496 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5498 if (!array_check (array
, 0))
5501 if (!dim_check (dim
, 1, false))
5504 if (!dim_rank_check (dim
, array
, 0))
5507 if (!kind_check (kind
, 2, BT_INTEGER
))
5509 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5510 "with KIND argument at %L",
5511 gfc_current_intrinsic
, &kind
->where
))
5519 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5521 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5523 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5527 if (!coarray_check (coarray
, 0))
5532 if (!dim_check (dim
, 1, false))
5535 if (!dim_corank_check (dim
, coarray
))
5539 if (!kind_check (kind
, 2, BT_INTEGER
))
5547 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5551 if (!rank_check (vector
, 0, 1))
5554 if (!array_check (mask
, 1))
5557 if (!type_check (mask
, 1, BT_LOGICAL
))
5560 if (!same_type_check (vector
, 0, field
, 2))
5563 if (mask
->expr_type
== EXPR_ARRAY
5564 && gfc_array_size (vector
, &vector_size
))
5566 int mask_true_count
= 0;
5567 gfc_constructor
*mask_ctor
;
5568 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5571 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5573 mask_true_count
= 0;
5577 if (mask_ctor
->expr
->value
.logical
)
5580 mask_ctor
= gfc_constructor_next (mask_ctor
);
5583 if (mpz_get_si (vector_size
) < mask_true_count
)
5585 gfc_error ("%qs argument of %qs intrinsic at %L must "
5586 "provide at least as many elements as there "
5587 "are .TRUE. values in %qs (%ld/%d)",
5588 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5589 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5590 mpz_get_si (vector_size
), mask_true_count
);
5594 mpz_clear (vector_size
);
5597 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5599 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5600 "the same rank as %qs or be a scalar",
5601 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5602 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5606 if (mask
->rank
== field
->rank
)
5609 for (i
= 0; i
< field
->rank
; i
++)
5610 if (! identical_dimen_shape (mask
, i
, field
, i
))
5612 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5613 "must have identical shape.",
5614 gfc_current_intrinsic_arg
[2]->name
,
5615 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5625 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5627 if (!type_check (x
, 0, BT_CHARACTER
))
5630 if (!same_type_check (x
, 0, y
, 1))
5633 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5636 if (!kind_check (kind
, 3, BT_INTEGER
))
5638 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5639 "with KIND argument at %L",
5640 gfc_current_intrinsic
, &kind
->where
))
5648 gfc_check_trim (gfc_expr
*x
)
5650 if (!type_check (x
, 0, BT_CHARACTER
))
5653 if (!scalar_check (x
, 0))
5661 gfc_check_ttynam (gfc_expr
*unit
)
5663 if (!scalar_check (unit
, 0))
5666 if (!type_check (unit
, 0, BT_INTEGER
))
5673 /************* Check functions for intrinsic subroutines *************/
5676 gfc_check_cpu_time (gfc_expr
*time
)
5678 if (!scalar_check (time
, 0))
5681 if (!type_check (time
, 0, BT_REAL
))
5684 if (!variable_check (time
, 0, false))
5692 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5693 gfc_expr
*zone
, gfc_expr
*values
)
5697 if (!type_check (date
, 0, BT_CHARACTER
))
5699 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5701 if (!scalar_check (date
, 0))
5703 if (!variable_check (date
, 0, false))
5709 if (!type_check (time
, 1, BT_CHARACTER
))
5711 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5713 if (!scalar_check (time
, 1))
5715 if (!variable_check (time
, 1, false))
5721 if (!type_check (zone
, 2, BT_CHARACTER
))
5723 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5725 if (!scalar_check (zone
, 2))
5727 if (!variable_check (zone
, 2, false))
5733 if (!type_check (values
, 3, BT_INTEGER
))
5735 if (!array_check (values
, 3))
5737 if (!rank_check (values
, 3, 1))
5739 if (!variable_check (values
, 3, false))
5748 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5749 gfc_expr
*to
, gfc_expr
*topos
)
5751 if (!type_check (from
, 0, BT_INTEGER
))
5754 if (!type_check (frompos
, 1, BT_INTEGER
))
5757 if (!type_check (len
, 2, BT_INTEGER
))
5760 if (!same_type_check (from
, 0, to
, 3))
5763 if (!variable_check (to
, 3, false))
5766 if (!type_check (topos
, 4, BT_INTEGER
))
5769 if (!nonnegative_check ("frompos", frompos
))
5772 if (!nonnegative_check ("topos", topos
))
5775 if (!nonnegative_check ("len", len
))
5778 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5781 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5789 gfc_check_random_number (gfc_expr
*harvest
)
5791 if (!type_check (harvest
, 0, BT_REAL
))
5794 if (!variable_check (harvest
, 0, false))
5802 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5804 unsigned int nargs
= 0, seed_size
;
5805 locus
*where
= NULL
;
5806 mpz_t put_size
, get_size
;
5808 /* Keep the number of bytes in sync with master_state in
5809 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5810 part of the state too. */
5811 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5815 if (size
->expr_type
!= EXPR_VARIABLE
5816 || !size
->symtree
->n
.sym
->attr
.optional
)
5819 if (!scalar_check (size
, 0))
5822 if (!type_check (size
, 0, BT_INTEGER
))
5825 if (!variable_check (size
, 0, false))
5828 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5834 if (put
->expr_type
!= EXPR_VARIABLE
5835 || !put
->symtree
->n
.sym
->attr
.optional
)
5838 where
= &put
->where
;
5841 if (!array_check (put
, 1))
5844 if (!rank_check (put
, 1, 1))
5847 if (!type_check (put
, 1, BT_INTEGER
))
5850 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5853 if (gfc_array_size (put
, &put_size
)
5854 && mpz_get_ui (put_size
) < seed_size
)
5855 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5856 "too small (%i/%i)",
5857 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5858 where
, (int) mpz_get_ui (put_size
), seed_size
);
5863 if (get
->expr_type
!= EXPR_VARIABLE
5864 || !get
->symtree
->n
.sym
->attr
.optional
)
5867 where
= &get
->where
;
5870 if (!array_check (get
, 2))
5873 if (!rank_check (get
, 2, 1))
5876 if (!type_check (get
, 2, BT_INTEGER
))
5879 if (!variable_check (get
, 2, false))
5882 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5885 if (gfc_array_size (get
, &get_size
)
5886 && mpz_get_ui (get_size
) < seed_size
)
5887 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5888 "too small (%i/%i)",
5889 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5890 where
, (int) mpz_get_ui (get_size
), seed_size
);
5893 /* RANDOM_SEED may not have more than one non-optional argument. */
5895 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5901 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5905 int num_percent
, nargs
;
5908 if (e
->expr_type
!= EXPR_CONSTANT
)
5911 len
= e
->value
.character
.length
;
5912 if (e
->value
.character
.string
[len
-1] != '\0')
5913 gfc_internal_error ("fe_runtime_error string must be null terminated");
5916 for (i
=0; i
<len
-1; i
++)
5917 if (e
->value
.character
.string
[i
] == '%')
5921 for (; a
; a
= a
->next
)
5924 if (nargs
-1 != num_percent
)
5925 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5926 nargs
, num_percent
++);
5932 gfc_check_second_sub (gfc_expr
*time
)
5934 if (!scalar_check (time
, 0))
5937 if (!type_check (time
, 0, BT_REAL
))
5940 if (!kind_value_check (time
, 0, 4))
5947 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5948 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5949 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5950 count_max are all optional arguments */
5953 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5954 gfc_expr
*count_max
)
5958 if (!scalar_check (count
, 0))
5961 if (!type_check (count
, 0, BT_INTEGER
))
5964 if (count
->ts
.kind
!= gfc_default_integer_kind
5965 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5966 "SYSTEM_CLOCK at %L has non-default kind",
5970 if (!variable_check (count
, 0, false))
5974 if (count_rate
!= NULL
)
5976 if (!scalar_check (count_rate
, 1))
5979 if (!variable_check (count_rate
, 1, false))
5982 if (count_rate
->ts
.type
== BT_REAL
)
5984 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5985 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5990 if (!type_check (count_rate
, 1, BT_INTEGER
))
5993 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5994 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5995 "SYSTEM_CLOCK at %L has non-default kind",
5996 &count_rate
->where
))
6002 if (count_max
!= NULL
)
6004 if (!scalar_check (count_max
, 2))
6007 if (!type_check (count_max
, 2, BT_INTEGER
))
6010 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6011 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6012 "SYSTEM_CLOCK at %L has non-default kind",
6016 if (!variable_check (count_max
, 2, false))
6025 gfc_check_irand (gfc_expr
*x
)
6030 if (!scalar_check (x
, 0))
6033 if (!type_check (x
, 0, BT_INTEGER
))
6036 if (!kind_value_check (x
, 0, 4))
6044 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6046 if (!scalar_check (seconds
, 0))
6048 if (!type_check (seconds
, 0, BT_INTEGER
))
6051 if (!int_or_proc_check (handler
, 1))
6053 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6059 if (!scalar_check (status
, 2))
6061 if (!type_check (status
, 2, BT_INTEGER
))
6063 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6071 gfc_check_rand (gfc_expr
*x
)
6076 if (!scalar_check (x
, 0))
6079 if (!type_check (x
, 0, BT_INTEGER
))
6082 if (!kind_value_check (x
, 0, 4))
6090 gfc_check_srand (gfc_expr
*x
)
6092 if (!scalar_check (x
, 0))
6095 if (!type_check (x
, 0, BT_INTEGER
))
6098 if (!kind_value_check (x
, 0, 4))
6106 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6108 if (!scalar_check (time
, 0))
6110 if (!type_check (time
, 0, BT_INTEGER
))
6113 if (!type_check (result
, 1, BT_CHARACTER
))
6115 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6123 gfc_check_dtime_etime (gfc_expr
*x
)
6125 if (!array_check (x
, 0))
6128 if (!rank_check (x
, 0, 1))
6131 if (!variable_check (x
, 0, false))
6134 if (!type_check (x
, 0, BT_REAL
))
6137 if (!kind_value_check (x
, 0, 4))
6145 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6147 if (!array_check (values
, 0))
6150 if (!rank_check (values
, 0, 1))
6153 if (!variable_check (values
, 0, false))
6156 if (!type_check (values
, 0, BT_REAL
))
6159 if (!kind_value_check (values
, 0, 4))
6162 if (!scalar_check (time
, 1))
6165 if (!type_check (time
, 1, BT_REAL
))
6168 if (!kind_value_check (time
, 1, 4))
6176 gfc_check_fdate_sub (gfc_expr
*date
)
6178 if (!type_check (date
, 0, BT_CHARACTER
))
6180 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6188 gfc_check_gerror (gfc_expr
*msg
)
6190 if (!type_check (msg
, 0, BT_CHARACTER
))
6192 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6200 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6202 if (!type_check (cwd
, 0, BT_CHARACTER
))
6204 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6210 if (!scalar_check (status
, 1))
6213 if (!type_check (status
, 1, BT_INTEGER
))
6221 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6223 if (!type_check (pos
, 0, BT_INTEGER
))
6226 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6228 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6229 "not wider than the default kind (%d)",
6230 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6231 &pos
->where
, gfc_default_integer_kind
);
6235 if (!type_check (value
, 1, BT_CHARACTER
))
6237 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6245 gfc_check_getlog (gfc_expr
*msg
)
6247 if (!type_check (msg
, 0, BT_CHARACTER
))
6249 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6257 gfc_check_exit (gfc_expr
*status
)
6262 if (!type_check (status
, 0, BT_INTEGER
))
6265 if (!scalar_check (status
, 0))
6273 gfc_check_flush (gfc_expr
*unit
)
6278 if (!type_check (unit
, 0, BT_INTEGER
))
6281 if (!scalar_check (unit
, 0))
6289 gfc_check_free (gfc_expr
*i
)
6291 if (!type_check (i
, 0, BT_INTEGER
))
6294 if (!scalar_check (i
, 0))
6302 gfc_check_hostnm (gfc_expr
*name
)
6304 if (!type_check (name
, 0, BT_CHARACTER
))
6306 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6314 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6316 if (!type_check (name
, 0, BT_CHARACTER
))
6318 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6324 if (!scalar_check (status
, 1))
6327 if (!type_check (status
, 1, BT_INTEGER
))
6335 gfc_check_itime_idate (gfc_expr
*values
)
6337 if (!array_check (values
, 0))
6340 if (!rank_check (values
, 0, 1))
6343 if (!variable_check (values
, 0, false))
6346 if (!type_check (values
, 0, BT_INTEGER
))
6349 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6357 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6359 if (!type_check (time
, 0, BT_INTEGER
))
6362 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6365 if (!scalar_check (time
, 0))
6368 if (!array_check (values
, 1))
6371 if (!rank_check (values
, 1, 1))
6374 if (!variable_check (values
, 1, false))
6377 if (!type_check (values
, 1, BT_INTEGER
))
6380 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6388 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6390 if (!scalar_check (unit
, 0))
6393 if (!type_check (unit
, 0, BT_INTEGER
))
6396 if (!type_check (name
, 1, BT_CHARACTER
))
6398 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6406 gfc_check_isatty (gfc_expr
*unit
)
6411 if (!type_check (unit
, 0, BT_INTEGER
))
6414 if (!scalar_check (unit
, 0))
6422 gfc_check_isnan (gfc_expr
*x
)
6424 if (!type_check (x
, 0, BT_REAL
))
6432 gfc_check_perror (gfc_expr
*string
)
6434 if (!type_check (string
, 0, BT_CHARACTER
))
6436 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6444 gfc_check_umask (gfc_expr
*mask
)
6446 if (!type_check (mask
, 0, BT_INTEGER
))
6449 if (!scalar_check (mask
, 0))
6457 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6459 if (!type_check (mask
, 0, BT_INTEGER
))
6462 if (!scalar_check (mask
, 0))
6468 if (!scalar_check (old
, 1))
6471 if (!type_check (old
, 1, BT_INTEGER
))
6479 gfc_check_unlink (gfc_expr
*name
)
6481 if (!type_check (name
, 0, BT_CHARACTER
))
6483 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6491 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6493 if (!type_check (name
, 0, BT_CHARACTER
))
6495 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6501 if (!scalar_check (status
, 1))
6504 if (!type_check (status
, 1, BT_INTEGER
))
6512 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6514 if (!scalar_check (number
, 0))
6516 if (!type_check (number
, 0, BT_INTEGER
))
6519 if (!int_or_proc_check (handler
, 1))
6521 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6529 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6531 if (!scalar_check (number
, 0))
6533 if (!type_check (number
, 0, BT_INTEGER
))
6536 if (!int_or_proc_check (handler
, 1))
6538 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6544 if (!type_check (status
, 2, BT_INTEGER
))
6546 if (!scalar_check (status
, 2))
6554 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6556 if (!type_check (cmd
, 0, BT_CHARACTER
))
6558 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6561 if (!scalar_check (status
, 1))
6564 if (!type_check (status
, 1, BT_INTEGER
))
6567 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6574 /* This is used for the GNU intrinsics AND, OR and XOR. */
6576 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6578 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6580 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6581 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6582 gfc_current_intrinsic
, &i
->where
);
6586 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6588 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6589 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6590 gfc_current_intrinsic
, &j
->where
);
6594 if (i
->ts
.type
!= j
->ts
.type
)
6596 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6597 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6598 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6603 if (!scalar_check (i
, 0))
6606 if (!scalar_check (j
, 1))
6614 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6617 if (a
->expr_type
== EXPR_NULL
)
6619 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6620 "argument to STORAGE_SIZE, because it returns a "
6621 "disassociated pointer", &a
->where
);
6625 if (a
->ts
.type
== BT_ASSUMED
)
6627 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6628 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6633 if (a
->ts
.type
== BT_PROCEDURE
)
6635 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6636 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6637 gfc_current_intrinsic
, &a
->where
);
6644 if (!type_check (kind
, 1, BT_INTEGER
))
6647 if (!scalar_check (kind
, 1))
6650 if (kind
->expr_type
!= EXPR_CONSTANT
)
6652 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6653 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,