2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 /* Users sometime use a subroutine designator as an actual argument to
76 an intrinsic subprogram that expects an argument with a numeric type. */
77 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
80 if (gfc_numeric_ts (&e
->ts
))
83 /* If the expression has not got a type, check if its namespace can
84 offer a default type. */
85 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
86 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
87 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
88 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
90 e
->ts
= e
->symtree
->n
.sym
->ts
;
96 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
97 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
104 /* Check that an expression is integer or real. */
107 int_or_real_check (gfc_expr
*e
, int n
)
109 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
111 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
112 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
113 gfc_current_intrinsic
, &e
->where
);
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_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1257 gfc_expr
*new_val
, gfc_expr
*stat
)
1259 if (atom
->expr_type
== EXPR_FUNCTION
1260 && atom
->value
.function
.isym
1261 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1262 atom
= atom
->value
.function
.actual
->expr
;
1264 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1267 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1270 if (!same_type_check (atom
, 0, old
, 1))
1273 if (!same_type_check (atom
, 0, compare
, 2))
1276 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1278 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1279 "definable", gfc_current_intrinsic
, &atom
->where
);
1283 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1285 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1286 "definable", gfc_current_intrinsic
, &old
->where
);
1294 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1296 if (event
->ts
.type
!= BT_DERIVED
1297 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1298 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1300 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1301 "shall be of type EVENT_TYPE", &event
->where
);
1305 if (!scalar_check (event
, 0))
1308 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1310 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1311 "shall be definable", &count
->where
);
1315 if (!type_check (count
, 1, BT_INTEGER
))
1318 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1319 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1321 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1323 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1324 "shall have at least the range of the default integer",
1331 if (!type_check (stat
, 2, BT_INTEGER
))
1333 if (!scalar_check (stat
, 2))
1335 if (!variable_check (stat
, 2, false))
1338 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1339 gfc_current_intrinsic
, &stat
->where
))
1348 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1351 if (atom
->expr_type
== EXPR_FUNCTION
1352 && atom
->value
.function
.isym
1353 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1354 atom
= atom
->value
.function
.actual
->expr
;
1356 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1358 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1359 "integer of ATOMIC_INT_KIND", &atom
->where
,
1360 gfc_current_intrinsic
);
1364 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1367 if (!scalar_check (old
, 2))
1370 if (!same_type_check (atom
, 0, old
, 2))
1373 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1375 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1376 "definable", gfc_current_intrinsic
, &atom
->where
);
1380 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1382 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1383 "definable", gfc_current_intrinsic
, &old
->where
);
1391 /* BESJN and BESYN functions. */
1394 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1396 if (!type_check (n
, 0, BT_INTEGER
))
1398 if (n
->expr_type
== EXPR_CONSTANT
)
1401 gfc_extract_int (n
, &i
);
1402 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1403 "N at %L", &n
->where
))
1407 if (!type_check (x
, 1, BT_REAL
))
1414 /* Transformational version of the Bessel JN and YN functions. */
1417 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1419 if (!type_check (n1
, 0, BT_INTEGER
))
1421 if (!scalar_check (n1
, 0))
1423 if (!nonnegative_check ("N1", n1
))
1426 if (!type_check (n2
, 1, BT_INTEGER
))
1428 if (!scalar_check (n2
, 1))
1430 if (!nonnegative_check ("N2", n2
))
1433 if (!type_check (x
, 2, BT_REAL
))
1435 if (!scalar_check (x
, 2))
1443 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1445 if (!type_check (i
, 0, BT_INTEGER
))
1448 if (!type_check (j
, 1, BT_INTEGER
))
1456 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1458 if (!type_check (i
, 0, BT_INTEGER
))
1461 if (!type_check (pos
, 1, BT_INTEGER
))
1464 if (!nonnegative_check ("pos", pos
))
1467 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1475 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1477 if (!type_check (i
, 0, BT_INTEGER
))
1479 if (!kind_check (kind
, 1, BT_CHARACTER
))
1487 gfc_check_chdir (gfc_expr
*dir
)
1489 if (!type_check (dir
, 0, BT_CHARACTER
))
1491 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1499 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1501 if (!type_check (dir
, 0, BT_CHARACTER
))
1503 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1509 if (!type_check (status
, 1, BT_INTEGER
))
1511 if (!scalar_check (status
, 1))
1519 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1521 if (!type_check (name
, 0, BT_CHARACTER
))
1523 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1526 if (!type_check (mode
, 1, BT_CHARACTER
))
1528 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1536 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1538 if (!type_check (name
, 0, BT_CHARACTER
))
1540 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1543 if (!type_check (mode
, 1, BT_CHARACTER
))
1545 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1551 if (!type_check (status
, 2, BT_INTEGER
))
1554 if (!scalar_check (status
, 2))
1562 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1564 if (!numeric_check (x
, 0))
1569 if (!numeric_check (y
, 1))
1572 if (x
->ts
.type
== BT_COMPLEX
)
1574 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1575 "present if %<x%> is COMPLEX",
1576 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1581 if (y
->ts
.type
== BT_COMPLEX
)
1583 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1584 "of either REAL or INTEGER",
1585 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1592 if (!kind_check (kind
, 2, BT_COMPLEX
))
1595 if (!kind
&& warn_conversion
1596 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1597 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1598 "COMPLEX(%d) at %L might lose precision, consider using "
1599 "the KIND argument", gfc_typename (&x
->ts
),
1600 gfc_default_real_kind
, &x
->where
);
1601 else if (y
&& !kind
&& warn_conversion
1602 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1603 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1604 "COMPLEX(%d) at %L might lose precision, consider using "
1605 "the KIND argument", gfc_typename (&y
->ts
),
1606 gfc_default_real_kind
, &y
->where
);
1612 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1613 gfc_expr
*errmsg
, bool co_reduce
)
1615 if (!variable_check (a
, 0, false))
1618 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1622 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1623 if (gfc_has_vector_subscript (a
))
1625 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1626 "subroutine %s shall not have a vector subscript",
1627 &a
->where
, gfc_current_intrinsic
);
1631 if (gfc_is_coindexed (a
))
1633 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1634 "coindexed", &a
->where
, gfc_current_intrinsic
);
1638 if (image_idx
!= NULL
)
1640 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1642 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1648 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1650 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1652 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1654 if (stat
->ts
.kind
!= 4)
1656 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1657 "variable", &stat
->where
);
1664 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1666 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1668 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1670 if (errmsg
->ts
.kind
!= 1)
1672 gfc_error ("The errmsg= argument at %L must be a default-kind "
1673 "character variable", &errmsg
->where
);
1678 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1680 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1690 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1693 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1695 gfc_error ("Support for the A argument at %L which is polymorphic A "
1696 "argument or has allocatable components is not yet "
1697 "implemented", &a
->where
);
1700 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1705 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1706 gfc_expr
*stat
, gfc_expr
*errmsg
)
1708 symbol_attribute attr
;
1709 gfc_formal_arglist
*formal
;
1712 if (a
->ts
.type
== BT_CLASS
)
1714 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1719 if (gfc_expr_attr (a
).alloc_comp
)
1721 gfc_error ("Support for the A argument at %L with allocatable components"
1722 " is not yet implemented", &a
->where
);
1726 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1729 if (!gfc_resolve_expr (op
))
1732 attr
= gfc_expr_attr (op
);
1733 if (!attr
.pure
|| !attr
.function
)
1735 gfc_error ("OPERATOR argument at %L must be a PURE function",
1742 /* None of the intrinsics fulfills the criteria of taking two arguments,
1743 returning the same type and kind as the arguments and being permitted
1744 as actual argument. */
1745 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1746 op
->symtree
->n
.sym
->name
, &op
->where
);
1750 if (gfc_is_proc_ptr_comp (op
))
1752 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1753 sym
= comp
->ts
.interface
;
1756 sym
= op
->symtree
->n
.sym
;
1758 formal
= sym
->formal
;
1760 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1762 gfc_error ("The function passed as OPERATOR at %L shall have two "
1763 "arguments", &op
->where
);
1767 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1768 gfc_set_default_type (sym
->result
, 0, NULL
);
1770 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1772 gfc_error ("The A argument at %L has type %s but the function passed as "
1773 "OPERATOR at %L returns %s",
1774 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1775 gfc_typename (&sym
->result
->ts
));
1778 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1779 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1781 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1782 "%s and %s but shall have type %s", &op
->where
,
1783 gfc_typename (&formal
->sym
->ts
),
1784 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1787 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1788 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1789 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1790 || formal
->next
->sym
->attr
.pointer
)
1792 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1793 "nonallocatable nonpointer arguments and return a "
1794 "nonallocatable nonpointer scalar", &op
->where
);
1798 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1800 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1801 "attribute either for none or both arguments", &op
->where
);
1805 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1807 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1808 "attribute either for none or both arguments", &op
->where
);
1812 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1814 gfc_error ("The function passed as OPERATOR at %L shall have the "
1815 "ASYNCHRONOUS attribute either for none or both arguments",
1820 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1822 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1823 "OPTIONAL attribute for either of the arguments", &op
->where
);
1827 if (a
->ts
.type
== BT_CHARACTER
)
1830 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1833 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1834 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1836 cl
= formal
->sym
->ts
.u
.cl
;
1837 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1838 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1840 cl
= formal
->next
->sym
->ts
.u
.cl
;
1841 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1842 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1845 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1846 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1849 && ((formal_size1
&& actual_size
!= formal_size1
)
1850 || (formal_size2
&& actual_size
!= formal_size2
)))
1852 gfc_error ("The character length of the A argument at %L and of the "
1853 "arguments of the OPERATOR at %L shall be the same",
1854 &a
->where
, &op
->where
);
1857 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1859 gfc_error ("The character length of the A argument at %L and of the "
1860 "function result of the OPERATOR at %L shall be the same",
1861 &a
->where
, &op
->where
);
1871 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1874 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1875 && a
->ts
.type
!= BT_CHARACTER
)
1877 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1878 "integer, real or character",
1879 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1883 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1888 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1891 if (!numeric_check (a
, 0))
1893 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1898 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1900 if (!int_or_real_check (x
, 0))
1902 if (!scalar_check (x
, 0))
1905 if (!int_or_real_check (y
, 1))
1907 if (!scalar_check (y
, 1))
1915 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1917 if (!logical_array_check (mask
, 0))
1919 if (!dim_check (dim
, 1, false))
1921 if (!dim_rank_check (dim
, mask
, 0))
1923 if (!kind_check (kind
, 2, BT_INTEGER
))
1925 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1926 "with KIND argument at %L",
1927 gfc_current_intrinsic
, &kind
->where
))
1935 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1937 if (!array_check (array
, 0))
1940 if (!type_check (shift
, 1, BT_INTEGER
))
1943 if (!dim_check (dim
, 2, true))
1946 if (!dim_rank_check (dim
, array
, false))
1949 if (array
->rank
== 1 || shift
->rank
== 0)
1951 if (!scalar_check (shift
, 1))
1954 else if (shift
->rank
== array
->rank
- 1)
1959 else if (dim
->expr_type
== EXPR_CONSTANT
)
1960 gfc_extract_int (dim
, &d
);
1967 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1970 if (!identical_dimen_shape (array
, i
, shift
, j
))
1972 gfc_error ("%qs argument of %qs intrinsic at %L has "
1973 "invalid shape in dimension %d (%ld/%ld)",
1974 gfc_current_intrinsic_arg
[1]->name
,
1975 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1976 mpz_get_si (array
->shape
[i
]),
1977 mpz_get_si (shift
->shape
[j
]));
1987 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
1988 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1989 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1998 gfc_check_ctime (gfc_expr
*time
)
2000 if (!scalar_check (time
, 0))
2003 if (!type_check (time
, 0, BT_INTEGER
))
2010 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2012 if (!double_check (y
, 0) || !double_check (x
, 1))
2019 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2021 if (!numeric_check (x
, 0))
2026 if (!numeric_check (y
, 1))
2029 if (x
->ts
.type
== BT_COMPLEX
)
2031 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2032 "present if %<x%> is COMPLEX",
2033 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2038 if (y
->ts
.type
== BT_COMPLEX
)
2040 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2041 "of either REAL or INTEGER",
2042 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2053 gfc_check_dble (gfc_expr
*x
)
2055 if (!numeric_check (x
, 0))
2063 gfc_check_digits (gfc_expr
*x
)
2065 if (!int_or_real_check (x
, 0))
2073 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2075 switch (vector_a
->ts
.type
)
2078 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2085 if (!numeric_check (vector_b
, 1))
2090 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2091 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2092 gfc_current_intrinsic
, &vector_a
->where
);
2096 if (!rank_check (vector_a
, 0, 1))
2099 if (!rank_check (vector_b
, 1, 1))
2102 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2104 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2105 "intrinsic %<dot_product%>",
2106 gfc_current_intrinsic_arg
[0]->name
,
2107 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2116 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2118 if (!type_check (x
, 0, BT_REAL
)
2119 || !type_check (y
, 1, BT_REAL
))
2122 if (x
->ts
.kind
!= gfc_default_real_kind
)
2124 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2125 "real", gfc_current_intrinsic_arg
[0]->name
,
2126 gfc_current_intrinsic
, &x
->where
);
2130 if (y
->ts
.kind
!= gfc_default_real_kind
)
2132 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2133 "real", gfc_current_intrinsic_arg
[1]->name
,
2134 gfc_current_intrinsic
, &y
->where
);
2143 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2145 if (!type_check (i
, 0, BT_INTEGER
))
2148 if (!type_check (j
, 1, BT_INTEGER
))
2151 if (i
->is_boz
&& j
->is_boz
)
2153 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2154 "constants", &i
->where
, &j
->where
);
2158 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
2161 if (!type_check (shift
, 2, BT_INTEGER
))
2164 if (!nonnegative_check ("SHIFT", shift
))
2169 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
2171 i
->ts
.kind
= j
->ts
.kind
;
2175 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2177 j
->ts
.kind
= i
->ts
.kind
;
2185 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2188 if (!array_check (array
, 0))
2191 if (!type_check (shift
, 1, BT_INTEGER
))
2194 if (!dim_check (dim
, 3, true))
2197 if (!dim_rank_check (dim
, array
, false))
2200 if (array
->rank
== 1 || shift
->rank
== 0)
2202 if (!scalar_check (shift
, 1))
2205 else if (shift
->rank
== array
->rank
- 1)
2210 else if (dim
->expr_type
== EXPR_CONSTANT
)
2211 gfc_extract_int (dim
, &d
);
2218 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2221 if (!identical_dimen_shape (array
, i
, shift
, j
))
2223 gfc_error ("%qs argument of %qs intrinsic at %L has "
2224 "invalid shape in dimension %d (%ld/%ld)",
2225 gfc_current_intrinsic_arg
[1]->name
,
2226 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2227 mpz_get_si (array
->shape
[i
]),
2228 mpz_get_si (shift
->shape
[j
]));
2238 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2239 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2240 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2244 if (boundary
!= NULL
)
2246 if (!same_type_check (array
, 0, boundary
, 2))
2249 if (array
->rank
== 1 || boundary
->rank
== 0)
2251 if (!scalar_check (boundary
, 2))
2254 else if (boundary
->rank
== array
->rank
- 1)
2256 if (!gfc_check_conformance (shift
, boundary
,
2257 "arguments '%s' and '%s' for "
2259 gfc_current_intrinsic_arg
[1]->name
,
2260 gfc_current_intrinsic_arg
[2]->name
,
2261 gfc_current_intrinsic
))
2266 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2267 "rank %d or be a scalar",
2268 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2269 &shift
->where
, array
->rank
- 1);
2278 gfc_check_float (gfc_expr
*a
)
2280 if (!type_check (a
, 0, BT_INTEGER
))
2283 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2284 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2285 "kind argument to %s intrinsic at %L",
2286 gfc_current_intrinsic
, &a
->where
))
2292 /* A single complex argument. */
2295 gfc_check_fn_c (gfc_expr
*a
)
2297 if (!type_check (a
, 0, BT_COMPLEX
))
2304 /* A single real argument. */
2307 gfc_check_fn_r (gfc_expr
*a
)
2309 if (!type_check (a
, 0, BT_REAL
))
2315 /* A single double argument. */
2318 gfc_check_fn_d (gfc_expr
*a
)
2320 if (!double_check (a
, 0))
2326 /* A single real or complex argument. */
2329 gfc_check_fn_rc (gfc_expr
*a
)
2331 if (!real_or_complex_check (a
, 0))
2339 gfc_check_fn_rc2008 (gfc_expr
*a
)
2341 if (!real_or_complex_check (a
, 0))
2344 if (a
->ts
.type
== BT_COMPLEX
2345 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2346 "of %qs intrinsic at %L",
2347 gfc_current_intrinsic_arg
[0]->name
,
2348 gfc_current_intrinsic
, &a
->where
))
2356 gfc_check_fnum (gfc_expr
*unit
)
2358 if (!type_check (unit
, 0, BT_INTEGER
))
2361 if (!scalar_check (unit
, 0))
2369 gfc_check_huge (gfc_expr
*x
)
2371 if (!int_or_real_check (x
, 0))
2379 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2381 if (!type_check (x
, 0, BT_REAL
))
2383 if (!same_type_check (x
, 0, y
, 1))
2390 /* Check that the single argument is an integer. */
2393 gfc_check_i (gfc_expr
*i
)
2395 if (!type_check (i
, 0, BT_INTEGER
))
2403 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2405 if (!type_check (i
, 0, BT_INTEGER
))
2408 if (!type_check (j
, 1, BT_INTEGER
))
2411 if (i
->ts
.kind
!= j
->ts
.kind
)
2413 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2423 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2425 if (!type_check (i
, 0, BT_INTEGER
))
2428 if (!type_check (pos
, 1, BT_INTEGER
))
2431 if (!type_check (len
, 2, BT_INTEGER
))
2434 if (!nonnegative_check ("pos", pos
))
2437 if (!nonnegative_check ("len", len
))
2440 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2448 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2452 if (!type_check (c
, 0, BT_CHARACTER
))
2455 if (!kind_check (kind
, 1, BT_INTEGER
))
2458 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2459 "with KIND argument at %L",
2460 gfc_current_intrinsic
, &kind
->where
))
2463 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2469 /* Substring references don't have the charlength set. */
2471 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2474 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2478 /* Check that the argument is length one. Non-constant lengths
2479 can't be checked here, so assume they are ok. */
2480 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2482 /* If we already have a length for this expression then use it. */
2483 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2485 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2492 start
= ref
->u
.ss
.start
;
2493 end
= ref
->u
.ss
.end
;
2496 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2497 || start
->expr_type
!= EXPR_CONSTANT
)
2500 i
= mpz_get_si (end
->value
.integer
) + 1
2501 - mpz_get_si (start
->value
.integer
);
2509 gfc_error ("Argument of %s at %L must be of length one",
2510 gfc_current_intrinsic
, &c
->where
);
2519 gfc_check_idnint (gfc_expr
*a
)
2521 if (!double_check (a
, 0))
2529 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2531 if (!type_check (i
, 0, BT_INTEGER
))
2534 if (!type_check (j
, 1, BT_INTEGER
))
2537 if (i
->ts
.kind
!= j
->ts
.kind
)
2539 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2549 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2552 if (!type_check (string
, 0, BT_CHARACTER
)
2553 || !type_check (substring
, 1, BT_CHARACTER
))
2556 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2559 if (!kind_check (kind
, 3, BT_INTEGER
))
2561 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2562 "with KIND argument at %L",
2563 gfc_current_intrinsic
, &kind
->where
))
2566 if (string
->ts
.kind
!= substring
->ts
.kind
)
2568 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2569 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2570 gfc_current_intrinsic
, &substring
->where
,
2571 gfc_current_intrinsic_arg
[0]->name
);
2580 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2582 if (!numeric_check (x
, 0))
2585 if (!kind_check (kind
, 1, BT_INTEGER
))
2593 gfc_check_intconv (gfc_expr
*x
)
2595 if (!numeric_check (x
, 0))
2603 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2605 if (!type_check (i
, 0, BT_INTEGER
))
2608 if (!type_check (j
, 1, BT_INTEGER
))
2611 if (i
->ts
.kind
!= j
->ts
.kind
)
2613 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2623 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2625 if (!type_check (i
, 0, BT_INTEGER
)
2626 || !type_check (shift
, 1, BT_INTEGER
))
2629 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2637 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2639 if (!type_check (i
, 0, BT_INTEGER
)
2640 || !type_check (shift
, 1, BT_INTEGER
))
2647 if (!type_check (size
, 2, BT_INTEGER
))
2650 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2653 if (size
->expr_type
== EXPR_CONSTANT
)
2655 gfc_extract_int (size
, &i3
);
2658 gfc_error ("SIZE at %L must be positive", &size
->where
);
2662 if (shift
->expr_type
== EXPR_CONSTANT
)
2664 gfc_extract_int (shift
, &i2
);
2670 gfc_error ("The absolute value of SHIFT at %L must be less "
2671 "than or equal to SIZE at %L", &shift
->where
,
2678 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2686 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2688 if (!type_check (pid
, 0, BT_INTEGER
))
2691 if (!type_check (sig
, 1, BT_INTEGER
))
2699 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2701 if (!type_check (pid
, 0, BT_INTEGER
))
2704 if (!scalar_check (pid
, 0))
2707 if (!type_check (sig
, 1, BT_INTEGER
))
2710 if (!scalar_check (sig
, 1))
2716 if (!type_check (status
, 2, BT_INTEGER
))
2719 if (!scalar_check (status
, 2))
2727 gfc_check_kind (gfc_expr
*x
)
2729 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
2731 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2732 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2733 gfc_current_intrinsic
, &x
->where
);
2736 if (x
->ts
.type
== BT_PROCEDURE
)
2738 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2739 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2749 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2751 if (!array_check (array
, 0))
2754 if (!dim_check (dim
, 1, false))
2757 if (!dim_rank_check (dim
, array
, 1))
2760 if (!kind_check (kind
, 2, BT_INTEGER
))
2762 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2763 "with KIND argument at %L",
2764 gfc_current_intrinsic
, &kind
->where
))
2772 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2774 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2776 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2780 if (!coarray_check (coarray
, 0))
2785 if (!dim_check (dim
, 1, false))
2788 if (!dim_corank_check (dim
, coarray
))
2792 if (!kind_check (kind
, 2, BT_INTEGER
))
2800 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2802 if (!type_check (s
, 0, BT_CHARACTER
))
2805 if (!kind_check (kind
, 1, BT_INTEGER
))
2807 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2808 "with KIND argument at %L",
2809 gfc_current_intrinsic
, &kind
->where
))
2817 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2819 if (!type_check (a
, 0, BT_CHARACTER
))
2821 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2824 if (!type_check (b
, 1, BT_CHARACTER
))
2826 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2834 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2836 if (!type_check (path1
, 0, BT_CHARACTER
))
2838 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2841 if (!type_check (path2
, 1, BT_CHARACTER
))
2843 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2851 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2853 if (!type_check (path1
, 0, BT_CHARACTER
))
2855 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2858 if (!type_check (path2
, 1, BT_CHARACTER
))
2860 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2866 if (!type_check (status
, 2, BT_INTEGER
))
2869 if (!scalar_check (status
, 2))
2877 gfc_check_loc (gfc_expr
*expr
)
2879 return variable_check (expr
, 0, true);
2884 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2886 if (!type_check (path1
, 0, BT_CHARACTER
))
2888 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2891 if (!type_check (path2
, 1, BT_CHARACTER
))
2893 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2901 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
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
))
2916 if (!type_check (status
, 2, BT_INTEGER
))
2919 if (!scalar_check (status
, 2))
2927 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2929 if (!type_check (a
, 0, BT_LOGICAL
))
2931 if (!kind_check (kind
, 1, BT_LOGICAL
))
2938 /* Min/max family. */
2941 min_max_args (gfc_actual_arglist
*args
)
2943 gfc_actual_arglist
*arg
;
2944 int i
, j
, nargs
, *nlabels
, nlabelless
;
2945 bool a1
= false, a2
= false;
2947 if (args
== NULL
|| args
->next
== NULL
)
2949 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
2950 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2957 if (!args
->next
->name
)
2961 for (arg
= args
; arg
; arg
= arg
->next
)
2968 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2970 nlabels
= XALLOCAVEC (int, nargs
);
2971 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2977 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2979 n
= strtol (&arg
->name
[1], &endp
, 10);
2980 if (endp
[0] != '\0')
2984 if (n
<= nlabelless
)
2997 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
2998 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2999 gfc_current_intrinsic_where
);
3003 /* Check for duplicates. */
3004 for (i
= 0; i
< nargs
; i
++)
3005 for (j
= i
+ 1; j
< nargs
; j
++)
3006 if (nlabels
[i
] == nlabels
[j
])
3012 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3013 &arg
->expr
->where
, gfc_current_intrinsic
);
3017 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3018 &arg
->expr
->where
, gfc_current_intrinsic
);
3024 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3026 gfc_actual_arglist
*arg
, *tmp
;
3030 if (!min_max_args (arglist
))
3033 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3036 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3038 if (x
->ts
.type
== type
)
3040 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3041 "kinds at %L", &x
->where
))
3046 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3047 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3048 gfc_basic_typename (type
), kind
);
3053 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3054 if (!gfc_check_conformance (tmp
->expr
, x
,
3055 "arguments 'a%d' and 'a%d' for "
3056 "intrinsic '%s'", m
, n
,
3057 gfc_current_intrinsic
))
3066 gfc_check_min_max (gfc_actual_arglist
*arg
)
3070 if (!min_max_args (arg
))
3075 if (x
->ts
.type
== BT_CHARACTER
)
3077 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3078 "with CHARACTER argument at %L",
3079 gfc_current_intrinsic
, &x
->where
))
3082 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3084 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3085 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3089 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3094 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3096 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3101 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3103 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3108 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3110 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3114 /* End of min/max family. */
3117 gfc_check_malloc (gfc_expr
*size
)
3119 if (!type_check (size
, 0, BT_INTEGER
))
3122 if (!scalar_check (size
, 0))
3130 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3132 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3134 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3135 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3136 gfc_current_intrinsic
, &matrix_a
->where
);
3140 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3142 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3143 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3144 gfc_current_intrinsic
, &matrix_b
->where
);
3148 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3149 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3151 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3152 gfc_current_intrinsic
, &matrix_a
->where
,
3153 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3157 switch (matrix_a
->rank
)
3160 if (!rank_check (matrix_b
, 1, 2))
3162 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3163 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3165 gfc_error ("Different shape on dimension 1 for arguments %qs "
3166 "and %qs at %L for intrinsic matmul",
3167 gfc_current_intrinsic_arg
[0]->name
,
3168 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3174 if (matrix_b
->rank
!= 2)
3176 if (!rank_check (matrix_b
, 1, 1))
3179 /* matrix_b has rank 1 or 2 here. Common check for the cases
3180 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3181 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3182 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3184 gfc_error ("Different shape on dimension 2 for argument %qs and "
3185 "dimension 1 for argument %qs at %L for intrinsic "
3186 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3187 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3193 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3194 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3195 gfc_current_intrinsic
, &matrix_a
->where
);
3203 /* Whoever came up with this interface was probably on something.
3204 The possibilities for the occupation of the second and third
3211 NULL MASK minloc(array, mask=m)
3214 I.e. in the case of minloc(array,mask), mask will be in the second
3215 position of the argument list and we'll have to fix that up. */
3218 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3220 gfc_expr
*a
, *m
, *d
, *k
;
3223 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3227 m
= ap
->next
->next
->expr
;
3228 k
= ap
->next
->next
->next
->expr
;
3230 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3231 && ap
->next
->name
== NULL
)
3235 ap
->next
->expr
= NULL
;
3236 ap
->next
->next
->expr
= m
;
3239 if (!dim_check (d
, 1, false))
3242 if (!dim_rank_check (d
, a
, 0))
3245 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3249 && !gfc_check_conformance (a
, m
,
3250 "arguments '%s' and '%s' for intrinsic %s",
3251 gfc_current_intrinsic_arg
[0]->name
,
3252 gfc_current_intrinsic_arg
[2]->name
,
3253 gfc_current_intrinsic
))
3256 if (!kind_check (k
, 1, BT_INTEGER
))
3263 /* Similar to minloc/maxloc, the argument list might need to be
3264 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3265 difference is that MINLOC/MAXLOC take an additional KIND argument.
3266 The possibilities are:
3272 NULL MASK minval(array, mask=m)
3275 I.e. in the case of minval(array,mask), mask will be in the second
3276 position of the argument list and we'll have to fix that up. */
3279 check_reduction (gfc_actual_arglist
*ap
)
3281 gfc_expr
*a
, *m
, *d
;
3285 m
= ap
->next
->next
->expr
;
3287 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3288 && ap
->next
->name
== NULL
)
3292 ap
->next
->expr
= NULL
;
3293 ap
->next
->next
->expr
= m
;
3296 if (!dim_check (d
, 1, false))
3299 if (!dim_rank_check (d
, a
, 0))
3302 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3306 && !gfc_check_conformance (a
, m
,
3307 "arguments '%s' and '%s' for intrinsic %s",
3308 gfc_current_intrinsic_arg
[0]->name
,
3309 gfc_current_intrinsic_arg
[2]->name
,
3310 gfc_current_intrinsic
))
3318 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3320 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
3321 || !array_check (ap
->expr
, 0))
3324 return check_reduction (ap
);
3329 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3331 if (!numeric_check (ap
->expr
, 0)
3332 || !array_check (ap
->expr
, 0))
3335 return check_reduction (ap
);
3339 /* For IANY, IALL and IPARITY. */
3342 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3346 if (!type_check (i
, 0, BT_INTEGER
))
3349 if (!nonnegative_check ("I", i
))
3352 if (!kind_check (kind
, 1, BT_INTEGER
))
3356 gfc_extract_int (kind
, &k
);
3358 k
= gfc_default_integer_kind
;
3360 if (!less_than_bitsizekind ("I", i
, k
))
3368 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3370 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3372 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3373 gfc_current_intrinsic_arg
[0]->name
,
3374 gfc_current_intrinsic
, &ap
->expr
->where
);
3378 if (!array_check (ap
->expr
, 0))
3381 return check_reduction (ap
);
3386 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3388 if (!same_type_check (tsource
, 0, fsource
, 1))
3391 if (!type_check (mask
, 2, BT_LOGICAL
))
3394 if (tsource
->ts
.type
== BT_CHARACTER
)
3395 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3402 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3404 if (!type_check (i
, 0, BT_INTEGER
))
3407 if (!type_check (j
, 1, BT_INTEGER
))
3410 if (!type_check (mask
, 2, BT_INTEGER
))
3413 if (!same_type_check (i
, 0, j
, 1))
3416 if (!same_type_check (i
, 0, mask
, 2))
3424 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3426 if (!variable_check (from
, 0, false))
3428 if (!allocatable_check (from
, 0))
3430 if (gfc_is_coindexed (from
))
3432 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3433 "coindexed", &from
->where
);
3437 if (!variable_check (to
, 1, false))
3439 if (!allocatable_check (to
, 1))
3441 if (gfc_is_coindexed (to
))
3443 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3444 "coindexed", &to
->where
);
3448 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3450 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3451 "polymorphic if FROM is polymorphic",
3456 if (!same_type_check (to
, 1, from
, 0))
3459 if (to
->rank
!= from
->rank
)
3461 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3462 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3467 /* IR F08/0040; cf. 12-006A. */
3468 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3470 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3471 "must have the same corank %d/%d", &to
->where
,
3472 gfc_get_corank (from
), gfc_get_corank (to
));
3476 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3477 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3478 and cmp2 are allocatable. After the allocation is transferred,
3479 the 'to' chain is broken by the nullification of the 'from'. A bit
3480 of reflection reveals that this can only occur for derived types
3481 with recursive allocatable components. */
3482 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3483 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3485 gfc_ref
*to_ref
, *from_ref
;
3487 from_ref
= from
->ref
;
3488 bool aliasing
= true;
3490 for (; from_ref
&& to_ref
;
3491 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3493 if (to_ref
->type
!= from
->ref
->type
)
3495 else if (to_ref
->type
== REF_ARRAY
3496 && to_ref
->u
.ar
.type
!= AR_FULL
3497 && from_ref
->u
.ar
.type
!= AR_FULL
)
3498 /* Play safe; assume sections and elements are different. */
3500 else if (to_ref
->type
== REF_COMPONENT
3501 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3510 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3511 "restrictions (F2003 12.4.1.7)", &to
->where
);
3516 /* CLASS arguments: Make sure the vtab of from is present. */
3517 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3518 gfc_find_vtab (&from
->ts
);
3525 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3527 if (!type_check (x
, 0, BT_REAL
))
3530 if (!type_check (s
, 1, BT_REAL
))
3533 if (s
->expr_type
== EXPR_CONSTANT
)
3535 if (mpfr_sgn (s
->value
.real
) == 0)
3537 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3548 gfc_check_new_line (gfc_expr
*a
)
3550 if (!type_check (a
, 0, BT_CHARACTER
))
3558 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3560 if (!type_check (array
, 0, BT_REAL
))
3563 if (!array_check (array
, 0))
3566 if (!dim_rank_check (dim
, array
, false))
3573 gfc_check_null (gfc_expr
*mold
)
3575 symbol_attribute attr
;
3580 if (!variable_check (mold
, 0, true))
3583 attr
= gfc_variable_attr (mold
, NULL
);
3585 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3587 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3588 "ALLOCATABLE or procedure pointer",
3589 gfc_current_intrinsic_arg
[0]->name
,
3590 gfc_current_intrinsic
, &mold
->where
);
3594 if (attr
.allocatable
3595 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3596 "allocatable MOLD at %L", &mold
->where
))
3600 if (gfc_is_coindexed (mold
))
3602 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3603 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3604 gfc_current_intrinsic
, &mold
->where
);
3613 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3615 if (!array_check (array
, 0))
3618 if (!type_check (mask
, 1, BT_LOGICAL
))
3621 if (!gfc_check_conformance (array
, mask
,
3622 "arguments '%s' and '%s' for intrinsic '%s'",
3623 gfc_current_intrinsic_arg
[0]->name
,
3624 gfc_current_intrinsic_arg
[1]->name
,
3625 gfc_current_intrinsic
))
3630 mpz_t array_size
, vector_size
;
3631 bool have_array_size
, have_vector_size
;
3633 if (!same_type_check (array
, 0, vector
, 2))
3636 if (!rank_check (vector
, 2, 1))
3639 /* VECTOR requires at least as many elements as MASK
3640 has .TRUE. values. */
3641 have_array_size
= gfc_array_size(array
, &array_size
);
3642 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3644 if (have_vector_size
3645 && (mask
->expr_type
== EXPR_ARRAY
3646 || (mask
->expr_type
== EXPR_CONSTANT
3647 && have_array_size
)))
3649 int mask_true_values
= 0;
3651 if (mask
->expr_type
== EXPR_ARRAY
)
3653 gfc_constructor
*mask_ctor
;
3654 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3657 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3659 mask_true_values
= 0;
3663 if (mask_ctor
->expr
->value
.logical
)
3666 mask_ctor
= gfc_constructor_next (mask_ctor
);
3669 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3670 mask_true_values
= mpz_get_si (array_size
);
3672 if (mpz_get_si (vector_size
) < mask_true_values
)
3674 gfc_error ("%qs argument of %qs intrinsic at %L must "
3675 "provide at least as many elements as there "
3676 "are .TRUE. values in %qs (%ld/%d)",
3677 gfc_current_intrinsic_arg
[2]->name
,
3678 gfc_current_intrinsic
, &vector
->where
,
3679 gfc_current_intrinsic_arg
[1]->name
,
3680 mpz_get_si (vector_size
), mask_true_values
);
3685 if (have_array_size
)
3686 mpz_clear (array_size
);
3687 if (have_vector_size
)
3688 mpz_clear (vector_size
);
3696 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3698 if (!type_check (mask
, 0, BT_LOGICAL
))
3701 if (!array_check (mask
, 0))
3704 if (!dim_rank_check (dim
, mask
, false))
3712 gfc_check_precision (gfc_expr
*x
)
3714 if (!real_or_complex_check (x
, 0))
3722 gfc_check_present (gfc_expr
*a
)
3726 if (!variable_check (a
, 0, true))
3729 sym
= a
->symtree
->n
.sym
;
3730 if (!sym
->attr
.dummy
)
3732 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3733 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3734 gfc_current_intrinsic
, &a
->where
);
3738 if (!sym
->attr
.optional
)
3740 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3741 "an OPTIONAL dummy variable",
3742 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3747 /* 13.14.82 PRESENT(A)
3749 Argument. A shall be the name of an optional dummy argument that is
3750 accessible in the subprogram in which the PRESENT function reference
3754 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3755 && (a
->ref
->u
.ar
.type
== AR_FULL
3756 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3757 && a
->ref
->u
.ar
.as
->rank
== 0))))
3759 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3760 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3761 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3770 gfc_check_radix (gfc_expr
*x
)
3772 if (!int_or_real_check (x
, 0))
3780 gfc_check_range (gfc_expr
*x
)
3782 if (!numeric_check (x
, 0))
3790 gfc_check_rank (gfc_expr
*a
)
3792 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3793 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3795 bool is_variable
= true;
3797 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3798 if (a
->expr_type
== EXPR_FUNCTION
)
3799 is_variable
= a
->value
.function
.esym
3800 ? a
->value
.function
.esym
->result
->attr
.pointer
3801 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3803 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3804 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3807 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3808 "object", &a
->where
);
3816 /* real, float, sngl. */
3818 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3820 if (!numeric_check (a
, 0))
3823 if (!kind_check (kind
, 1, BT_REAL
))
3831 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3833 if (!type_check (path1
, 0, BT_CHARACTER
))
3835 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3838 if (!type_check (path2
, 1, BT_CHARACTER
))
3840 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3848 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3850 if (!type_check (path1
, 0, BT_CHARACTER
))
3852 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3855 if (!type_check (path2
, 1, BT_CHARACTER
))
3857 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3863 if (!type_check (status
, 2, BT_INTEGER
))
3866 if (!scalar_check (status
, 2))
3874 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3876 if (!type_check (x
, 0, BT_CHARACTER
))
3879 if (!scalar_check (x
, 0))
3882 if (!type_check (y
, 0, BT_INTEGER
))
3885 if (!scalar_check (y
, 1))
3893 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3894 gfc_expr
*pad
, gfc_expr
*order
)
3900 if (!array_check (source
, 0))
3903 if (!rank_check (shape
, 1, 1))
3906 if (!type_check (shape
, 1, BT_INTEGER
))
3909 if (!gfc_array_size (shape
, &size
))
3911 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3912 "array of constant size", &shape
->where
);
3916 shape_size
= mpz_get_ui (size
);
3919 if (shape_size
<= 0)
3921 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3922 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3926 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3928 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
3929 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3932 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3936 for (i
= 0; i
< shape_size
; ++i
)
3938 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3939 if (e
->expr_type
!= EXPR_CONSTANT
)
3942 gfc_extract_int (e
, &extent
);
3945 gfc_error ("%qs argument of %qs intrinsic at %L has "
3946 "negative element (%d)",
3947 gfc_current_intrinsic_arg
[1]->name
,
3948 gfc_current_intrinsic
, &e
->where
, extent
);
3953 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
3954 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
3955 && shape
->ref
->u
.ar
.as
3956 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
3957 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
3958 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
3959 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
3960 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
3965 v
= shape
->symtree
->n
.sym
->value
;
3967 for (i
= 0; i
< shape_size
; i
++)
3969 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
3973 gfc_extract_int (e
, &extent
);
3977 gfc_error ("Element %d of actual argument of RESHAPE at %L "
3978 "cannot be negative", i
+ 1, &shape
->where
);
3986 if (!same_type_check (source
, 0, pad
, 2))
3989 if (!array_check (pad
, 2))
3995 if (!array_check (order
, 3))
3998 if (!type_check (order
, 3, BT_INTEGER
))
4001 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4003 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4006 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4009 gfc_array_size (order
, &size
);
4010 order_size
= mpz_get_ui (size
);
4013 if (order_size
!= shape_size
)
4015 gfc_error ("%qs argument of %qs intrinsic at %L "
4016 "has wrong number of elements (%d/%d)",
4017 gfc_current_intrinsic_arg
[3]->name
,
4018 gfc_current_intrinsic
, &order
->where
,
4019 order_size
, shape_size
);
4023 for (i
= 1; i
<= order_size
; ++i
)
4025 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4026 if (e
->expr_type
!= EXPR_CONSTANT
)
4029 gfc_extract_int (e
, &dim
);
4031 if (dim
< 1 || dim
> order_size
)
4033 gfc_error ("%qs argument of %qs intrinsic at %L "
4034 "has out-of-range dimension (%d)",
4035 gfc_current_intrinsic_arg
[3]->name
,
4036 gfc_current_intrinsic
, &e
->where
, dim
);
4040 if (perm
[dim
-1] != 0)
4042 gfc_error ("%qs argument of %qs intrinsic at %L has "
4043 "invalid permutation of dimensions (dimension "
4045 gfc_current_intrinsic_arg
[3]->name
,
4046 gfc_current_intrinsic
, &e
->where
, dim
);
4055 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4056 && gfc_is_constant_expr (shape
)
4057 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4058 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4060 /* Check the match in size between source and destination. */
4061 if (gfc_array_size (source
, &nelems
))
4067 mpz_init_set_ui (size
, 1);
4068 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4069 c
; c
= gfc_constructor_next (c
))
4070 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4072 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4078 gfc_error ("Without padding, there are not enough elements "
4079 "in the intrinsic RESHAPE source at %L to match "
4080 "the shape", &source
->where
);
4091 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4093 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4095 gfc_error ("%qs argument of %qs intrinsic at %L "
4096 "cannot be of type %s",
4097 gfc_current_intrinsic_arg
[0]->name
,
4098 gfc_current_intrinsic
,
4099 &a
->where
, gfc_typename (&a
->ts
));
4103 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4105 gfc_error ("%qs argument of %qs intrinsic at %L "
4106 "must be of an extensible type",
4107 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4112 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4114 gfc_error ("%qs argument of %qs intrinsic at %L "
4115 "cannot be of type %s",
4116 gfc_current_intrinsic_arg
[0]->name
,
4117 gfc_current_intrinsic
,
4118 &b
->where
, gfc_typename (&b
->ts
));
4122 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4124 gfc_error ("%qs argument of %qs intrinsic at %L "
4125 "must be of an extensible type",
4126 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4136 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4138 if (!type_check (x
, 0, BT_REAL
))
4141 if (!type_check (i
, 1, BT_INTEGER
))
4149 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4151 if (!type_check (x
, 0, BT_CHARACTER
))
4154 if (!type_check (y
, 1, BT_CHARACTER
))
4157 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4160 if (!kind_check (kind
, 3, BT_INTEGER
))
4162 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4163 "with KIND argument at %L",
4164 gfc_current_intrinsic
, &kind
->where
))
4167 if (!same_type_check (x
, 0, y
, 1))
4175 gfc_check_secnds (gfc_expr
*r
)
4177 if (!type_check (r
, 0, BT_REAL
))
4180 if (!kind_value_check (r
, 0, 4))
4183 if (!scalar_check (r
, 0))
4191 gfc_check_selected_char_kind (gfc_expr
*name
)
4193 if (!type_check (name
, 0, BT_CHARACTER
))
4196 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4199 if (!scalar_check (name
, 0))
4207 gfc_check_selected_int_kind (gfc_expr
*r
)
4209 if (!type_check (r
, 0, BT_INTEGER
))
4212 if (!scalar_check (r
, 0))
4220 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4222 if (p
== NULL
&& r
== NULL
4223 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4224 " neither %<P%> nor %<R%> argument at %L",
4225 gfc_current_intrinsic_where
))
4230 if (!type_check (p
, 0, BT_INTEGER
))
4233 if (!scalar_check (p
, 0))
4239 if (!type_check (r
, 1, BT_INTEGER
))
4242 if (!scalar_check (r
, 1))
4248 if (!type_check (radix
, 1, BT_INTEGER
))
4251 if (!scalar_check (radix
, 1))
4254 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4255 "RADIX argument at %L", gfc_current_intrinsic
,
4265 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4267 if (!type_check (x
, 0, BT_REAL
))
4270 if (!type_check (i
, 1, BT_INTEGER
))
4278 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4282 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4285 ar
= gfc_find_array_ref (source
);
4287 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4289 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4290 "an assumed size array", &source
->where
);
4294 if (!kind_check (kind
, 1, BT_INTEGER
))
4296 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4297 "with KIND argument at %L",
4298 gfc_current_intrinsic
, &kind
->where
))
4306 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4308 if (!type_check (i
, 0, BT_INTEGER
))
4311 if (!type_check (shift
, 0, BT_INTEGER
))
4314 if (!nonnegative_check ("SHIFT", shift
))
4317 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4325 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4327 if (!int_or_real_check (a
, 0))
4330 if (!same_type_check (a
, 0, b
, 1))
4338 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4340 if (!array_check (array
, 0))
4343 if (!dim_check (dim
, 1, true))
4346 if (!dim_rank_check (dim
, array
, 0))
4349 if (!kind_check (kind
, 2, BT_INTEGER
))
4351 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4352 "with KIND argument at %L",
4353 gfc_current_intrinsic
, &kind
->where
))
4362 gfc_check_sizeof (gfc_expr
*arg
)
4364 if (arg
->ts
.type
== BT_PROCEDURE
)
4366 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4367 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4372 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4373 if (arg
->ts
.type
== BT_ASSUMED
4374 && (arg
->symtree
->n
.sym
->as
== NULL
4375 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4376 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4377 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4379 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4380 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4385 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4386 && arg
->symtree
->n
.sym
->as
!= NULL
4387 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4388 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4390 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4391 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4392 gfc_current_intrinsic
, &arg
->where
);
4400 /* Check whether an expression is interoperable. When returning false,
4401 msg is set to a string telling why the expression is not interoperable,
4402 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4403 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4404 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4405 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4409 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4413 if (expr
->ts
.type
== BT_CLASS
)
4415 *msg
= "Expression is polymorphic";
4419 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4420 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4422 *msg
= "Expression is a noninteroperable derived type";
4426 if (expr
->ts
.type
== BT_PROCEDURE
)
4428 *msg
= "Procedure unexpected as argument";
4432 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4435 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4436 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4438 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4442 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4443 && expr
->ts
.kind
!= 1)
4445 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4449 if (expr
->ts
.type
== BT_CHARACTER
) {
4450 if (expr
->ts
.deferred
)
4452 /* TS 29113 allows deferred-length strings as dummy arguments,
4453 but it is not an interoperable type. */
4454 *msg
= "Expression shall not be a deferred-length string";
4458 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4459 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4460 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4462 if (!c_loc
&& expr
->ts
.u
.cl
4463 && (!expr
->ts
.u
.cl
->length
4464 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4465 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4467 *msg
= "Type shall have a character length of 1";
4472 /* Note: The following checks are about interoperatable variables, Fortran
4473 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4474 is allowed, e.g. assumed-shape arrays with TS 29113. */
4476 if (gfc_is_coarray (expr
))
4478 *msg
= "Coarrays are not interoperable";
4482 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4484 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4485 if (ar
->type
!= AR_FULL
)
4487 *msg
= "Only whole-arrays are interoperable";
4490 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4491 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4493 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4503 gfc_check_c_sizeof (gfc_expr
*arg
)
4507 if (!is_c_interoperable (arg
, &msg
, false, false))
4509 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4510 "interoperable data entity: %s",
4511 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4516 if (arg
->ts
.type
== BT_ASSUMED
)
4518 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4520 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4525 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4526 && arg
->symtree
->n
.sym
->as
!= NULL
4527 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4528 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4530 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4531 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4532 gfc_current_intrinsic
, &arg
->where
);
4541 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4543 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4544 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4545 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4546 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4548 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4549 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4553 if (!scalar_check (c_ptr_1
, 0))
4557 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4558 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4559 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4560 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4562 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4563 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4564 gfc_typename (&c_ptr_1
->ts
),
4565 gfc_typename (&c_ptr_2
->ts
));
4569 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4577 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4579 symbol_attribute attr
;
4582 if (cptr
->ts
.type
!= BT_DERIVED
4583 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4584 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4586 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4587 "type TYPE(C_PTR)", &cptr
->where
);
4591 if (!scalar_check (cptr
, 0))
4594 attr
= gfc_expr_attr (fptr
);
4598 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4603 if (fptr
->ts
.type
== BT_CLASS
)
4605 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4610 if (gfc_is_coindexed (fptr
))
4612 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4613 "coindexed", &fptr
->where
);
4617 if (fptr
->rank
== 0 && shape
)
4619 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4620 "FPTR", &fptr
->where
);
4623 else if (fptr
->rank
&& !shape
)
4625 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4626 "FPTR at %L", &fptr
->where
);
4630 if (shape
&& !rank_check (shape
, 2, 1))
4633 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4639 if (gfc_array_size (shape
, &size
))
4641 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4644 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4645 "size as the RANK of FPTR", &shape
->where
);
4652 if (fptr
->ts
.type
== BT_CLASS
)
4654 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4658 if (!is_c_interoperable (fptr
, &msg
, false, true))
4659 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4660 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4667 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4669 symbol_attribute attr
;
4671 if (cptr
->ts
.type
!= BT_DERIVED
4672 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4673 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4675 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4676 "type TYPE(C_FUNPTR)", &cptr
->where
);
4680 if (!scalar_check (cptr
, 0))
4683 attr
= gfc_expr_attr (fptr
);
4685 if (!attr
.proc_pointer
)
4687 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4688 "pointer", &fptr
->where
);
4692 if (gfc_is_coindexed (fptr
))
4694 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4695 "coindexed", &fptr
->where
);
4699 if (!attr
.is_bind_c
)
4700 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4701 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4708 gfc_check_c_funloc (gfc_expr
*x
)
4710 symbol_attribute attr
;
4712 if (gfc_is_coindexed (x
))
4714 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4715 "coindexed", &x
->where
);
4719 attr
= gfc_expr_attr (x
);
4721 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4722 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4724 gfc_namespace
*ns
= gfc_current_ns
;
4726 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4727 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4729 gfc_error ("Function result %qs at %L is invalid as X argument "
4730 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4735 if (attr
.flavor
!= FL_PROCEDURE
)
4737 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4738 "or a procedure pointer", &x
->where
);
4742 if (!attr
.is_bind_c
)
4743 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4744 "at %L to C_FUNLOC", &x
->where
);
4750 gfc_check_c_loc (gfc_expr
*x
)
4752 symbol_attribute attr
;
4755 if (gfc_is_coindexed (x
))
4757 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4761 if (x
->ts
.type
== BT_CLASS
)
4763 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4768 attr
= gfc_expr_attr (x
);
4771 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4772 || attr
.flavor
== FL_PARAMETER
))
4774 gfc_error ("Argument X at %L to C_LOC shall have either "
4775 "the POINTER or the TARGET attribute", &x
->where
);
4779 if (x
->ts
.type
== BT_CHARACTER
4780 && gfc_var_strlen (x
) == 0)
4782 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4783 "string", &x
->where
);
4787 if (!is_c_interoperable (x
, &msg
, true, false))
4789 if (x
->ts
.type
== BT_CLASS
)
4791 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4797 && !gfc_notify_std (GFC_STD_F2008_TS
,
4798 "Noninteroperable array at %L as"
4799 " argument to C_LOC: %s", &x
->where
, msg
))
4802 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4804 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4806 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4807 && !attr
.allocatable
4808 && !gfc_notify_std (GFC_STD_F2008
,
4809 "Array of interoperable type at %L "
4810 "to C_LOC which is nonallocatable and neither "
4811 "assumed size nor explicit size", &x
->where
))
4813 else if (ar
->type
!= AR_FULL
4814 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4815 "to C_LOC", &x
->where
))
4824 gfc_check_sleep_sub (gfc_expr
*seconds
)
4826 if (!type_check (seconds
, 0, BT_INTEGER
))
4829 if (!scalar_check (seconds
, 0))
4836 gfc_check_sngl (gfc_expr
*a
)
4838 if (!type_check (a
, 0, BT_REAL
))
4841 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4842 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4843 "REAL argument to %s intrinsic at %L",
4844 gfc_current_intrinsic
, &a
->where
))
4851 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4853 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4855 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4856 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4857 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4865 if (!dim_check (dim
, 1, false))
4868 /* dim_rank_check() does not apply here. */
4870 && dim
->expr_type
== EXPR_CONSTANT
4871 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4872 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4874 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4875 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4876 gfc_current_intrinsic
, &dim
->where
);
4880 if (!type_check (ncopies
, 2, BT_INTEGER
))
4883 if (!scalar_check (ncopies
, 2))
4890 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4894 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4896 if (!type_check (unit
, 0, BT_INTEGER
))
4899 if (!scalar_check (unit
, 0))
4902 if (!type_check (c
, 1, BT_CHARACTER
))
4904 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4910 if (!type_check (status
, 2, BT_INTEGER
)
4911 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4912 || !scalar_check (status
, 2))
4920 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4922 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4927 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4929 if (!type_check (c
, 0, BT_CHARACTER
))
4931 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4937 if (!type_check (status
, 1, BT_INTEGER
)
4938 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4939 || !scalar_check (status
, 1))
4947 gfc_check_fgetput (gfc_expr
*c
)
4949 return gfc_check_fgetput_sub (c
, NULL
);
4954 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4956 if (!type_check (unit
, 0, BT_INTEGER
))
4959 if (!scalar_check (unit
, 0))
4962 if (!type_check (offset
, 1, BT_INTEGER
))
4965 if (!scalar_check (offset
, 1))
4968 if (!type_check (whence
, 2, BT_INTEGER
))
4971 if (!scalar_check (whence
, 2))
4977 if (!type_check (status
, 3, BT_INTEGER
))
4980 if (!kind_value_check (status
, 3, 4))
4983 if (!scalar_check (status
, 3))
4992 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4994 if (!type_check (unit
, 0, BT_INTEGER
))
4997 if (!scalar_check (unit
, 0))
5000 if (!type_check (array
, 1, BT_INTEGER
)
5001 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5004 if (!array_check (array
, 1))
5012 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5014 if (!type_check (unit
, 0, BT_INTEGER
))
5017 if (!scalar_check (unit
, 0))
5020 if (!type_check (array
, 1, BT_INTEGER
)
5021 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5024 if (!array_check (array
, 1))
5030 if (!type_check (status
, 2, BT_INTEGER
)
5031 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5034 if (!scalar_check (status
, 2))
5042 gfc_check_ftell (gfc_expr
*unit
)
5044 if (!type_check (unit
, 0, BT_INTEGER
))
5047 if (!scalar_check (unit
, 0))
5055 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5057 if (!type_check (unit
, 0, BT_INTEGER
))
5060 if (!scalar_check (unit
, 0))
5063 if (!type_check (offset
, 1, BT_INTEGER
))
5066 if (!scalar_check (offset
, 1))
5074 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5076 if (!type_check (name
, 0, BT_CHARACTER
))
5078 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5081 if (!type_check (array
, 1, BT_INTEGER
)
5082 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5085 if (!array_check (array
, 1))
5093 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5095 if (!type_check (name
, 0, BT_CHARACTER
))
5097 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5100 if (!type_check (array
, 1, BT_INTEGER
)
5101 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5104 if (!array_check (array
, 1))
5110 if (!type_check (status
, 2, BT_INTEGER
)
5111 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5114 if (!scalar_check (status
, 2))
5122 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5126 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5128 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5132 if (!coarray_check (coarray
, 0))
5137 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5138 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5142 if (gfc_array_size (sub
, &nelems
))
5144 int corank
= gfc_get_corank (coarray
);
5146 if (mpz_cmp_ui (nelems
, corank
) != 0)
5148 gfc_error ("The number of array elements of the SUB argument to "
5149 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5150 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5162 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5164 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5166 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5172 if (!type_check (distance
, 0, BT_INTEGER
))
5175 if (!nonnegative_check ("DISTANCE", distance
))
5178 if (!scalar_check (distance
, 0))
5181 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5182 "NUM_IMAGES at %L", &distance
->where
))
5188 if (!type_check (failed
, 1, BT_LOGICAL
))
5191 if (!scalar_check (failed
, 1))
5194 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5195 "NUM_IMAGES at %L", &failed
->where
))
5204 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5206 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5208 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5212 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5215 if (dim
!= NULL
&& coarray
== NULL
)
5217 gfc_error ("DIM argument without COARRAY argument not allowed for "
5218 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5222 if (distance
&& (coarray
|| dim
))
5224 gfc_error ("The DISTANCE argument may not be specified together with the "
5225 "COARRAY or DIM argument in intrinsic at %L",
5230 /* Assume that we have "this_image (distance)". */
5231 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5235 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5244 if (!type_check (distance
, 2, BT_INTEGER
))
5247 if (!nonnegative_check ("DISTANCE", distance
))
5250 if (!scalar_check (distance
, 2))
5253 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5254 "THIS_IMAGE at %L", &distance
->where
))
5260 if (!coarray_check (coarray
, 0))
5265 if (!dim_check (dim
, 1, false))
5268 if (!dim_corank_check (dim
, coarray
))
5275 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5276 by gfc_simplify_transfer. Return false if we cannot do so. */
5279 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5280 size_t *source_size
, size_t *result_size
,
5281 size_t *result_length_p
)
5283 size_t result_elt_size
;
5285 if (source
->expr_type
== EXPR_FUNCTION
)
5288 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5291 /* Calculate the size of the source. */
5292 *source_size
= gfc_target_expr_size (source
);
5293 if (*source_size
== 0)
5296 /* Determine the size of the element. */
5297 result_elt_size
= gfc_element_size (mold
);
5298 if (result_elt_size
== 0)
5301 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5306 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5309 result_length
= *source_size
/ result_elt_size
;
5310 if (result_length
* result_elt_size
< *source_size
)
5314 *result_size
= result_length
* result_elt_size
;
5315 if (result_length_p
)
5316 *result_length_p
= result_length
;
5319 *result_size
= result_elt_size
;
5326 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5331 if (mold
->ts
.type
== BT_HOLLERITH
)
5333 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5334 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5340 if (!type_check (size
, 2, BT_INTEGER
))
5343 if (!scalar_check (size
, 2))
5346 if (!nonoptional_check (size
, 2))
5350 if (!warn_surprising
)
5353 /* If we can't calculate the sizes, we cannot check any more.
5354 Return true for that case. */
5356 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5357 &result_size
, NULL
))
5360 if (source_size
< result_size
)
5361 gfc_warning (OPT_Wsurprising
,
5362 "Intrinsic TRANSFER at %L has partly undefined result: "
5363 "source size %ld < result size %ld", &source
->where
,
5364 (long) source_size
, (long) result_size
);
5371 gfc_check_transpose (gfc_expr
*matrix
)
5373 if (!rank_check (matrix
, 0, 2))
5381 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5383 if (!array_check (array
, 0))
5386 if (!dim_check (dim
, 1, false))
5389 if (!dim_rank_check (dim
, array
, 0))
5392 if (!kind_check (kind
, 2, BT_INTEGER
))
5394 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5395 "with KIND argument at %L",
5396 gfc_current_intrinsic
, &kind
->where
))
5404 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5406 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5408 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5412 if (!coarray_check (coarray
, 0))
5417 if (!dim_check (dim
, 1, false))
5420 if (!dim_corank_check (dim
, coarray
))
5424 if (!kind_check (kind
, 2, BT_INTEGER
))
5432 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5436 if (!rank_check (vector
, 0, 1))
5439 if (!array_check (mask
, 1))
5442 if (!type_check (mask
, 1, BT_LOGICAL
))
5445 if (!same_type_check (vector
, 0, field
, 2))
5448 if (mask
->expr_type
== EXPR_ARRAY
5449 && gfc_array_size (vector
, &vector_size
))
5451 int mask_true_count
= 0;
5452 gfc_constructor
*mask_ctor
;
5453 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5456 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5458 mask_true_count
= 0;
5462 if (mask_ctor
->expr
->value
.logical
)
5465 mask_ctor
= gfc_constructor_next (mask_ctor
);
5468 if (mpz_get_si (vector_size
) < mask_true_count
)
5470 gfc_error ("%qs argument of %qs intrinsic at %L must "
5471 "provide at least as many elements as there "
5472 "are .TRUE. values in %qs (%ld/%d)",
5473 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5474 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5475 mpz_get_si (vector_size
), mask_true_count
);
5479 mpz_clear (vector_size
);
5482 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5484 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5485 "the same rank as %qs or be a scalar",
5486 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5487 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5491 if (mask
->rank
== field
->rank
)
5494 for (i
= 0; i
< field
->rank
; i
++)
5495 if (! identical_dimen_shape (mask
, i
, field
, i
))
5497 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5498 "must have identical shape.",
5499 gfc_current_intrinsic_arg
[2]->name
,
5500 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5510 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5512 if (!type_check (x
, 0, BT_CHARACTER
))
5515 if (!same_type_check (x
, 0, y
, 1))
5518 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5521 if (!kind_check (kind
, 3, BT_INTEGER
))
5523 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5524 "with KIND argument at %L",
5525 gfc_current_intrinsic
, &kind
->where
))
5533 gfc_check_trim (gfc_expr
*x
)
5535 if (!type_check (x
, 0, BT_CHARACTER
))
5538 if (!scalar_check (x
, 0))
5546 gfc_check_ttynam (gfc_expr
*unit
)
5548 if (!scalar_check (unit
, 0))
5551 if (!type_check (unit
, 0, BT_INTEGER
))
5558 /************* Check functions for intrinsic subroutines *************/
5561 gfc_check_cpu_time (gfc_expr
*time
)
5563 if (!scalar_check (time
, 0))
5566 if (!type_check (time
, 0, BT_REAL
))
5569 if (!variable_check (time
, 0, false))
5577 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5578 gfc_expr
*zone
, gfc_expr
*values
)
5582 if (!type_check (date
, 0, BT_CHARACTER
))
5584 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5586 if (!scalar_check (date
, 0))
5588 if (!variable_check (date
, 0, false))
5594 if (!type_check (time
, 1, BT_CHARACTER
))
5596 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5598 if (!scalar_check (time
, 1))
5600 if (!variable_check (time
, 1, false))
5606 if (!type_check (zone
, 2, BT_CHARACTER
))
5608 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5610 if (!scalar_check (zone
, 2))
5612 if (!variable_check (zone
, 2, false))
5618 if (!type_check (values
, 3, BT_INTEGER
))
5620 if (!array_check (values
, 3))
5622 if (!rank_check (values
, 3, 1))
5624 if (!variable_check (values
, 3, false))
5633 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5634 gfc_expr
*to
, gfc_expr
*topos
)
5636 if (!type_check (from
, 0, BT_INTEGER
))
5639 if (!type_check (frompos
, 1, BT_INTEGER
))
5642 if (!type_check (len
, 2, BT_INTEGER
))
5645 if (!same_type_check (from
, 0, to
, 3))
5648 if (!variable_check (to
, 3, false))
5651 if (!type_check (topos
, 4, BT_INTEGER
))
5654 if (!nonnegative_check ("frompos", frompos
))
5657 if (!nonnegative_check ("topos", topos
))
5660 if (!nonnegative_check ("len", len
))
5663 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5666 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5674 gfc_check_random_number (gfc_expr
*harvest
)
5676 if (!type_check (harvest
, 0, BT_REAL
))
5679 if (!variable_check (harvest
, 0, false))
5687 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5689 unsigned int nargs
= 0, seed_size
;
5690 locus
*where
= NULL
;
5691 mpz_t put_size
, get_size
;
5693 /* Keep the number of bytes in sync with master_state in
5694 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5695 part of the state too. */
5696 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5700 if (size
->expr_type
!= EXPR_VARIABLE
5701 || !size
->symtree
->n
.sym
->attr
.optional
)
5704 if (!scalar_check (size
, 0))
5707 if (!type_check (size
, 0, BT_INTEGER
))
5710 if (!variable_check (size
, 0, false))
5713 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5719 if (put
->expr_type
!= EXPR_VARIABLE
5720 || !put
->symtree
->n
.sym
->attr
.optional
)
5723 where
= &put
->where
;
5726 if (!array_check (put
, 1))
5729 if (!rank_check (put
, 1, 1))
5732 if (!type_check (put
, 1, BT_INTEGER
))
5735 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5738 if (gfc_array_size (put
, &put_size
)
5739 && mpz_get_ui (put_size
) < seed_size
)
5740 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5741 "too small (%i/%i)",
5742 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5743 where
, (int) mpz_get_ui (put_size
), seed_size
);
5748 if (get
->expr_type
!= EXPR_VARIABLE
5749 || !get
->symtree
->n
.sym
->attr
.optional
)
5752 where
= &get
->where
;
5755 if (!array_check (get
, 2))
5758 if (!rank_check (get
, 2, 1))
5761 if (!type_check (get
, 2, BT_INTEGER
))
5764 if (!variable_check (get
, 2, false))
5767 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5770 if (gfc_array_size (get
, &get_size
)
5771 && mpz_get_ui (get_size
) < seed_size
)
5772 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5773 "too small (%i/%i)",
5774 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5775 where
, (int) mpz_get_ui (get_size
), seed_size
);
5778 /* RANDOM_SEED may not have more than one non-optional argument. */
5780 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5786 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5790 int num_percent
, nargs
;
5793 if (e
->expr_type
!= EXPR_CONSTANT
)
5796 len
= e
->value
.character
.length
;
5797 if (e
->value
.character
.string
[len
-1] != '\0')
5798 gfc_internal_error ("fe_runtime_error string must be null terminated");
5801 for (i
=0; i
<len
-1; i
++)
5802 if (e
->value
.character
.string
[i
] == '%')
5806 for (; a
; a
= a
->next
)
5809 if (nargs
-1 != num_percent
)
5810 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5811 nargs
, num_percent
++);
5817 gfc_check_second_sub (gfc_expr
*time
)
5819 if (!scalar_check (time
, 0))
5822 if (!type_check (time
, 0, BT_REAL
))
5825 if (!kind_value_check (time
, 0, 4))
5832 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5833 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5834 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5835 count_max are all optional arguments */
5838 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5839 gfc_expr
*count_max
)
5843 if (!scalar_check (count
, 0))
5846 if (!type_check (count
, 0, BT_INTEGER
))
5849 if (count
->ts
.kind
!= gfc_default_integer_kind
5850 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5851 "SYSTEM_CLOCK at %L has non-default kind",
5855 if (!variable_check (count
, 0, false))
5859 if (count_rate
!= NULL
)
5861 if (!scalar_check (count_rate
, 1))
5864 if (!variable_check (count_rate
, 1, false))
5867 if (count_rate
->ts
.type
== BT_REAL
)
5869 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5870 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5875 if (!type_check (count_rate
, 1, BT_INTEGER
))
5878 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5879 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5880 "SYSTEM_CLOCK at %L has non-default kind",
5881 &count_rate
->where
))
5887 if (count_max
!= NULL
)
5889 if (!scalar_check (count_max
, 2))
5892 if (!type_check (count_max
, 2, BT_INTEGER
))
5895 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5896 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5897 "SYSTEM_CLOCK at %L has non-default kind",
5901 if (!variable_check (count_max
, 2, false))
5910 gfc_check_irand (gfc_expr
*x
)
5915 if (!scalar_check (x
, 0))
5918 if (!type_check (x
, 0, BT_INTEGER
))
5921 if (!kind_value_check (x
, 0, 4))
5929 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5931 if (!scalar_check (seconds
, 0))
5933 if (!type_check (seconds
, 0, BT_INTEGER
))
5936 if (!int_or_proc_check (handler
, 1))
5938 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5944 if (!scalar_check (status
, 2))
5946 if (!type_check (status
, 2, BT_INTEGER
))
5948 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5956 gfc_check_rand (gfc_expr
*x
)
5961 if (!scalar_check (x
, 0))
5964 if (!type_check (x
, 0, BT_INTEGER
))
5967 if (!kind_value_check (x
, 0, 4))
5975 gfc_check_srand (gfc_expr
*x
)
5977 if (!scalar_check (x
, 0))
5980 if (!type_check (x
, 0, BT_INTEGER
))
5983 if (!kind_value_check (x
, 0, 4))
5991 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5993 if (!scalar_check (time
, 0))
5995 if (!type_check (time
, 0, BT_INTEGER
))
5998 if (!type_check (result
, 1, BT_CHARACTER
))
6000 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6008 gfc_check_dtime_etime (gfc_expr
*x
)
6010 if (!array_check (x
, 0))
6013 if (!rank_check (x
, 0, 1))
6016 if (!variable_check (x
, 0, false))
6019 if (!type_check (x
, 0, BT_REAL
))
6022 if (!kind_value_check (x
, 0, 4))
6030 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6032 if (!array_check (values
, 0))
6035 if (!rank_check (values
, 0, 1))
6038 if (!variable_check (values
, 0, false))
6041 if (!type_check (values
, 0, BT_REAL
))
6044 if (!kind_value_check (values
, 0, 4))
6047 if (!scalar_check (time
, 1))
6050 if (!type_check (time
, 1, BT_REAL
))
6053 if (!kind_value_check (time
, 1, 4))
6061 gfc_check_fdate_sub (gfc_expr
*date
)
6063 if (!type_check (date
, 0, BT_CHARACTER
))
6065 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6073 gfc_check_gerror (gfc_expr
*msg
)
6075 if (!type_check (msg
, 0, BT_CHARACTER
))
6077 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6085 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6087 if (!type_check (cwd
, 0, BT_CHARACTER
))
6089 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6095 if (!scalar_check (status
, 1))
6098 if (!type_check (status
, 1, BT_INTEGER
))
6106 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6108 if (!type_check (pos
, 0, BT_INTEGER
))
6111 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6113 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6114 "not wider than the default kind (%d)",
6115 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6116 &pos
->where
, gfc_default_integer_kind
);
6120 if (!type_check (value
, 1, BT_CHARACTER
))
6122 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6130 gfc_check_getlog (gfc_expr
*msg
)
6132 if (!type_check (msg
, 0, BT_CHARACTER
))
6134 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6142 gfc_check_exit (gfc_expr
*status
)
6147 if (!type_check (status
, 0, BT_INTEGER
))
6150 if (!scalar_check (status
, 0))
6158 gfc_check_flush (gfc_expr
*unit
)
6163 if (!type_check (unit
, 0, BT_INTEGER
))
6166 if (!scalar_check (unit
, 0))
6174 gfc_check_free (gfc_expr
*i
)
6176 if (!type_check (i
, 0, BT_INTEGER
))
6179 if (!scalar_check (i
, 0))
6187 gfc_check_hostnm (gfc_expr
*name
)
6189 if (!type_check (name
, 0, BT_CHARACTER
))
6191 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6199 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6201 if (!type_check (name
, 0, BT_CHARACTER
))
6203 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6209 if (!scalar_check (status
, 1))
6212 if (!type_check (status
, 1, BT_INTEGER
))
6220 gfc_check_itime_idate (gfc_expr
*values
)
6222 if (!array_check (values
, 0))
6225 if (!rank_check (values
, 0, 1))
6228 if (!variable_check (values
, 0, false))
6231 if (!type_check (values
, 0, BT_INTEGER
))
6234 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6242 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6244 if (!type_check (time
, 0, BT_INTEGER
))
6247 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6250 if (!scalar_check (time
, 0))
6253 if (!array_check (values
, 1))
6256 if (!rank_check (values
, 1, 1))
6259 if (!variable_check (values
, 1, false))
6262 if (!type_check (values
, 1, BT_INTEGER
))
6265 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6273 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6275 if (!scalar_check (unit
, 0))
6278 if (!type_check (unit
, 0, BT_INTEGER
))
6281 if (!type_check (name
, 1, BT_CHARACTER
))
6283 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6291 gfc_check_isatty (gfc_expr
*unit
)
6296 if (!type_check (unit
, 0, BT_INTEGER
))
6299 if (!scalar_check (unit
, 0))
6307 gfc_check_isnan (gfc_expr
*x
)
6309 if (!type_check (x
, 0, BT_REAL
))
6317 gfc_check_perror (gfc_expr
*string
)
6319 if (!type_check (string
, 0, BT_CHARACTER
))
6321 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6329 gfc_check_umask (gfc_expr
*mask
)
6331 if (!type_check (mask
, 0, BT_INTEGER
))
6334 if (!scalar_check (mask
, 0))
6342 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6344 if (!type_check (mask
, 0, BT_INTEGER
))
6347 if (!scalar_check (mask
, 0))
6353 if (!scalar_check (old
, 1))
6356 if (!type_check (old
, 1, BT_INTEGER
))
6364 gfc_check_unlink (gfc_expr
*name
)
6366 if (!type_check (name
, 0, BT_CHARACTER
))
6368 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6376 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6378 if (!type_check (name
, 0, BT_CHARACTER
))
6380 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6386 if (!scalar_check (status
, 1))
6389 if (!type_check (status
, 1, BT_INTEGER
))
6397 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6399 if (!scalar_check (number
, 0))
6401 if (!type_check (number
, 0, BT_INTEGER
))
6404 if (!int_or_proc_check (handler
, 1))
6406 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6414 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6416 if (!scalar_check (number
, 0))
6418 if (!type_check (number
, 0, BT_INTEGER
))
6421 if (!int_or_proc_check (handler
, 1))
6423 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6429 if (!type_check (status
, 2, BT_INTEGER
))
6431 if (!scalar_check (status
, 2))
6439 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6441 if (!type_check (cmd
, 0, BT_CHARACTER
))
6443 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6446 if (!scalar_check (status
, 1))
6449 if (!type_check (status
, 1, BT_INTEGER
))
6452 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6459 /* This is used for the GNU intrinsics AND, OR and XOR. */
6461 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6463 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6465 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6466 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6467 gfc_current_intrinsic
, &i
->where
);
6471 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6473 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6474 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6475 gfc_current_intrinsic
, &j
->where
);
6479 if (i
->ts
.type
!= j
->ts
.type
)
6481 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6482 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6483 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6488 if (!scalar_check (i
, 0))
6491 if (!scalar_check (j
, 1))
6499 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6502 if (a
->expr_type
== EXPR_NULL
)
6504 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6505 "argument to STORAGE_SIZE, because it returns a "
6506 "disassociated pointer", &a
->where
);
6510 if (a
->ts
.type
== BT_ASSUMED
)
6512 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6513 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6518 if (a
->ts
.type
== BT_PROCEDURE
)
6520 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6521 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6522 gfc_current_intrinsic
, &a
->where
);
6529 if (!type_check (kind
, 1, BT_INTEGER
))
6532 if (!scalar_check (kind
, 1))
6535 if (kind
->expr_type
!= EXPR_CONSTANT
)
6537 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6538 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,