2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 /* Users sometime use a subroutine designator as an actual argument to
76 an intrinsic subprogram that expects an argument with a numeric type. */
77 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
80 if (gfc_numeric_ts (&e
->ts
))
83 /* If the expression has not got a type, check if its namespace can
84 offer a default type. */
85 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
86 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
87 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
88 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
90 e
->ts
= e
->symtree
->n
.sym
->ts
;
96 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
97 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
104 /* Check that an expression is integer or real. */
107 int_or_real_check (gfc_expr
*e
, int n
)
109 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
111 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
112 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
113 gfc_current_intrinsic
, &e
->where
);
120 /* Check that an expression is integer or real; allow character for
124 int_or_real_or_char_check_f2003 (gfc_expr
*e
, int n
)
126 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
128 if (e
->ts
.type
== BT_CHARACTER
)
129 return gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Character for "
130 "%qs argument of %qs intrinsic at %L",
131 gfc_current_intrinsic_arg
[n
]->name
,
132 gfc_current_intrinsic
, &e
->where
);
135 if (gfc_option
.allow_std
& GFC_STD_F2003
)
136 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
137 "or REAL or CHARACTER",
138 gfc_current_intrinsic_arg
[n
]->name
,
139 gfc_current_intrinsic
, &e
->where
);
141 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
142 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
143 gfc_current_intrinsic
, &e
->where
);
152 /* Check that an expression is real or complex. */
155 real_or_complex_check (gfc_expr
*e
, int n
)
157 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
159 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
160 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
161 gfc_current_intrinsic
, &e
->where
);
169 /* Check that an expression is INTEGER or PROCEDURE. */
172 int_or_proc_check (gfc_expr
*e
, int n
)
174 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
176 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
177 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
178 gfc_current_intrinsic
, &e
->where
);
186 /* Check that the expression is an optional constant integer
187 and that it specifies a valid kind for that type. */
190 kind_check (gfc_expr
*k
, int n
, bt type
)
197 if (!type_check (k
, n
, BT_INTEGER
))
200 if (!scalar_check (k
, n
))
203 if (!gfc_check_init_expr (k
))
205 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
206 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
211 if (gfc_extract_int (k
, &kind
)
212 || gfc_validate_kind (type
, kind
, true) < 0)
214 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
223 /* Make sure the expression is a double precision real. */
226 double_check (gfc_expr
*d
, int n
)
228 if (!type_check (d
, n
, BT_REAL
))
231 if (d
->ts
.kind
!= gfc_default_double_kind
)
233 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
234 "precision", gfc_current_intrinsic_arg
[n
]->name
,
235 gfc_current_intrinsic
, &d
->where
);
244 coarray_check (gfc_expr
*e
, int n
)
246 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
247 && CLASS_DATA (e
)->attr
.codimension
248 && CLASS_DATA (e
)->as
->corank
)
250 gfc_add_class_array_ref (e
);
254 if (!gfc_is_coarray (e
))
256 gfc_error ("Expected coarray variable as %qs argument to the %s "
257 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
258 gfc_current_intrinsic
, &e
->where
);
266 /* Make sure the expression is a logical array. */
269 logical_array_check (gfc_expr
*array
, int n
)
271 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
273 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
274 "array", gfc_current_intrinsic_arg
[n
]->name
,
275 gfc_current_intrinsic
, &array
->where
);
283 /* Make sure an expression is an array. */
286 array_check (gfc_expr
*e
, int n
)
288 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
289 && CLASS_DATA (e
)->attr
.dimension
290 && CLASS_DATA (e
)->as
->rank
)
292 gfc_add_class_array_ref (e
);
296 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
299 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
300 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
307 /* If expr is a constant, then check to ensure that it is greater than
311 nonnegative_check (const char *arg
, gfc_expr
*expr
)
315 if (expr
->expr_type
== EXPR_CONSTANT
)
317 gfc_extract_int (expr
, &i
);
320 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
329 /* If expr is a constant, then check to ensure that it is greater than zero. */
332 positive_check (int n
, gfc_expr
*expr
)
336 if (expr
->expr_type
== EXPR_CONSTANT
)
338 gfc_extract_int (expr
, &i
);
341 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
342 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
352 /* If expr2 is constant, then check that the value is less than
353 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
356 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
357 gfc_expr
*expr2
, bool or_equal
)
361 if (expr2
->expr_type
== EXPR_CONSTANT
)
363 gfc_extract_int (expr2
, &i2
);
364 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
366 /* For ISHFT[C], check that |shift| <= bit_size(i). */
372 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
374 gfc_error ("The absolute value of SHIFT at %L must be less "
375 "than or equal to BIT_SIZE(%qs)",
376 &expr2
->where
, arg1
);
383 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
385 gfc_error ("%qs at %L must be less than "
386 "or equal to BIT_SIZE(%qs)",
387 arg2
, &expr2
->where
, arg1
);
393 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
395 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
396 arg2
, &expr2
->where
, arg1
);
406 /* If expr is constant, then check that the value is less than or equal
407 to the bit_size of the kind k. */
410 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
414 if (expr
->expr_type
!= EXPR_CONSTANT
)
417 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
418 gfc_extract_int (expr
, &val
);
420 if (val
> gfc_integer_kinds
[i
].bit_size
)
422 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
423 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
431 /* If expr2 and expr3 are constants, then check that the value is less than
432 or equal to bit_size(expr1). */
435 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
436 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
440 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
442 gfc_extract_int (expr2
, &i2
);
443 gfc_extract_int (expr3
, &i3
);
445 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
446 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
448 gfc_error ("%<%s + %s%> at %L must be less than or equal "
450 arg2
, arg3
, &expr2
->where
, arg1
);
458 /* Make sure two expressions have the same type. */
461 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
, bool assoc
= false)
463 gfc_typespec
*ets
= &e
->ts
;
464 gfc_typespec
*fts
= &f
->ts
;
468 /* Procedure pointer component expressions have the type of the interface
469 procedure. If they are being tested for association with a procedure
470 pointer (ie. not a component), the type of the procedure must be
472 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
473 ets
= &e
->symtree
->n
.sym
->ts
;
474 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
475 fts
= &f
->symtree
->n
.sym
->ts
;
478 if (gfc_compare_types (ets
, fts
))
481 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
482 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
483 gfc_current_intrinsic
, &f
->where
,
484 gfc_current_intrinsic_arg
[n
]->name
);
490 /* Make sure that an expression has a certain (nonzero) rank. */
493 rank_check (gfc_expr
*e
, int n
, int rank
)
498 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
499 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
506 /* Make sure a variable expression is not an optional dummy argument. */
509 nonoptional_check (gfc_expr
*e
, int n
)
511 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
513 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
514 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
518 /* TODO: Recursive check on nonoptional variables? */
524 /* Check for ALLOCATABLE attribute. */
527 allocatable_check (gfc_expr
*e
, int n
)
529 symbol_attribute attr
;
531 attr
= gfc_variable_attr (e
, NULL
);
532 if (!attr
.allocatable
|| attr
.associate_var
)
534 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
535 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
544 /* Check that an expression has a particular kind. */
547 kind_value_check (gfc_expr
*e
, int n
, int k
)
552 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
553 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
560 /* Make sure an expression is a variable. */
563 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
565 if (e
->expr_type
== EXPR_VARIABLE
566 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
567 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
568 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
571 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
572 && CLASS_DATA (e
->symtree
->n
.sym
)
573 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
574 : e
->symtree
->n
.sym
->attr
.pointer
;
576 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
578 if (pointer
&& ref
->type
== REF_COMPONENT
)
580 if (ref
->type
== REF_COMPONENT
581 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
582 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
583 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
584 && ref
->u
.c
.component
->attr
.pointer
)))
590 gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
591 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
592 gfc_current_intrinsic
, &e
->where
);
597 if (e
->expr_type
== EXPR_VARIABLE
598 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
599 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
602 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
603 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
606 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
607 if (ns
->proc_name
== e
->symtree
->n
.sym
)
611 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
612 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
618 /* Check the common DIM parameter for correctness. */
621 dim_check (gfc_expr
*dim
, int n
, bool optional
)
626 if (!type_check (dim
, n
, BT_INTEGER
))
629 if (!scalar_check (dim
, n
))
632 if (!optional
&& !nonoptional_check (dim
, n
))
639 /* If a coarray DIM parameter is a constant, make sure that it is greater than
640 zero and less than or equal to the corank of the given array. */
643 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
647 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
649 if (dim
->expr_type
!= EXPR_CONSTANT
)
652 if (array
->ts
.type
== BT_CLASS
)
655 corank
= gfc_get_corank (array
);
657 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
658 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
660 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
661 "codimension index", gfc_current_intrinsic
, &dim
->where
);
670 /* If a DIM parameter is a constant, make sure that it is greater than
671 zero and less than or equal to the rank of the given array. If
672 allow_assumed is zero then dim must be less than the rank of the array
673 for assumed size arrays. */
676 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
684 if (dim
->expr_type
!= EXPR_CONSTANT
)
687 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
688 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
689 rank
= array
->rank
+ 1;
693 /* Assumed-rank array. */
695 rank
= GFC_MAX_DIMENSIONS
;
697 if (array
->expr_type
== EXPR_VARIABLE
)
699 ar
= gfc_find_array_ref (array
);
700 if (ar
->as
->type
== AS_ASSUMED_SIZE
702 && ar
->type
!= AR_ELEMENT
703 && ar
->type
!= AR_SECTION
)
707 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
708 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
710 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
711 "dimension index", gfc_current_intrinsic
, &dim
->where
);
720 /* Compare the size of a along dimension ai with the size of b along
721 dimension bi, returning 0 if they are known not to be identical,
722 and 1 if they are identical, or if this cannot be determined. */
725 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
727 mpz_t a_size
, b_size
;
730 gcc_assert (a
->rank
> ai
);
731 gcc_assert (b
->rank
> bi
);
735 if (gfc_array_dimen_size (a
, ai
, &a_size
))
737 if (gfc_array_dimen_size (b
, bi
, &b_size
))
739 if (mpz_cmp (a_size
, b_size
) != 0)
749 /* Calculate the length of a character variable, including substrings.
750 Strip away parentheses if necessary. Return -1 if no length could
754 gfc_var_strlen (const gfc_expr
*a
)
758 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
761 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
771 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
772 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
774 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
776 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
777 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
779 else if (ra
->u
.ss
.start
780 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
786 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
787 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
788 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
789 else if (a
->expr_type
== EXPR_CONSTANT
790 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
791 return a
->value
.character
.length
;
797 /* Check whether two character expressions have the same length;
798 returns true if they have or if the length cannot be determined,
799 otherwise return false and raise a gfc_error. */
802 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
806 len_a
= gfc_var_strlen(a
);
807 len_b
= gfc_var_strlen(b
);
809 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
813 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
814 len_a
, len_b
, name
, &a
->where
);
820 /***** Check functions *****/
822 /* Check subroutine suitable for intrinsics taking a real argument and
823 a kind argument for the result. */
826 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
828 if (!type_check (a
, 0, BT_REAL
))
830 if (!kind_check (kind
, 1, type
))
837 /* Check subroutine suitable for ceiling, floor and nint. */
840 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
842 return check_a_kind (a
, kind
, BT_INTEGER
);
846 /* Check subroutine suitable for aint, anint. */
849 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
851 return check_a_kind (a
, kind
, BT_REAL
);
856 gfc_check_abs (gfc_expr
*a
)
858 if (!numeric_check (a
, 0))
866 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
868 if (!type_check (a
, 0, BT_INTEGER
))
870 if (!kind_check (kind
, 1, BT_CHARACTER
))
878 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
880 if (!type_check (name
, 0, BT_CHARACTER
)
881 || !scalar_check (name
, 0))
883 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
886 if (!type_check (mode
, 1, BT_CHARACTER
)
887 || !scalar_check (mode
, 1))
889 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
897 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
899 if (!logical_array_check (mask
, 0))
902 if (!dim_check (dim
, 1, false))
905 if (!dim_rank_check (dim
, mask
, 0))
913 gfc_check_allocated (gfc_expr
*array
)
915 /* Tests on allocated components of coarrays need to detour the check to
916 argument of the _caf_get. */
917 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
918 && array
->value
.function
.isym
919 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
921 array
= array
->value
.function
.actual
->expr
;
926 if (!variable_check (array
, 0, false))
928 if (!allocatable_check (array
, 0))
935 /* Common check function where the first argument must be real or
936 integer and the second argument must be the same as the first. */
939 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
941 if (!int_or_real_check (a
, 0))
944 if (a
->ts
.type
!= p
->ts
.type
)
946 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
947 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
948 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
953 if (a
->ts
.kind
!= p
->ts
.kind
)
955 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
965 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
967 if (!double_check (x
, 0) || !double_check (y
, 1))
975 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
977 symbol_attribute attr1
, attr2
;
982 where
= &pointer
->where
;
984 if (pointer
->expr_type
== EXPR_NULL
)
987 attr1
= gfc_expr_attr (pointer
);
989 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
991 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
992 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
998 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
1000 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1001 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
1002 gfc_current_intrinsic
, &pointer
->where
);
1006 /* Target argument is optional. */
1010 where
= &target
->where
;
1011 if (target
->expr_type
== EXPR_NULL
)
1014 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
1015 attr2
= gfc_expr_attr (target
);
1018 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1019 "or target VARIABLE or FUNCTION",
1020 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1025 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
1027 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1028 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
1029 gfc_current_intrinsic
, &target
->where
);
1034 if (attr1
.pointer
&& gfc_is_coindexed (target
))
1036 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1037 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1038 gfc_current_intrinsic
, &target
->where
);
1043 if (!same_type_check (pointer
, 0, target
, 1, true))
1045 if (!rank_check (target
, 0, pointer
->rank
))
1047 if (target
->rank
> 0)
1049 for (i
= 0; i
< target
->rank
; i
++)
1050 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1052 gfc_error ("Array section with a vector subscript at %L shall not "
1053 "be the target of a pointer",
1063 gfc_error ("NULL pointer at %L is not permitted as actual argument "
1064 "of %qs intrinsic function", where
, gfc_current_intrinsic
);
1071 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1073 /* gfc_notify_std would be a waste of time as the return value
1074 is seemingly used only for the generic resolution. The error
1075 will be: Too many arguments. */
1076 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1079 return gfc_check_atan2 (y
, x
);
1084 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1086 if (!type_check (y
, 0, BT_REAL
))
1088 if (!same_type_check (y
, 0, x
, 1))
1096 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1097 gfc_expr
*stat
, int stat_no
)
1099 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1102 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1103 && !(atom
->ts
.type
== BT_LOGICAL
1104 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1106 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1107 "integer of ATOMIC_INT_KIND or a logical of "
1108 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1112 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1114 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1115 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1119 if (atom
->ts
.type
!= value
->ts
.type
)
1121 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1122 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1123 gfc_current_intrinsic
, &value
->where
,
1124 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1130 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1132 if (!scalar_check (stat
, stat_no
))
1134 if (!variable_check (stat
, stat_no
, false))
1136 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1139 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1140 gfc_current_intrinsic
, &stat
->where
))
1149 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1151 if (atom
->expr_type
== EXPR_FUNCTION
1152 && atom
->value
.function
.isym
1153 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1154 atom
= atom
->value
.function
.actual
->expr
;
1156 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1158 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1159 "definable", gfc_current_intrinsic
, &atom
->where
);
1163 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1168 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1170 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1172 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1173 "integer of ATOMIC_INT_KIND", &atom
->where
,
1174 gfc_current_intrinsic
);
1178 return gfc_check_atomic_def (atom
, value
, stat
);
1183 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1185 if (atom
->expr_type
== EXPR_FUNCTION
1186 && atom
->value
.function
.isym
1187 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1188 atom
= atom
->value
.function
.actual
->expr
;
1190 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1192 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1193 "definable", gfc_current_intrinsic
, &value
->where
);
1197 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1202 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1204 /* IMAGE has to be a positive, scalar integer. */
1205 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1206 || !positive_check (0, image
))
1211 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1212 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1221 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1225 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1226 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1235 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1236 || !positive_check (1, kind
))
1239 /* Get the kind, reporting error on non-constant or overflow. */
1240 gfc_current_locus
= kind
->where
;
1241 if (gfc_extract_int (kind
, &k
, 1))
1243 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1245 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1246 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1247 gfc_current_intrinsic
, &kind
->where
);
1256 gfc_check_get_team (gfc_expr
*level
)
1260 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1261 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1270 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1271 gfc_expr
*new_val
, gfc_expr
*stat
)
1273 if (atom
->expr_type
== EXPR_FUNCTION
1274 && atom
->value
.function
.isym
1275 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1276 atom
= atom
->value
.function
.actual
->expr
;
1278 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1281 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1284 if (!same_type_check (atom
, 0, old
, 1))
1287 if (!same_type_check (atom
, 0, compare
, 2))
1290 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1292 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1293 "definable", gfc_current_intrinsic
, &atom
->where
);
1297 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1299 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1300 "definable", gfc_current_intrinsic
, &old
->where
);
1308 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1310 if (event
->ts
.type
!= BT_DERIVED
1311 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1312 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1314 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1315 "shall be of type EVENT_TYPE", &event
->where
);
1319 if (!scalar_check (event
, 0))
1322 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1324 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1325 "shall be definable", &count
->where
);
1329 if (!type_check (count
, 1, BT_INTEGER
))
1332 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1333 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1335 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1337 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1338 "shall have at least the range of the default integer",
1345 if (!type_check (stat
, 2, BT_INTEGER
))
1347 if (!scalar_check (stat
, 2))
1349 if (!variable_check (stat
, 2, false))
1352 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1353 gfc_current_intrinsic
, &stat
->where
))
1362 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1365 if (atom
->expr_type
== EXPR_FUNCTION
1366 && atom
->value
.function
.isym
1367 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1368 atom
= atom
->value
.function
.actual
->expr
;
1370 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1372 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1373 "integer of ATOMIC_INT_KIND", &atom
->where
,
1374 gfc_current_intrinsic
);
1378 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1381 if (!scalar_check (old
, 2))
1384 if (!same_type_check (atom
, 0, old
, 2))
1387 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1389 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1390 "definable", gfc_current_intrinsic
, &atom
->where
);
1394 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1396 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1397 "definable", gfc_current_intrinsic
, &old
->where
);
1405 /* BESJN and BESYN functions. */
1408 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1410 if (!type_check (n
, 0, BT_INTEGER
))
1412 if (n
->expr_type
== EXPR_CONSTANT
)
1415 gfc_extract_int (n
, &i
);
1416 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1417 "N at %L", &n
->where
))
1421 if (!type_check (x
, 1, BT_REAL
))
1428 /* Transformational version of the Bessel JN and YN functions. */
1431 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1433 if (!type_check (n1
, 0, BT_INTEGER
))
1435 if (!scalar_check (n1
, 0))
1437 if (!nonnegative_check ("N1", n1
))
1440 if (!type_check (n2
, 1, BT_INTEGER
))
1442 if (!scalar_check (n2
, 1))
1444 if (!nonnegative_check ("N2", n2
))
1447 if (!type_check (x
, 2, BT_REAL
))
1449 if (!scalar_check (x
, 2))
1457 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1459 if (!type_check (i
, 0, BT_INTEGER
))
1462 if (!type_check (j
, 1, BT_INTEGER
))
1470 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1472 if (!type_check (i
, 0, BT_INTEGER
))
1475 if (!type_check (pos
, 1, BT_INTEGER
))
1478 if (!nonnegative_check ("pos", pos
))
1481 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1489 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1491 if (!type_check (i
, 0, BT_INTEGER
))
1493 if (!kind_check (kind
, 1, BT_CHARACTER
))
1501 gfc_check_chdir (gfc_expr
*dir
)
1503 if (!type_check (dir
, 0, BT_CHARACTER
))
1505 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1513 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1515 if (!type_check (dir
, 0, BT_CHARACTER
))
1517 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1523 if (!type_check (status
, 1, BT_INTEGER
))
1525 if (!scalar_check (status
, 1))
1533 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1535 if (!type_check (name
, 0, BT_CHARACTER
))
1537 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1540 if (!type_check (mode
, 1, BT_CHARACTER
))
1542 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1550 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1552 if (!type_check (name
, 0, BT_CHARACTER
))
1554 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1557 if (!type_check (mode
, 1, BT_CHARACTER
))
1559 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1565 if (!type_check (status
, 2, BT_INTEGER
))
1568 if (!scalar_check (status
, 2))
1576 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1578 if (!numeric_check (x
, 0))
1583 if (!numeric_check (y
, 1))
1586 if (x
->ts
.type
== BT_COMPLEX
)
1588 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1589 "present if %<x%> is COMPLEX",
1590 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1595 if (y
->ts
.type
== BT_COMPLEX
)
1597 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1598 "of either REAL or INTEGER",
1599 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1606 if (!kind_check (kind
, 2, BT_COMPLEX
))
1609 if (!kind
&& warn_conversion
1610 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1611 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1612 "COMPLEX(%d) at %L might lose precision, consider using "
1613 "the KIND argument", gfc_typename (&x
->ts
),
1614 gfc_default_real_kind
, &x
->where
);
1615 else if (y
&& !kind
&& warn_conversion
1616 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1617 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1618 "COMPLEX(%d) at %L might lose precision, consider using "
1619 "the KIND argument", gfc_typename (&y
->ts
),
1620 gfc_default_real_kind
, &y
->where
);
1626 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1627 gfc_expr
*errmsg
, bool co_reduce
)
1629 if (!variable_check (a
, 0, false))
1632 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1636 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1637 if (gfc_has_vector_subscript (a
))
1639 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1640 "subroutine %s shall not have a vector subscript",
1641 &a
->where
, gfc_current_intrinsic
);
1645 if (gfc_is_coindexed (a
))
1647 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1648 "coindexed", &a
->where
, gfc_current_intrinsic
);
1652 if (image_idx
!= NULL
)
1654 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1656 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1662 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1664 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1666 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1668 if (stat
->ts
.kind
!= 4)
1670 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1671 "variable", &stat
->where
);
1678 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1680 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1682 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1684 if (errmsg
->ts
.kind
!= 1)
1686 gfc_error ("The errmsg= argument at %L must be a default-kind "
1687 "character variable", &errmsg
->where
);
1692 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1694 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1704 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1707 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1709 gfc_error ("Support for the A argument at %L which is polymorphic A "
1710 "argument or has allocatable components is not yet "
1711 "implemented", &a
->where
);
1714 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1719 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1720 gfc_expr
*stat
, gfc_expr
*errmsg
)
1722 symbol_attribute attr
;
1723 gfc_formal_arglist
*formal
;
1726 if (a
->ts
.type
== BT_CLASS
)
1728 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1733 if (gfc_expr_attr (a
).alloc_comp
)
1735 gfc_error ("Support for the A argument at %L with allocatable components"
1736 " is not yet implemented", &a
->where
);
1740 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1743 if (!gfc_resolve_expr (op
))
1746 attr
= gfc_expr_attr (op
);
1747 if (!attr
.pure
|| !attr
.function
)
1749 gfc_error ("OPERATOR argument at %L must be a PURE function",
1756 /* None of the intrinsics fulfills the criteria of taking two arguments,
1757 returning the same type and kind as the arguments and being permitted
1758 as actual argument. */
1759 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1760 op
->symtree
->n
.sym
->name
, &op
->where
);
1764 if (gfc_is_proc_ptr_comp (op
))
1766 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1767 sym
= comp
->ts
.interface
;
1770 sym
= op
->symtree
->n
.sym
;
1772 formal
= sym
->formal
;
1774 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1776 gfc_error ("The function passed as OPERATOR at %L shall have two "
1777 "arguments", &op
->where
);
1781 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1782 gfc_set_default_type (sym
->result
, 0, NULL
);
1784 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1786 gfc_error ("The A argument at %L has type %s but the function passed as "
1787 "OPERATOR at %L returns %s",
1788 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1789 gfc_typename (&sym
->result
->ts
));
1792 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1793 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1795 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1796 "%s and %s but shall have type %s", &op
->where
,
1797 gfc_typename (&formal
->sym
->ts
),
1798 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1801 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1802 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1803 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1804 || formal
->next
->sym
->attr
.pointer
)
1806 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1807 "nonallocatable nonpointer arguments and return a "
1808 "nonallocatable nonpointer scalar", &op
->where
);
1812 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1814 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1815 "attribute either for none or both arguments", &op
->where
);
1819 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1821 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1822 "attribute either for none or both arguments", &op
->where
);
1826 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1828 gfc_error ("The function passed as OPERATOR at %L shall have the "
1829 "ASYNCHRONOUS attribute either for none or both arguments",
1834 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1836 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1837 "OPTIONAL attribute for either of the arguments", &op
->where
);
1841 if (a
->ts
.type
== BT_CHARACTER
)
1844 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1847 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1848 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1850 cl
= formal
->sym
->ts
.u
.cl
;
1851 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1852 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1854 cl
= formal
->next
->sym
->ts
.u
.cl
;
1855 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1856 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1859 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1860 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1863 && ((formal_size1
&& actual_size
!= formal_size1
)
1864 || (formal_size2
&& actual_size
!= formal_size2
)))
1866 gfc_error ("The character length of the A argument at %L and of the "
1867 "arguments of the OPERATOR at %L shall be the same",
1868 &a
->where
, &op
->where
);
1871 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1873 gfc_error ("The character length of the A argument at %L and of the "
1874 "function result of the OPERATOR at %L shall be the same",
1875 &a
->where
, &op
->where
);
1885 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1888 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1889 && a
->ts
.type
!= BT_CHARACTER
)
1891 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1892 "integer, real or character",
1893 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1897 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1902 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1905 if (!numeric_check (a
, 0))
1907 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1912 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1914 if (!int_or_real_check (x
, 0))
1916 if (!scalar_check (x
, 0))
1919 if (!int_or_real_check (y
, 1))
1921 if (!scalar_check (y
, 1))
1929 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1931 if (!logical_array_check (mask
, 0))
1933 if (!dim_check (dim
, 1, false))
1935 if (!dim_rank_check (dim
, mask
, 0))
1937 if (!kind_check (kind
, 2, BT_INTEGER
))
1939 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1940 "with KIND argument at %L",
1941 gfc_current_intrinsic
, &kind
->where
))
1949 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1951 if (!array_check (array
, 0))
1954 if (!type_check (shift
, 1, BT_INTEGER
))
1957 if (!dim_check (dim
, 2, true))
1960 if (!dim_rank_check (dim
, array
, false))
1963 if (array
->rank
== 1 || shift
->rank
== 0)
1965 if (!scalar_check (shift
, 1))
1968 else if (shift
->rank
== array
->rank
- 1)
1973 else if (dim
->expr_type
== EXPR_CONSTANT
)
1974 gfc_extract_int (dim
, &d
);
1981 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1984 if (!identical_dimen_shape (array
, i
, shift
, j
))
1986 gfc_error ("%qs argument of %qs intrinsic at %L has "
1987 "invalid shape in dimension %d (%ld/%ld)",
1988 gfc_current_intrinsic_arg
[1]->name
,
1989 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1990 mpz_get_si (array
->shape
[i
]),
1991 mpz_get_si (shift
->shape
[j
]));
2001 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2002 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2003 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2012 gfc_check_ctime (gfc_expr
*time
)
2014 if (!scalar_check (time
, 0))
2017 if (!type_check (time
, 0, BT_INTEGER
))
2024 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2026 if (!double_check (y
, 0) || !double_check (x
, 1))
2033 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2035 if (!numeric_check (x
, 0))
2040 if (!numeric_check (y
, 1))
2043 if (x
->ts
.type
== BT_COMPLEX
)
2045 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2046 "present if %<x%> is COMPLEX",
2047 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2052 if (y
->ts
.type
== BT_COMPLEX
)
2054 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2055 "of either REAL or INTEGER",
2056 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2067 gfc_check_dble (gfc_expr
*x
)
2069 if (!numeric_check (x
, 0))
2077 gfc_check_digits (gfc_expr
*x
)
2079 if (!int_or_real_check (x
, 0))
2087 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2089 switch (vector_a
->ts
.type
)
2092 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2099 if (!numeric_check (vector_b
, 1))
2104 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2105 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2106 gfc_current_intrinsic
, &vector_a
->where
);
2110 if (!rank_check (vector_a
, 0, 1))
2113 if (!rank_check (vector_b
, 1, 1))
2116 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2118 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2119 "intrinsic %<dot_product%>",
2120 gfc_current_intrinsic_arg
[0]->name
,
2121 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2130 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2132 if (!type_check (x
, 0, BT_REAL
)
2133 || !type_check (y
, 1, BT_REAL
))
2136 if (x
->ts
.kind
!= gfc_default_real_kind
)
2138 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2139 "real", gfc_current_intrinsic_arg
[0]->name
,
2140 gfc_current_intrinsic
, &x
->where
);
2144 if (y
->ts
.kind
!= gfc_default_real_kind
)
2146 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2147 "real", gfc_current_intrinsic_arg
[1]->name
,
2148 gfc_current_intrinsic
, &y
->where
);
2157 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2159 if (!type_check (i
, 0, BT_INTEGER
))
2162 if (!type_check (j
, 1, BT_INTEGER
))
2165 if (i
->is_boz
&& j
->is_boz
)
2167 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2168 "constants", &i
->where
, &j
->where
);
2172 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
2175 if (!type_check (shift
, 2, BT_INTEGER
))
2178 if (!nonnegative_check ("SHIFT", shift
))
2183 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
2185 i
->ts
.kind
= j
->ts
.kind
;
2189 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2191 j
->ts
.kind
= i
->ts
.kind
;
2199 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2204 if (!array_check (array
, 0))
2207 if (!type_check (shift
, 1, BT_INTEGER
))
2210 if (!dim_check (dim
, 3, true))
2213 if (!dim_rank_check (dim
, array
, false))
2218 else if (dim
->expr_type
== EXPR_CONSTANT
)
2219 gfc_extract_int (dim
, &d
);
2223 if (array
->rank
== 1 || shift
->rank
== 0)
2225 if (!scalar_check (shift
, 1))
2228 else if (shift
->rank
== array
->rank
- 1)
2233 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2236 if (!identical_dimen_shape (array
, i
, shift
, j
))
2238 gfc_error ("%qs argument of %qs intrinsic at %L has "
2239 "invalid shape in dimension %d (%ld/%ld)",
2240 gfc_current_intrinsic_arg
[1]->name
,
2241 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2242 mpz_get_si (array
->shape
[i
]),
2243 mpz_get_si (shift
->shape
[j
]));
2253 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2254 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2255 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2259 if (boundary
!= NULL
)
2261 if (!same_type_check (array
, 0, boundary
, 2))
2264 /* Reject unequal string lengths and emit a better error message than
2265 gfc_check_same_strlen would. */
2266 if (array
->ts
.type
== BT_CHARACTER
)
2268 ssize_t len_a
, len_b
;
2270 len_a
= gfc_var_strlen (array
);
2271 len_b
= gfc_var_strlen (boundary
);
2272 if (len_a
!= -1 && len_b
!= -1 && len_a
!= len_b
)
2274 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2275 gfc_current_intrinsic_arg
[2]->name
,
2276 gfc_current_intrinsic_arg
[0]->name
,
2277 &boundary
->where
, gfc_current_intrinsic
);
2282 if (array
->rank
== 1 || boundary
->rank
== 0)
2284 if (!scalar_check (boundary
, 2))
2287 else if (boundary
->rank
== array
->rank
- 1)
2292 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2296 if (!identical_dimen_shape (array
, i
, boundary
, j
))
2298 gfc_error ("%qs argument of %qs intrinsic at %L has "
2299 "invalid shape in dimension %d (%ld/%ld)",
2300 gfc_current_intrinsic_arg
[2]->name
,
2301 gfc_current_intrinsic
, &shift
->where
, i
+1,
2302 mpz_get_si (array
->shape
[i
]),
2303 mpz_get_si (boundary
->shape
[j
]));
2313 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2314 "rank %d or be a scalar",
2315 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2316 &shift
->where
, array
->rank
- 1);
2322 switch (array
->ts
.type
)
2332 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2333 "of type %qs", gfc_current_intrinsic_arg
[2]->name
,
2334 gfc_current_intrinsic
, &array
->where
,
2335 gfc_current_intrinsic_arg
[0]->name
,
2336 gfc_typename (&array
->ts
));
2345 gfc_check_float (gfc_expr
*a
)
2347 if (!type_check (a
, 0, BT_INTEGER
))
2350 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2351 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2352 "kind argument to %s intrinsic at %L",
2353 gfc_current_intrinsic
, &a
->where
))
2359 /* A single complex argument. */
2362 gfc_check_fn_c (gfc_expr
*a
)
2364 if (!type_check (a
, 0, BT_COMPLEX
))
2371 /* A single real argument. */
2374 gfc_check_fn_r (gfc_expr
*a
)
2376 if (!type_check (a
, 0, BT_REAL
))
2382 /* A single double argument. */
2385 gfc_check_fn_d (gfc_expr
*a
)
2387 if (!double_check (a
, 0))
2393 /* A single real or complex argument. */
2396 gfc_check_fn_rc (gfc_expr
*a
)
2398 if (!real_or_complex_check (a
, 0))
2406 gfc_check_fn_rc2008 (gfc_expr
*a
)
2408 if (!real_or_complex_check (a
, 0))
2411 if (a
->ts
.type
== BT_COMPLEX
2412 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2413 "of %qs intrinsic at %L",
2414 gfc_current_intrinsic_arg
[0]->name
,
2415 gfc_current_intrinsic
, &a
->where
))
2423 gfc_check_fnum (gfc_expr
*unit
)
2425 if (!type_check (unit
, 0, BT_INTEGER
))
2428 if (!scalar_check (unit
, 0))
2436 gfc_check_huge (gfc_expr
*x
)
2438 if (!int_or_real_check (x
, 0))
2446 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2448 if (!type_check (x
, 0, BT_REAL
))
2450 if (!same_type_check (x
, 0, y
, 1))
2457 /* Check that the single argument is an integer. */
2460 gfc_check_i (gfc_expr
*i
)
2462 if (!type_check (i
, 0, BT_INTEGER
))
2470 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2472 if (!type_check (i
, 0, BT_INTEGER
))
2475 if (!type_check (j
, 1, BT_INTEGER
))
2478 if (i
->ts
.kind
!= j
->ts
.kind
)
2480 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2490 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2492 if (!type_check (i
, 0, BT_INTEGER
))
2495 if (!type_check (pos
, 1, BT_INTEGER
))
2498 if (!type_check (len
, 2, BT_INTEGER
))
2501 if (!nonnegative_check ("pos", pos
))
2504 if (!nonnegative_check ("len", len
))
2507 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2515 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2519 if (!type_check (c
, 0, BT_CHARACTER
))
2522 if (!kind_check (kind
, 1, BT_INTEGER
))
2525 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2526 "with KIND argument at %L",
2527 gfc_current_intrinsic
, &kind
->where
))
2530 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2536 /* Substring references don't have the charlength set. */
2538 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2541 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2545 /* Check that the argument is length one. Non-constant lengths
2546 can't be checked here, so assume they are ok. */
2547 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2549 /* If we already have a length for this expression then use it. */
2550 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2552 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2559 start
= ref
->u
.ss
.start
;
2560 end
= ref
->u
.ss
.end
;
2563 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2564 || start
->expr_type
!= EXPR_CONSTANT
)
2567 i
= mpz_get_si (end
->value
.integer
) + 1
2568 - mpz_get_si (start
->value
.integer
);
2576 gfc_error ("Argument of %s at %L must be of length one",
2577 gfc_current_intrinsic
, &c
->where
);
2586 gfc_check_idnint (gfc_expr
*a
)
2588 if (!double_check (a
, 0))
2596 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2598 if (!type_check (i
, 0, BT_INTEGER
))
2601 if (!type_check (j
, 1, BT_INTEGER
))
2604 if (i
->ts
.kind
!= j
->ts
.kind
)
2606 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2616 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2619 if (!type_check (string
, 0, BT_CHARACTER
)
2620 || !type_check (substring
, 1, BT_CHARACTER
))
2623 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2626 if (!kind_check (kind
, 3, BT_INTEGER
))
2628 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2629 "with KIND argument at %L",
2630 gfc_current_intrinsic
, &kind
->where
))
2633 if (string
->ts
.kind
!= substring
->ts
.kind
)
2635 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2636 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2637 gfc_current_intrinsic
, &substring
->where
,
2638 gfc_current_intrinsic_arg
[0]->name
);
2647 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2649 if (!numeric_check (x
, 0))
2652 if (!kind_check (kind
, 1, BT_INTEGER
))
2660 gfc_check_intconv (gfc_expr
*x
)
2662 if (!numeric_check (x
, 0))
2670 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2672 if (!type_check (i
, 0, BT_INTEGER
))
2675 if (!type_check (j
, 1, BT_INTEGER
))
2678 if (i
->ts
.kind
!= j
->ts
.kind
)
2680 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2690 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2692 if (!type_check (i
, 0, BT_INTEGER
)
2693 || !type_check (shift
, 1, BT_INTEGER
))
2696 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2704 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2706 if (!type_check (i
, 0, BT_INTEGER
)
2707 || !type_check (shift
, 1, BT_INTEGER
))
2714 if (!type_check (size
, 2, BT_INTEGER
))
2717 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2720 if (size
->expr_type
== EXPR_CONSTANT
)
2722 gfc_extract_int (size
, &i3
);
2725 gfc_error ("SIZE at %L must be positive", &size
->where
);
2729 if (shift
->expr_type
== EXPR_CONSTANT
)
2731 gfc_extract_int (shift
, &i2
);
2737 gfc_error ("The absolute value of SHIFT at %L must be less "
2738 "than or equal to SIZE at %L", &shift
->where
,
2745 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2753 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2755 if (!type_check (pid
, 0, BT_INTEGER
))
2758 if (!scalar_check (pid
, 0))
2761 if (!type_check (sig
, 1, BT_INTEGER
))
2764 if (!scalar_check (sig
, 1))
2772 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2774 if (!type_check (pid
, 0, BT_INTEGER
))
2777 if (!scalar_check (pid
, 0))
2780 if (!type_check (sig
, 1, BT_INTEGER
))
2783 if (!scalar_check (sig
, 1))
2788 if (!type_check (status
, 2, BT_INTEGER
))
2791 if (!scalar_check (status
, 2))
2800 gfc_check_kind (gfc_expr
*x
)
2802 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
2804 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2805 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2806 gfc_current_intrinsic
, &x
->where
);
2809 if (x
->ts
.type
== BT_PROCEDURE
)
2811 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2812 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2822 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2824 if (!array_check (array
, 0))
2827 if (!dim_check (dim
, 1, false))
2830 if (!dim_rank_check (dim
, array
, 1))
2833 if (!kind_check (kind
, 2, BT_INTEGER
))
2835 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2836 "with KIND argument at %L",
2837 gfc_current_intrinsic
, &kind
->where
))
2845 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2847 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2849 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2853 if (!coarray_check (coarray
, 0))
2858 if (!dim_check (dim
, 1, false))
2861 if (!dim_corank_check (dim
, coarray
))
2865 if (!kind_check (kind
, 2, BT_INTEGER
))
2873 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2875 if (!type_check (s
, 0, BT_CHARACTER
))
2878 if (!kind_check (kind
, 1, BT_INTEGER
))
2880 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2881 "with KIND argument at %L",
2882 gfc_current_intrinsic
, &kind
->where
))
2890 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2892 if (!type_check (a
, 0, BT_CHARACTER
))
2894 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2897 if (!type_check (b
, 1, BT_CHARACTER
))
2899 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2907 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2909 if (!type_check (path1
, 0, BT_CHARACTER
))
2911 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2914 if (!type_check (path2
, 1, BT_CHARACTER
))
2916 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2924 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2926 if (!type_check (path1
, 0, BT_CHARACTER
))
2928 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2931 if (!type_check (path2
, 1, BT_CHARACTER
))
2933 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2939 if (!type_check (status
, 2, BT_INTEGER
))
2942 if (!scalar_check (status
, 2))
2950 gfc_check_loc (gfc_expr
*expr
)
2952 return variable_check (expr
, 0, true);
2957 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2959 if (!type_check (path1
, 0, BT_CHARACTER
))
2961 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2964 if (!type_check (path2
, 1, BT_CHARACTER
))
2966 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2974 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2976 if (!type_check (path1
, 0, BT_CHARACTER
))
2978 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2981 if (!type_check (path2
, 1, BT_CHARACTER
))
2983 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2989 if (!type_check (status
, 2, BT_INTEGER
))
2992 if (!scalar_check (status
, 2))
3000 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
3002 if (!type_check (a
, 0, BT_LOGICAL
))
3004 if (!kind_check (kind
, 1, BT_LOGICAL
))
3011 /* Min/max family. */
3014 min_max_args (gfc_actual_arglist
*args
)
3016 gfc_actual_arglist
*arg
;
3017 int i
, j
, nargs
, *nlabels
, nlabelless
;
3018 bool a1
= false, a2
= false;
3020 if (args
== NULL
|| args
->next
== NULL
)
3022 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3023 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
3030 if (!args
->next
->name
)
3034 for (arg
= args
; arg
; arg
= arg
->next
)
3041 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3043 nlabels
= XALLOCAVEC (int, nargs
);
3044 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
3050 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
3052 n
= strtol (&arg
->name
[1], &endp
, 10);
3053 if (endp
[0] != '\0')
3057 if (n
<= nlabelless
)
3070 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3071 !a1
? "a1" : "a2", gfc_current_intrinsic
,
3072 gfc_current_intrinsic_where
);
3076 /* Check for duplicates. */
3077 for (i
= 0; i
< nargs
; i
++)
3078 for (j
= i
+ 1; j
< nargs
; j
++)
3079 if (nlabels
[i
] == nlabels
[j
])
3085 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3086 &arg
->expr
->where
, gfc_current_intrinsic
);
3090 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3091 &arg
->expr
->where
, gfc_current_intrinsic
);
3097 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3099 gfc_actual_arglist
*arg
, *tmp
;
3103 if (!min_max_args (arglist
))
3106 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3109 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3111 if (x
->ts
.type
== type
)
3113 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3114 "kinds at %L", &x
->where
))
3119 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3120 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3121 gfc_basic_typename (type
), kind
);
3126 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3127 if (!gfc_check_conformance (tmp
->expr
, x
,
3128 "arguments 'a%d' and 'a%d' for "
3129 "intrinsic '%s'", m
, n
,
3130 gfc_current_intrinsic
))
3139 gfc_check_min_max (gfc_actual_arglist
*arg
)
3143 if (!min_max_args (arg
))
3148 if (x
->ts
.type
== BT_CHARACTER
)
3150 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3151 "with CHARACTER argument at %L",
3152 gfc_current_intrinsic
, &x
->where
))
3155 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3157 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3158 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3162 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3167 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3169 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3174 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3176 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3181 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3183 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3187 /* End of min/max family. */
3190 gfc_check_malloc (gfc_expr
*size
)
3192 if (!type_check (size
, 0, BT_INTEGER
))
3195 if (!scalar_check (size
, 0))
3203 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3205 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3207 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3208 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3209 gfc_current_intrinsic
, &matrix_a
->where
);
3213 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3215 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3216 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3217 gfc_current_intrinsic
, &matrix_b
->where
);
3221 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3222 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3224 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3225 gfc_current_intrinsic
, &matrix_a
->where
,
3226 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3230 switch (matrix_a
->rank
)
3233 if (!rank_check (matrix_b
, 1, 2))
3235 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3236 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3238 gfc_error ("Different shape on dimension 1 for arguments %qs "
3239 "and %qs at %L for intrinsic matmul",
3240 gfc_current_intrinsic_arg
[0]->name
,
3241 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3247 if (matrix_b
->rank
!= 2)
3249 if (!rank_check (matrix_b
, 1, 1))
3252 /* matrix_b has rank 1 or 2 here. Common check for the cases
3253 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3254 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3255 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3257 gfc_error ("Different shape on dimension 2 for argument %qs and "
3258 "dimension 1 for argument %qs at %L for intrinsic "
3259 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3260 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3266 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3267 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3268 gfc_current_intrinsic
, &matrix_a
->where
);
3276 /* Whoever came up with this interface was probably on something.
3277 The possibilities for the occupation of the second and third
3284 NULL MASK minloc(array, mask=m)
3287 I.e. in the case of minloc(array,mask), mask will be in the second
3288 position of the argument list and we'll have to fix that up. Also,
3289 add the BACK argument if that isn't present. */
3292 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3294 gfc_expr
*a
, *m
, *d
, *k
, *b
;
3297 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3301 m
= ap
->next
->next
->expr
;
3302 k
= ap
->next
->next
->next
->expr
;
3303 b
= ap
->next
->next
->next
->next
->expr
;
3307 if (!type_check (b
, 4, BT_LOGICAL
) || !scalar_check (b
,4))
3310 /* TODO: Remove this once BACK is actually implemented. */
3311 if (b
->expr_type
!= EXPR_CONSTANT
|| b
->value
.logical
!= 0)
3313 gfc_error ("BACK argument to %qs intrinsic not yet "
3314 "implemented", gfc_current_intrinsic
);
3320 b
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, 0);
3321 ap
->next
->next
->next
->next
->expr
= b
;
3324 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3325 && ap
->next
->name
== NULL
)
3329 ap
->next
->expr
= NULL
;
3330 ap
->next
->next
->expr
= m
;
3333 if (!dim_check (d
, 1, false))
3336 if (!dim_rank_check (d
, a
, 0))
3339 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3343 && !gfc_check_conformance (a
, m
,
3344 "arguments '%s' and '%s' for intrinsic %s",
3345 gfc_current_intrinsic_arg
[0]->name
,
3346 gfc_current_intrinsic_arg
[2]->name
,
3347 gfc_current_intrinsic
))
3350 if (!kind_check (k
, 1, BT_INTEGER
))
3357 /* Similar to minloc/maxloc, the argument list might need to be
3358 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3359 difference is that MINLOC/MAXLOC take an additional KIND argument.
3360 The possibilities are:
3366 NULL MASK minval(array, mask=m)
3369 I.e. in the case of minval(array,mask), mask will be in the second
3370 position of the argument list and we'll have to fix that up. */
3373 check_reduction (gfc_actual_arglist
*ap
)
3375 gfc_expr
*a
, *m
, *d
;
3379 m
= ap
->next
->next
->expr
;
3381 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3382 && ap
->next
->name
== NULL
)
3386 ap
->next
->expr
= NULL
;
3387 ap
->next
->next
->expr
= m
;
3390 if (!dim_check (d
, 1, false))
3393 if (!dim_rank_check (d
, a
, 0))
3396 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3400 && !gfc_check_conformance (a
, m
,
3401 "arguments '%s' and '%s' for intrinsic %s",
3402 gfc_current_intrinsic_arg
[0]->name
,
3403 gfc_current_intrinsic_arg
[2]->name
,
3404 gfc_current_intrinsic
))
3412 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3414 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
3415 || !array_check (ap
->expr
, 0))
3418 return check_reduction (ap
);
3423 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3425 if (!numeric_check (ap
->expr
, 0)
3426 || !array_check (ap
->expr
, 0))
3429 return check_reduction (ap
);
3433 /* For IANY, IALL and IPARITY. */
3436 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3440 if (!type_check (i
, 0, BT_INTEGER
))
3443 if (!nonnegative_check ("I", i
))
3446 if (!kind_check (kind
, 1, BT_INTEGER
))
3450 gfc_extract_int (kind
, &k
);
3452 k
= gfc_default_integer_kind
;
3454 if (!less_than_bitsizekind ("I", i
, k
))
3462 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3464 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3466 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3467 gfc_current_intrinsic_arg
[0]->name
,
3468 gfc_current_intrinsic
, &ap
->expr
->where
);
3472 if (!array_check (ap
->expr
, 0))
3475 return check_reduction (ap
);
3480 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3482 if (!same_type_check (tsource
, 0, fsource
, 1))
3485 if (!type_check (mask
, 2, BT_LOGICAL
))
3488 if (tsource
->ts
.type
== BT_CHARACTER
)
3489 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3496 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3498 if (!type_check (i
, 0, BT_INTEGER
))
3501 if (!type_check (j
, 1, BT_INTEGER
))
3504 if (!type_check (mask
, 2, BT_INTEGER
))
3507 if (!same_type_check (i
, 0, j
, 1))
3510 if (!same_type_check (i
, 0, mask
, 2))
3518 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3520 if (!variable_check (from
, 0, false))
3522 if (!allocatable_check (from
, 0))
3524 if (gfc_is_coindexed (from
))
3526 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3527 "coindexed", &from
->where
);
3531 if (!variable_check (to
, 1, false))
3533 if (!allocatable_check (to
, 1))
3535 if (gfc_is_coindexed (to
))
3537 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3538 "coindexed", &to
->where
);
3542 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3544 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3545 "polymorphic if FROM is polymorphic",
3550 if (!same_type_check (to
, 1, from
, 0))
3553 if (to
->rank
!= from
->rank
)
3555 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3556 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3561 /* IR F08/0040; cf. 12-006A. */
3562 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3564 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3565 "must have the same corank %d/%d", &to
->where
,
3566 gfc_get_corank (from
), gfc_get_corank (to
));
3570 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3571 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3572 and cmp2 are allocatable. After the allocation is transferred,
3573 the 'to' chain is broken by the nullification of the 'from'. A bit
3574 of reflection reveals that this can only occur for derived types
3575 with recursive allocatable components. */
3576 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3577 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3579 gfc_ref
*to_ref
, *from_ref
;
3581 from_ref
= from
->ref
;
3582 bool aliasing
= true;
3584 for (; from_ref
&& to_ref
;
3585 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3587 if (to_ref
->type
!= from
->ref
->type
)
3589 else if (to_ref
->type
== REF_ARRAY
3590 && to_ref
->u
.ar
.type
!= AR_FULL
3591 && from_ref
->u
.ar
.type
!= AR_FULL
)
3592 /* Play safe; assume sections and elements are different. */
3594 else if (to_ref
->type
== REF_COMPONENT
3595 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3604 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3605 "restrictions (F2003 12.4.1.7)", &to
->where
);
3610 /* CLASS arguments: Make sure the vtab of from is present. */
3611 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3612 gfc_find_vtab (&from
->ts
);
3619 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3621 if (!type_check (x
, 0, BT_REAL
))
3624 if (!type_check (s
, 1, BT_REAL
))
3627 if (s
->expr_type
== EXPR_CONSTANT
)
3629 if (mpfr_sgn (s
->value
.real
) == 0)
3631 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3642 gfc_check_new_line (gfc_expr
*a
)
3644 if (!type_check (a
, 0, BT_CHARACTER
))
3652 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3654 if (!type_check (array
, 0, BT_REAL
))
3657 if (!array_check (array
, 0))
3660 if (!dim_rank_check (dim
, array
, false))
3667 gfc_check_null (gfc_expr
*mold
)
3669 symbol_attribute attr
;
3674 if (!variable_check (mold
, 0, true))
3677 attr
= gfc_variable_attr (mold
, NULL
);
3679 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3681 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3682 "ALLOCATABLE or procedure pointer",
3683 gfc_current_intrinsic_arg
[0]->name
,
3684 gfc_current_intrinsic
, &mold
->where
);
3688 if (attr
.allocatable
3689 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3690 "allocatable MOLD at %L", &mold
->where
))
3694 if (gfc_is_coindexed (mold
))
3696 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3697 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3698 gfc_current_intrinsic
, &mold
->where
);
3707 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3709 if (!array_check (array
, 0))
3712 if (!type_check (mask
, 1, BT_LOGICAL
))
3715 if (!gfc_check_conformance (array
, mask
,
3716 "arguments '%s' and '%s' for intrinsic '%s'",
3717 gfc_current_intrinsic_arg
[0]->name
,
3718 gfc_current_intrinsic_arg
[1]->name
,
3719 gfc_current_intrinsic
))
3724 mpz_t array_size
, vector_size
;
3725 bool have_array_size
, have_vector_size
;
3727 if (!same_type_check (array
, 0, vector
, 2))
3730 if (!rank_check (vector
, 2, 1))
3733 /* VECTOR requires at least as many elements as MASK
3734 has .TRUE. values. */
3735 have_array_size
= gfc_array_size(array
, &array_size
);
3736 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3738 if (have_vector_size
3739 && (mask
->expr_type
== EXPR_ARRAY
3740 || (mask
->expr_type
== EXPR_CONSTANT
3741 && have_array_size
)))
3743 int mask_true_values
= 0;
3745 if (mask
->expr_type
== EXPR_ARRAY
)
3747 gfc_constructor
*mask_ctor
;
3748 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3751 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3753 mask_true_values
= 0;
3757 if (mask_ctor
->expr
->value
.logical
)
3760 mask_ctor
= gfc_constructor_next (mask_ctor
);
3763 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3764 mask_true_values
= mpz_get_si (array_size
);
3766 if (mpz_get_si (vector_size
) < mask_true_values
)
3768 gfc_error ("%qs argument of %qs intrinsic at %L must "
3769 "provide at least as many elements as there "
3770 "are .TRUE. values in %qs (%ld/%d)",
3771 gfc_current_intrinsic_arg
[2]->name
,
3772 gfc_current_intrinsic
, &vector
->where
,
3773 gfc_current_intrinsic_arg
[1]->name
,
3774 mpz_get_si (vector_size
), mask_true_values
);
3779 if (have_array_size
)
3780 mpz_clear (array_size
);
3781 if (have_vector_size
)
3782 mpz_clear (vector_size
);
3790 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3792 if (!type_check (mask
, 0, BT_LOGICAL
))
3795 if (!array_check (mask
, 0))
3798 if (!dim_rank_check (dim
, mask
, false))
3806 gfc_check_precision (gfc_expr
*x
)
3808 if (!real_or_complex_check (x
, 0))
3816 gfc_check_present (gfc_expr
*a
)
3820 if (!variable_check (a
, 0, true))
3823 sym
= a
->symtree
->n
.sym
;
3824 if (!sym
->attr
.dummy
)
3826 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3827 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3828 gfc_current_intrinsic
, &a
->where
);
3832 if (!sym
->attr
.optional
)
3834 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3835 "an OPTIONAL dummy variable",
3836 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3841 /* 13.14.82 PRESENT(A)
3843 Argument. A shall be the name of an optional dummy argument that is
3844 accessible in the subprogram in which the PRESENT function reference
3848 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3849 && (a
->ref
->u
.ar
.type
== AR_FULL
3850 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3851 && a
->ref
->u
.ar
.as
->rank
== 0))))
3853 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3854 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3855 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3864 gfc_check_radix (gfc_expr
*x
)
3866 if (!int_or_real_check (x
, 0))
3874 gfc_check_range (gfc_expr
*x
)
3876 if (!numeric_check (x
, 0))
3884 gfc_check_rank (gfc_expr
*a
)
3886 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3887 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3889 bool is_variable
= true;
3891 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3892 if (a
->expr_type
== EXPR_FUNCTION
)
3893 is_variable
= a
->value
.function
.esym
3894 ? a
->value
.function
.esym
->result
->attr
.pointer
3895 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3897 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3898 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3901 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3902 "object", &a
->where
);
3910 /* real, float, sngl. */
3912 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3914 if (!numeric_check (a
, 0))
3917 if (!kind_check (kind
, 1, BT_REAL
))
3925 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3927 if (!type_check (path1
, 0, BT_CHARACTER
))
3929 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3932 if (!type_check (path2
, 1, BT_CHARACTER
))
3934 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3942 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3944 if (!type_check (path1
, 0, BT_CHARACTER
))
3946 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3949 if (!type_check (path2
, 1, BT_CHARACTER
))
3951 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3957 if (!type_check (status
, 2, BT_INTEGER
))
3960 if (!scalar_check (status
, 2))
3968 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3970 if (!type_check (x
, 0, BT_CHARACTER
))
3973 if (!scalar_check (x
, 0))
3976 if (!type_check (y
, 0, BT_INTEGER
))
3979 if (!scalar_check (y
, 1))
3987 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3988 gfc_expr
*pad
, gfc_expr
*order
)
3994 if (!array_check (source
, 0))
3997 if (!rank_check (shape
, 1, 1))
4000 if (!type_check (shape
, 1, BT_INTEGER
))
4003 if (!gfc_array_size (shape
, &size
))
4005 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4006 "array of constant size", &shape
->where
);
4010 shape_size
= mpz_get_ui (size
);
4013 if (shape_size
<= 0)
4015 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4016 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4020 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4022 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4023 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4026 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
4030 for (i
= 0; i
< shape_size
; ++i
)
4032 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4033 if (e
->expr_type
!= EXPR_CONSTANT
)
4036 gfc_extract_int (e
, &extent
);
4039 gfc_error ("%qs argument of %qs intrinsic at %L has "
4040 "negative element (%d)",
4041 gfc_current_intrinsic_arg
[1]->name
,
4042 gfc_current_intrinsic
, &e
->where
, extent
);
4047 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4048 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4049 && shape
->ref
->u
.ar
.as
4050 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4051 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4052 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4053 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4054 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4059 v
= shape
->symtree
->n
.sym
->value
;
4061 for (i
= 0; i
< shape_size
; i
++)
4063 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4067 gfc_extract_int (e
, &extent
);
4071 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4072 "cannot be negative", i
+ 1, &shape
->where
);
4080 if (!same_type_check (source
, 0, pad
, 2))
4083 if (!array_check (pad
, 2))
4089 if (!array_check (order
, 3))
4092 if (!type_check (order
, 3, BT_INTEGER
))
4095 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4097 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4100 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4103 gfc_array_size (order
, &size
);
4104 order_size
= mpz_get_ui (size
);
4107 if (order_size
!= shape_size
)
4109 gfc_error ("%qs argument of %qs intrinsic at %L "
4110 "has wrong number of elements (%d/%d)",
4111 gfc_current_intrinsic_arg
[3]->name
,
4112 gfc_current_intrinsic
, &order
->where
,
4113 order_size
, shape_size
);
4117 for (i
= 1; i
<= order_size
; ++i
)
4119 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4120 if (e
->expr_type
!= EXPR_CONSTANT
)
4123 gfc_extract_int (e
, &dim
);
4125 if (dim
< 1 || dim
> order_size
)
4127 gfc_error ("%qs argument of %qs intrinsic at %L "
4128 "has out-of-range dimension (%d)",
4129 gfc_current_intrinsic_arg
[3]->name
,
4130 gfc_current_intrinsic
, &e
->where
, dim
);
4134 if (perm
[dim
-1] != 0)
4136 gfc_error ("%qs argument of %qs intrinsic at %L has "
4137 "invalid permutation of dimensions (dimension "
4139 gfc_current_intrinsic_arg
[3]->name
,
4140 gfc_current_intrinsic
, &e
->where
, dim
);
4149 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4150 && gfc_is_constant_expr (shape
)
4151 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4152 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4154 /* Check the match in size between source and destination. */
4155 if (gfc_array_size (source
, &nelems
))
4161 mpz_init_set_ui (size
, 1);
4162 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4163 c
; c
= gfc_constructor_next (c
))
4164 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4166 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4172 gfc_error ("Without padding, there are not enough elements "
4173 "in the intrinsic RESHAPE source at %L to match "
4174 "the shape", &source
->where
);
4185 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4187 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4189 gfc_error ("%qs argument of %qs intrinsic at %L "
4190 "cannot be of type %s",
4191 gfc_current_intrinsic_arg
[0]->name
,
4192 gfc_current_intrinsic
,
4193 &a
->where
, gfc_typename (&a
->ts
));
4197 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4199 gfc_error ("%qs argument of %qs intrinsic at %L "
4200 "must be of an extensible type",
4201 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4206 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4208 gfc_error ("%qs argument of %qs intrinsic at %L "
4209 "cannot be of type %s",
4210 gfc_current_intrinsic_arg
[0]->name
,
4211 gfc_current_intrinsic
,
4212 &b
->where
, gfc_typename (&b
->ts
));
4216 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4218 gfc_error ("%qs argument of %qs intrinsic at %L "
4219 "must be of an extensible type",
4220 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4230 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4232 if (!type_check (x
, 0, BT_REAL
))
4235 if (!type_check (i
, 1, BT_INTEGER
))
4243 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4245 if (!type_check (x
, 0, BT_CHARACTER
))
4248 if (!type_check (y
, 1, BT_CHARACTER
))
4251 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4254 if (!kind_check (kind
, 3, BT_INTEGER
))
4256 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4257 "with KIND argument at %L",
4258 gfc_current_intrinsic
, &kind
->where
))
4261 if (!same_type_check (x
, 0, y
, 1))
4269 gfc_check_secnds (gfc_expr
*r
)
4271 if (!type_check (r
, 0, BT_REAL
))
4274 if (!kind_value_check (r
, 0, 4))
4277 if (!scalar_check (r
, 0))
4285 gfc_check_selected_char_kind (gfc_expr
*name
)
4287 if (!type_check (name
, 0, BT_CHARACTER
))
4290 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4293 if (!scalar_check (name
, 0))
4301 gfc_check_selected_int_kind (gfc_expr
*r
)
4303 if (!type_check (r
, 0, BT_INTEGER
))
4306 if (!scalar_check (r
, 0))
4314 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4316 if (p
== NULL
&& r
== NULL
4317 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4318 " neither %<P%> nor %<R%> argument at %L",
4319 gfc_current_intrinsic_where
))
4324 if (!type_check (p
, 0, BT_INTEGER
))
4327 if (!scalar_check (p
, 0))
4333 if (!type_check (r
, 1, BT_INTEGER
))
4336 if (!scalar_check (r
, 1))
4342 if (!type_check (radix
, 1, BT_INTEGER
))
4345 if (!scalar_check (radix
, 1))
4348 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4349 "RADIX argument at %L", gfc_current_intrinsic
,
4359 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4361 if (!type_check (x
, 0, BT_REAL
))
4364 if (!type_check (i
, 1, BT_INTEGER
))
4372 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4376 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4379 ar
= gfc_find_array_ref (source
);
4381 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4383 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4384 "an assumed size array", &source
->where
);
4388 if (!kind_check (kind
, 1, BT_INTEGER
))
4390 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4391 "with KIND argument at %L",
4392 gfc_current_intrinsic
, &kind
->where
))
4400 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4402 if (!type_check (i
, 0, BT_INTEGER
))
4405 if (!type_check (shift
, 0, BT_INTEGER
))
4408 if (!nonnegative_check ("SHIFT", shift
))
4411 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4419 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4421 if (!int_or_real_check (a
, 0))
4424 if (!same_type_check (a
, 0, b
, 1))
4432 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4434 if (!array_check (array
, 0))
4437 if (!dim_check (dim
, 1, true))
4440 if (!dim_rank_check (dim
, array
, 0))
4443 if (!kind_check (kind
, 2, BT_INTEGER
))
4445 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4446 "with KIND argument at %L",
4447 gfc_current_intrinsic
, &kind
->where
))
4456 gfc_check_sizeof (gfc_expr
*arg
)
4458 if (arg
->ts
.type
== BT_PROCEDURE
)
4460 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4461 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4466 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4467 if (arg
->ts
.type
== BT_ASSUMED
4468 && (arg
->symtree
->n
.sym
->as
== NULL
4469 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4470 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4471 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4473 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4474 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4479 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4480 && arg
->symtree
->n
.sym
->as
!= NULL
4481 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4482 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4484 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4485 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4486 gfc_current_intrinsic
, &arg
->where
);
4494 /* Check whether an expression is interoperable. When returning false,
4495 msg is set to a string telling why the expression is not interoperable,
4496 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4497 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4498 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4499 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4503 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4507 if (expr
->ts
.type
== BT_CLASS
)
4509 *msg
= "Expression is polymorphic";
4513 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4514 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4516 *msg
= "Expression is a noninteroperable derived type";
4520 if (expr
->ts
.type
== BT_PROCEDURE
)
4522 *msg
= "Procedure unexpected as argument";
4526 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4529 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4530 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4532 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4536 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4537 && expr
->ts
.kind
!= 1)
4539 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4543 if (expr
->ts
.type
== BT_CHARACTER
) {
4544 if (expr
->ts
.deferred
)
4546 /* TS 29113 allows deferred-length strings as dummy arguments,
4547 but it is not an interoperable type. */
4548 *msg
= "Expression shall not be a deferred-length string";
4552 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4553 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4554 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4556 if (!c_loc
&& expr
->ts
.u
.cl
4557 && (!expr
->ts
.u
.cl
->length
4558 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4559 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4561 *msg
= "Type shall have a character length of 1";
4566 /* Note: The following checks are about interoperatable variables, Fortran
4567 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4568 is allowed, e.g. assumed-shape arrays with TS 29113. */
4570 if (gfc_is_coarray (expr
))
4572 *msg
= "Coarrays are not interoperable";
4576 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4578 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4579 if (ar
->type
!= AR_FULL
)
4581 *msg
= "Only whole-arrays are interoperable";
4584 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4585 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4587 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4597 gfc_check_c_sizeof (gfc_expr
*arg
)
4601 if (!is_c_interoperable (arg
, &msg
, false, false))
4603 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4604 "interoperable data entity: %s",
4605 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4610 if (arg
->ts
.type
== BT_ASSUMED
)
4612 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4614 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4619 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4620 && arg
->symtree
->n
.sym
->as
!= NULL
4621 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4622 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4624 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4625 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4626 gfc_current_intrinsic
, &arg
->where
);
4635 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4637 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4638 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4639 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4640 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4642 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4643 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4647 if (!scalar_check (c_ptr_1
, 0))
4651 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4652 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4653 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4654 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4656 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4657 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4658 gfc_typename (&c_ptr_1
->ts
),
4659 gfc_typename (&c_ptr_2
->ts
));
4663 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4671 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4673 symbol_attribute attr
;
4676 if (cptr
->ts
.type
!= BT_DERIVED
4677 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4678 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4680 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4681 "type TYPE(C_PTR)", &cptr
->where
);
4685 if (!scalar_check (cptr
, 0))
4688 attr
= gfc_expr_attr (fptr
);
4692 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4697 if (fptr
->ts
.type
== BT_CLASS
)
4699 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4704 if (gfc_is_coindexed (fptr
))
4706 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4707 "coindexed", &fptr
->where
);
4711 if (fptr
->rank
== 0 && shape
)
4713 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4714 "FPTR", &fptr
->where
);
4717 else if (fptr
->rank
&& !shape
)
4719 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4720 "FPTR at %L", &fptr
->where
);
4724 if (shape
&& !rank_check (shape
, 2, 1))
4727 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4733 if (gfc_array_size (shape
, &size
))
4735 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4738 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4739 "size as the RANK of FPTR", &shape
->where
);
4746 if (fptr
->ts
.type
== BT_CLASS
)
4748 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4752 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
4753 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4754 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4761 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4763 symbol_attribute attr
;
4765 if (cptr
->ts
.type
!= BT_DERIVED
4766 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4767 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4769 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4770 "type TYPE(C_FUNPTR)", &cptr
->where
);
4774 if (!scalar_check (cptr
, 0))
4777 attr
= gfc_expr_attr (fptr
);
4779 if (!attr
.proc_pointer
)
4781 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4782 "pointer", &fptr
->where
);
4786 if (gfc_is_coindexed (fptr
))
4788 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4789 "coindexed", &fptr
->where
);
4793 if (!attr
.is_bind_c
)
4794 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4795 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4802 gfc_check_c_funloc (gfc_expr
*x
)
4804 symbol_attribute attr
;
4806 if (gfc_is_coindexed (x
))
4808 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4809 "coindexed", &x
->where
);
4813 attr
= gfc_expr_attr (x
);
4815 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4816 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4818 gfc_namespace
*ns
= gfc_current_ns
;
4820 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4821 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4823 gfc_error ("Function result %qs at %L is invalid as X argument "
4824 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4829 if (attr
.flavor
!= FL_PROCEDURE
)
4831 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4832 "or a procedure pointer", &x
->where
);
4836 if (!attr
.is_bind_c
)
4837 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4838 "at %L to C_FUNLOC", &x
->where
);
4844 gfc_check_c_loc (gfc_expr
*x
)
4846 symbol_attribute attr
;
4849 if (gfc_is_coindexed (x
))
4851 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4855 if (x
->ts
.type
== BT_CLASS
)
4857 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4862 attr
= gfc_expr_attr (x
);
4865 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4866 || attr
.flavor
== FL_PARAMETER
))
4868 gfc_error ("Argument X at %L to C_LOC shall have either "
4869 "the POINTER or the TARGET attribute", &x
->where
);
4873 if (x
->ts
.type
== BT_CHARACTER
4874 && gfc_var_strlen (x
) == 0)
4876 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4877 "string", &x
->where
);
4881 if (!is_c_interoperable (x
, &msg
, true, false))
4883 if (x
->ts
.type
== BT_CLASS
)
4885 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4891 && !gfc_notify_std (GFC_STD_F2008_TS
,
4892 "Noninteroperable array at %L as"
4893 " argument to C_LOC: %s", &x
->where
, msg
))
4896 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4898 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4900 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4901 && !attr
.allocatable
4902 && !gfc_notify_std (GFC_STD_F2008
,
4903 "Array of interoperable type at %L "
4904 "to C_LOC which is nonallocatable and neither "
4905 "assumed size nor explicit size", &x
->where
))
4907 else if (ar
->type
!= AR_FULL
4908 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4909 "to C_LOC", &x
->where
))
4918 gfc_check_sleep_sub (gfc_expr
*seconds
)
4920 if (!type_check (seconds
, 0, BT_INTEGER
))
4923 if (!scalar_check (seconds
, 0))
4930 gfc_check_sngl (gfc_expr
*a
)
4932 if (!type_check (a
, 0, BT_REAL
))
4935 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4936 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4937 "REAL argument to %s intrinsic at %L",
4938 gfc_current_intrinsic
, &a
->where
))
4945 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4947 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4949 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4950 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4951 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4959 if (!dim_check (dim
, 1, false))
4962 /* dim_rank_check() does not apply here. */
4964 && dim
->expr_type
== EXPR_CONSTANT
4965 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4966 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4968 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4969 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4970 gfc_current_intrinsic
, &dim
->where
);
4974 if (!type_check (ncopies
, 2, BT_INTEGER
))
4977 if (!scalar_check (ncopies
, 2))
4984 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4988 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4990 if (!type_check (unit
, 0, BT_INTEGER
))
4993 if (!scalar_check (unit
, 0))
4996 if (!type_check (c
, 1, BT_CHARACTER
))
4998 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5004 if (!type_check (status
, 2, BT_INTEGER
)
5005 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5006 || !scalar_check (status
, 2))
5014 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5016 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5021 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5023 if (!type_check (c
, 0, BT_CHARACTER
))
5025 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5031 if (!type_check (status
, 1, BT_INTEGER
)
5032 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5033 || !scalar_check (status
, 1))
5041 gfc_check_fgetput (gfc_expr
*c
)
5043 return gfc_check_fgetput_sub (c
, NULL
);
5048 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5050 if (!type_check (unit
, 0, BT_INTEGER
))
5053 if (!scalar_check (unit
, 0))
5056 if (!type_check (offset
, 1, BT_INTEGER
))
5059 if (!scalar_check (offset
, 1))
5062 if (!type_check (whence
, 2, BT_INTEGER
))
5065 if (!scalar_check (whence
, 2))
5071 if (!type_check (status
, 3, BT_INTEGER
))
5074 if (!kind_value_check (status
, 3, 4))
5077 if (!scalar_check (status
, 3))
5086 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5088 if (!type_check (unit
, 0, BT_INTEGER
))
5091 if (!scalar_check (unit
, 0))
5094 if (!type_check (array
, 1, BT_INTEGER
)
5095 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5098 if (!array_check (array
, 1))
5106 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5108 if (!type_check (unit
, 0, BT_INTEGER
))
5111 if (!scalar_check (unit
, 0))
5114 if (!type_check (array
, 1, BT_INTEGER
)
5115 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5118 if (!array_check (array
, 1))
5124 if (!type_check (status
, 2, BT_INTEGER
)
5125 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5128 if (!scalar_check (status
, 2))
5136 gfc_check_ftell (gfc_expr
*unit
)
5138 if (!type_check (unit
, 0, BT_INTEGER
))
5141 if (!scalar_check (unit
, 0))
5149 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5151 if (!type_check (unit
, 0, BT_INTEGER
))
5154 if (!scalar_check (unit
, 0))
5157 if (!type_check (offset
, 1, BT_INTEGER
))
5160 if (!scalar_check (offset
, 1))
5168 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5170 if (!type_check (name
, 0, BT_CHARACTER
))
5172 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5175 if (!type_check (array
, 1, BT_INTEGER
)
5176 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5179 if (!array_check (array
, 1))
5187 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5189 if (!type_check (name
, 0, BT_CHARACTER
))
5191 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5194 if (!type_check (array
, 1, BT_INTEGER
)
5195 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5198 if (!array_check (array
, 1))
5204 if (!type_check (status
, 2, BT_INTEGER
)
5205 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5208 if (!scalar_check (status
, 2))
5216 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5220 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5222 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5226 if (!coarray_check (coarray
, 0))
5231 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5232 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5236 if (gfc_array_size (sub
, &nelems
))
5238 int corank
= gfc_get_corank (coarray
);
5240 if (mpz_cmp_ui (nelems
, corank
) != 0)
5242 gfc_error ("The number of array elements of the SUB argument to "
5243 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5244 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5256 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5258 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5260 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5266 if (!type_check (distance
, 0, BT_INTEGER
))
5269 if (!nonnegative_check ("DISTANCE", distance
))
5272 if (!scalar_check (distance
, 0))
5275 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5276 "NUM_IMAGES at %L", &distance
->where
))
5282 if (!type_check (failed
, 1, BT_LOGICAL
))
5285 if (!scalar_check (failed
, 1))
5288 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5289 "NUM_IMAGES at %L", &failed
->where
))
5298 gfc_check_team_number (gfc_expr
*team
)
5300 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5302 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5308 if (team
->ts
.type
!= BT_DERIVED
5309 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
5310 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
5312 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
5313 "shall be of type TEAM_TYPE", &team
->where
);
5325 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5327 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5329 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5333 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5336 if (dim
!= NULL
&& coarray
== NULL
)
5338 gfc_error ("DIM argument without COARRAY argument not allowed for "
5339 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5343 if (distance
&& (coarray
|| dim
))
5345 gfc_error ("The DISTANCE argument may not be specified together with the "
5346 "COARRAY or DIM argument in intrinsic at %L",
5351 /* Assume that we have "this_image (distance)". */
5352 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5356 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5365 if (!type_check (distance
, 2, BT_INTEGER
))
5368 if (!nonnegative_check ("DISTANCE", distance
))
5371 if (!scalar_check (distance
, 2))
5374 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5375 "THIS_IMAGE at %L", &distance
->where
))
5381 if (!coarray_check (coarray
, 0))
5386 if (!dim_check (dim
, 1, false))
5389 if (!dim_corank_check (dim
, coarray
))
5396 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5397 by gfc_simplify_transfer. Return false if we cannot do so. */
5400 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5401 size_t *source_size
, size_t *result_size
,
5402 size_t *result_length_p
)
5404 size_t result_elt_size
;
5406 if (source
->expr_type
== EXPR_FUNCTION
)
5409 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5412 /* Calculate the size of the source. */
5413 *source_size
= gfc_target_expr_size (source
);
5414 if (*source_size
== 0)
5417 /* Determine the size of the element. */
5418 result_elt_size
= gfc_element_size (mold
);
5419 if (result_elt_size
== 0)
5422 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5427 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5430 result_length
= *source_size
/ result_elt_size
;
5431 if (result_length
* result_elt_size
< *source_size
)
5435 *result_size
= result_length
* result_elt_size
;
5436 if (result_length_p
)
5437 *result_length_p
= result_length
;
5440 *result_size
= result_elt_size
;
5447 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5452 if (mold
->ts
.type
== BT_HOLLERITH
)
5454 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5455 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5461 if (!type_check (size
, 2, BT_INTEGER
))
5464 if (!scalar_check (size
, 2))
5467 if (!nonoptional_check (size
, 2))
5471 if (!warn_surprising
)
5474 /* If we can't calculate the sizes, we cannot check any more.
5475 Return true for that case. */
5477 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5478 &result_size
, NULL
))
5481 if (source_size
< result_size
)
5482 gfc_warning (OPT_Wsurprising
,
5483 "Intrinsic TRANSFER at %L has partly undefined result: "
5484 "source size %ld < result size %ld", &source
->where
,
5485 (long) source_size
, (long) result_size
);
5492 gfc_check_transpose (gfc_expr
*matrix
)
5494 if (!rank_check (matrix
, 0, 2))
5502 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5504 if (!array_check (array
, 0))
5507 if (!dim_check (dim
, 1, false))
5510 if (!dim_rank_check (dim
, array
, 0))
5513 if (!kind_check (kind
, 2, BT_INTEGER
))
5515 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5516 "with KIND argument at %L",
5517 gfc_current_intrinsic
, &kind
->where
))
5525 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5527 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5529 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5533 if (!coarray_check (coarray
, 0))
5538 if (!dim_check (dim
, 1, false))
5541 if (!dim_corank_check (dim
, coarray
))
5545 if (!kind_check (kind
, 2, BT_INTEGER
))
5553 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5557 if (!rank_check (vector
, 0, 1))
5560 if (!array_check (mask
, 1))
5563 if (!type_check (mask
, 1, BT_LOGICAL
))
5566 if (!same_type_check (vector
, 0, field
, 2))
5569 if (mask
->expr_type
== EXPR_ARRAY
5570 && gfc_array_size (vector
, &vector_size
))
5572 int mask_true_count
= 0;
5573 gfc_constructor
*mask_ctor
;
5574 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5577 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5579 mask_true_count
= 0;
5583 if (mask_ctor
->expr
->value
.logical
)
5586 mask_ctor
= gfc_constructor_next (mask_ctor
);
5589 if (mpz_get_si (vector_size
) < mask_true_count
)
5591 gfc_error ("%qs argument of %qs intrinsic at %L must "
5592 "provide at least as many elements as there "
5593 "are .TRUE. values in %qs (%ld/%d)",
5594 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5595 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5596 mpz_get_si (vector_size
), mask_true_count
);
5600 mpz_clear (vector_size
);
5603 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5605 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5606 "the same rank as %qs or be a scalar",
5607 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5608 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5612 if (mask
->rank
== field
->rank
)
5615 for (i
= 0; i
< field
->rank
; i
++)
5616 if (! identical_dimen_shape (mask
, i
, field
, i
))
5618 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5619 "must have identical shape.",
5620 gfc_current_intrinsic_arg
[2]->name
,
5621 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5631 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5633 if (!type_check (x
, 0, BT_CHARACTER
))
5636 if (!same_type_check (x
, 0, y
, 1))
5639 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5642 if (!kind_check (kind
, 3, BT_INTEGER
))
5644 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5645 "with KIND argument at %L",
5646 gfc_current_intrinsic
, &kind
->where
))
5654 gfc_check_trim (gfc_expr
*x
)
5656 if (!type_check (x
, 0, BT_CHARACTER
))
5659 if (!scalar_check (x
, 0))
5667 gfc_check_ttynam (gfc_expr
*unit
)
5669 if (!scalar_check (unit
, 0))
5672 if (!type_check (unit
, 0, BT_INTEGER
))
5679 /************* Check functions for intrinsic subroutines *************/
5682 gfc_check_cpu_time (gfc_expr
*time
)
5684 if (!scalar_check (time
, 0))
5687 if (!type_check (time
, 0, BT_REAL
))
5690 if (!variable_check (time
, 0, false))
5698 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5699 gfc_expr
*zone
, gfc_expr
*values
)
5703 if (!type_check (date
, 0, BT_CHARACTER
))
5705 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5707 if (!scalar_check (date
, 0))
5709 if (!variable_check (date
, 0, false))
5715 if (!type_check (time
, 1, BT_CHARACTER
))
5717 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5719 if (!scalar_check (time
, 1))
5721 if (!variable_check (time
, 1, false))
5727 if (!type_check (zone
, 2, BT_CHARACTER
))
5729 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5731 if (!scalar_check (zone
, 2))
5733 if (!variable_check (zone
, 2, false))
5739 if (!type_check (values
, 3, BT_INTEGER
))
5741 if (!array_check (values
, 3))
5743 if (!rank_check (values
, 3, 1))
5745 if (!variable_check (values
, 3, false))
5754 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5755 gfc_expr
*to
, gfc_expr
*topos
)
5757 if (!type_check (from
, 0, BT_INTEGER
))
5760 if (!type_check (frompos
, 1, BT_INTEGER
))
5763 if (!type_check (len
, 2, BT_INTEGER
))
5766 if (!same_type_check (from
, 0, to
, 3))
5769 if (!variable_check (to
, 3, false))
5772 if (!type_check (topos
, 4, BT_INTEGER
))
5775 if (!nonnegative_check ("frompos", frompos
))
5778 if (!nonnegative_check ("topos", topos
))
5781 if (!nonnegative_check ("len", len
))
5784 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5787 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5795 gfc_check_random_number (gfc_expr
*harvest
)
5797 if (!type_check (harvest
, 0, BT_REAL
))
5800 if (!variable_check (harvest
, 0, false))
5808 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5810 unsigned int nargs
= 0, seed_size
;
5811 locus
*where
= NULL
;
5812 mpz_t put_size
, get_size
;
5814 /* Keep the number of bytes in sync with master_state in
5815 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5816 part of the state too. */
5817 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5821 if (size
->expr_type
!= EXPR_VARIABLE
5822 || !size
->symtree
->n
.sym
->attr
.optional
)
5825 if (!scalar_check (size
, 0))
5828 if (!type_check (size
, 0, BT_INTEGER
))
5831 if (!variable_check (size
, 0, false))
5834 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5840 if (put
->expr_type
!= EXPR_VARIABLE
5841 || !put
->symtree
->n
.sym
->attr
.optional
)
5844 where
= &put
->where
;
5847 if (!array_check (put
, 1))
5850 if (!rank_check (put
, 1, 1))
5853 if (!type_check (put
, 1, BT_INTEGER
))
5856 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5859 if (gfc_array_size (put
, &put_size
)
5860 && mpz_get_ui (put_size
) < seed_size
)
5861 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5862 "too small (%i/%i)",
5863 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5864 where
, (int) mpz_get_ui (put_size
), seed_size
);
5869 if (get
->expr_type
!= EXPR_VARIABLE
5870 || !get
->symtree
->n
.sym
->attr
.optional
)
5873 where
= &get
->where
;
5876 if (!array_check (get
, 2))
5879 if (!rank_check (get
, 2, 1))
5882 if (!type_check (get
, 2, BT_INTEGER
))
5885 if (!variable_check (get
, 2, false))
5888 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5891 if (gfc_array_size (get
, &get_size
)
5892 && mpz_get_ui (get_size
) < seed_size
)
5893 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5894 "too small (%i/%i)",
5895 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5896 where
, (int) mpz_get_ui (get_size
), seed_size
);
5899 /* RANDOM_SEED may not have more than one non-optional argument. */
5901 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5907 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5911 int num_percent
, nargs
;
5914 if (e
->expr_type
!= EXPR_CONSTANT
)
5917 len
= e
->value
.character
.length
;
5918 if (e
->value
.character
.string
[len
-1] != '\0')
5919 gfc_internal_error ("fe_runtime_error string must be null terminated");
5922 for (i
=0; i
<len
-1; i
++)
5923 if (e
->value
.character
.string
[i
] == '%')
5927 for (; a
; a
= a
->next
)
5930 if (nargs
-1 != num_percent
)
5931 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5932 nargs
, num_percent
++);
5938 gfc_check_second_sub (gfc_expr
*time
)
5940 if (!scalar_check (time
, 0))
5943 if (!type_check (time
, 0, BT_REAL
))
5946 if (!kind_value_check (time
, 0, 4))
5953 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5954 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5955 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5956 count_max are all optional arguments */
5959 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5960 gfc_expr
*count_max
)
5964 if (!scalar_check (count
, 0))
5967 if (!type_check (count
, 0, BT_INTEGER
))
5970 if (count
->ts
.kind
!= gfc_default_integer_kind
5971 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5972 "SYSTEM_CLOCK at %L has non-default kind",
5976 if (!variable_check (count
, 0, false))
5980 if (count_rate
!= NULL
)
5982 if (!scalar_check (count_rate
, 1))
5985 if (!variable_check (count_rate
, 1, false))
5988 if (count_rate
->ts
.type
== BT_REAL
)
5990 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5991 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5996 if (!type_check (count_rate
, 1, BT_INTEGER
))
5999 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6000 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6001 "SYSTEM_CLOCK at %L has non-default kind",
6002 &count_rate
->where
))
6008 if (count_max
!= NULL
)
6010 if (!scalar_check (count_max
, 2))
6013 if (!type_check (count_max
, 2, BT_INTEGER
))
6016 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6017 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6018 "SYSTEM_CLOCK at %L has non-default kind",
6022 if (!variable_check (count_max
, 2, false))
6031 gfc_check_irand (gfc_expr
*x
)
6036 if (!scalar_check (x
, 0))
6039 if (!type_check (x
, 0, BT_INTEGER
))
6042 if (!kind_value_check (x
, 0, 4))
6050 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6052 if (!scalar_check (seconds
, 0))
6054 if (!type_check (seconds
, 0, BT_INTEGER
))
6057 if (!int_or_proc_check (handler
, 1))
6059 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6065 if (!scalar_check (status
, 2))
6067 if (!type_check (status
, 2, BT_INTEGER
))
6069 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6077 gfc_check_rand (gfc_expr
*x
)
6082 if (!scalar_check (x
, 0))
6085 if (!type_check (x
, 0, BT_INTEGER
))
6088 if (!kind_value_check (x
, 0, 4))
6096 gfc_check_srand (gfc_expr
*x
)
6098 if (!scalar_check (x
, 0))
6101 if (!type_check (x
, 0, BT_INTEGER
))
6104 if (!kind_value_check (x
, 0, 4))
6112 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6114 if (!scalar_check (time
, 0))
6116 if (!type_check (time
, 0, BT_INTEGER
))
6119 if (!type_check (result
, 1, BT_CHARACTER
))
6121 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6129 gfc_check_dtime_etime (gfc_expr
*x
)
6131 if (!array_check (x
, 0))
6134 if (!rank_check (x
, 0, 1))
6137 if (!variable_check (x
, 0, false))
6140 if (!type_check (x
, 0, BT_REAL
))
6143 if (!kind_value_check (x
, 0, 4))
6151 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6153 if (!array_check (values
, 0))
6156 if (!rank_check (values
, 0, 1))
6159 if (!variable_check (values
, 0, false))
6162 if (!type_check (values
, 0, BT_REAL
))
6165 if (!kind_value_check (values
, 0, 4))
6168 if (!scalar_check (time
, 1))
6171 if (!type_check (time
, 1, BT_REAL
))
6174 if (!kind_value_check (time
, 1, 4))
6182 gfc_check_fdate_sub (gfc_expr
*date
)
6184 if (!type_check (date
, 0, BT_CHARACTER
))
6186 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6194 gfc_check_gerror (gfc_expr
*msg
)
6196 if (!type_check (msg
, 0, BT_CHARACTER
))
6198 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6206 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6208 if (!type_check (cwd
, 0, BT_CHARACTER
))
6210 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6216 if (!scalar_check (status
, 1))
6219 if (!type_check (status
, 1, BT_INTEGER
))
6227 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6229 if (!type_check (pos
, 0, BT_INTEGER
))
6232 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6234 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6235 "not wider than the default kind (%d)",
6236 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6237 &pos
->where
, gfc_default_integer_kind
);
6241 if (!type_check (value
, 1, BT_CHARACTER
))
6243 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6251 gfc_check_getlog (gfc_expr
*msg
)
6253 if (!type_check (msg
, 0, BT_CHARACTER
))
6255 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6263 gfc_check_exit (gfc_expr
*status
)
6268 if (!type_check (status
, 0, BT_INTEGER
))
6271 if (!scalar_check (status
, 0))
6279 gfc_check_flush (gfc_expr
*unit
)
6284 if (!type_check (unit
, 0, BT_INTEGER
))
6287 if (!scalar_check (unit
, 0))
6295 gfc_check_free (gfc_expr
*i
)
6297 if (!type_check (i
, 0, BT_INTEGER
))
6300 if (!scalar_check (i
, 0))
6308 gfc_check_hostnm (gfc_expr
*name
)
6310 if (!type_check (name
, 0, BT_CHARACTER
))
6312 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6320 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6322 if (!type_check (name
, 0, BT_CHARACTER
))
6324 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6330 if (!scalar_check (status
, 1))
6333 if (!type_check (status
, 1, BT_INTEGER
))
6341 gfc_check_itime_idate (gfc_expr
*values
)
6343 if (!array_check (values
, 0))
6346 if (!rank_check (values
, 0, 1))
6349 if (!variable_check (values
, 0, false))
6352 if (!type_check (values
, 0, BT_INTEGER
))
6355 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6363 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6365 if (!type_check (time
, 0, BT_INTEGER
))
6368 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6371 if (!scalar_check (time
, 0))
6374 if (!array_check (values
, 1))
6377 if (!rank_check (values
, 1, 1))
6380 if (!variable_check (values
, 1, false))
6383 if (!type_check (values
, 1, BT_INTEGER
))
6386 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6394 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6396 if (!scalar_check (unit
, 0))
6399 if (!type_check (unit
, 0, BT_INTEGER
))
6402 if (!type_check (name
, 1, BT_CHARACTER
))
6404 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6412 gfc_check_isatty (gfc_expr
*unit
)
6417 if (!type_check (unit
, 0, BT_INTEGER
))
6420 if (!scalar_check (unit
, 0))
6428 gfc_check_isnan (gfc_expr
*x
)
6430 if (!type_check (x
, 0, BT_REAL
))
6438 gfc_check_perror (gfc_expr
*string
)
6440 if (!type_check (string
, 0, BT_CHARACTER
))
6442 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6450 gfc_check_umask (gfc_expr
*mask
)
6452 if (!type_check (mask
, 0, BT_INTEGER
))
6455 if (!scalar_check (mask
, 0))
6463 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6465 if (!type_check (mask
, 0, BT_INTEGER
))
6468 if (!scalar_check (mask
, 0))
6474 if (!scalar_check (old
, 1))
6477 if (!type_check (old
, 1, BT_INTEGER
))
6485 gfc_check_unlink (gfc_expr
*name
)
6487 if (!type_check (name
, 0, BT_CHARACTER
))
6489 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6497 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6499 if (!type_check (name
, 0, BT_CHARACTER
))
6501 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6507 if (!scalar_check (status
, 1))
6510 if (!type_check (status
, 1, BT_INTEGER
))
6518 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6520 if (!scalar_check (number
, 0))
6522 if (!type_check (number
, 0, BT_INTEGER
))
6525 if (!int_or_proc_check (handler
, 1))
6527 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6535 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6537 if (!scalar_check (number
, 0))
6539 if (!type_check (number
, 0, BT_INTEGER
))
6542 if (!int_or_proc_check (handler
, 1))
6544 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6550 if (!type_check (status
, 2, BT_INTEGER
))
6552 if (!scalar_check (status
, 2))
6560 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6562 if (!type_check (cmd
, 0, BT_CHARACTER
))
6564 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6567 if (!scalar_check (status
, 1))
6570 if (!type_check (status
, 1, BT_INTEGER
))
6573 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6580 /* This is used for the GNU intrinsics AND, OR and XOR. */
6582 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6584 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6586 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6587 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6588 gfc_current_intrinsic
, &i
->where
);
6592 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6594 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6595 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6596 gfc_current_intrinsic
, &j
->where
);
6600 if (i
->ts
.type
!= j
->ts
.type
)
6602 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6603 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6604 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6609 if (!scalar_check (i
, 0))
6612 if (!scalar_check (j
, 1))
6620 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6623 if (a
->expr_type
== EXPR_NULL
)
6625 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6626 "argument to STORAGE_SIZE, because it returns a "
6627 "disassociated pointer", &a
->where
);
6631 if (a
->ts
.type
== BT_ASSUMED
)
6633 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6634 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6639 if (a
->ts
.type
== BT_PROCEDURE
)
6641 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6642 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6643 gfc_current_intrinsic
, &a
->where
);
6650 if (!type_check (kind
, 1, BT_INTEGER
))
6653 if (!scalar_check (kind
, 1))
6656 if (kind
->expr_type
!= EXPR_CONSTANT
)
6658 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6659 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,