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))
3312 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3313 ap
->next
->next
->next
->next
->expr
= b
;
3316 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3317 && ap
->next
->name
== NULL
)
3321 ap
->next
->expr
= NULL
;
3322 ap
->next
->next
->expr
= m
;
3325 if (!dim_check (d
, 1, false))
3328 if (!dim_rank_check (d
, a
, 0))
3331 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3335 && !gfc_check_conformance (a
, m
,
3336 "arguments '%s' and '%s' for intrinsic %s",
3337 gfc_current_intrinsic_arg
[0]->name
,
3338 gfc_current_intrinsic_arg
[2]->name
,
3339 gfc_current_intrinsic
))
3342 if (!kind_check (k
, 1, BT_INTEGER
))
3349 /* Similar to minloc/maxloc, the argument list might need to be
3350 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3351 difference is that MINLOC/MAXLOC take an additional KIND argument.
3352 The possibilities are:
3358 NULL MASK minval(array, mask=m)
3361 I.e. in the case of minval(array,mask), mask will be in the second
3362 position of the argument list and we'll have to fix that up. */
3365 check_reduction (gfc_actual_arglist
*ap
)
3367 gfc_expr
*a
, *m
, *d
;
3371 m
= ap
->next
->next
->expr
;
3373 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3374 && ap
->next
->name
== NULL
)
3378 ap
->next
->expr
= NULL
;
3379 ap
->next
->next
->expr
= m
;
3382 if (!dim_check (d
, 1, false))
3385 if (!dim_rank_check (d
, a
, 0))
3388 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3392 && !gfc_check_conformance (a
, m
,
3393 "arguments '%s' and '%s' for intrinsic %s",
3394 gfc_current_intrinsic_arg
[0]->name
,
3395 gfc_current_intrinsic_arg
[2]->name
,
3396 gfc_current_intrinsic
))
3404 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3406 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
3407 || !array_check (ap
->expr
, 0))
3410 return check_reduction (ap
);
3415 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3417 if (!numeric_check (ap
->expr
, 0)
3418 || !array_check (ap
->expr
, 0))
3421 return check_reduction (ap
);
3425 /* For IANY, IALL and IPARITY. */
3428 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3432 if (!type_check (i
, 0, BT_INTEGER
))
3435 if (!nonnegative_check ("I", i
))
3438 if (!kind_check (kind
, 1, BT_INTEGER
))
3442 gfc_extract_int (kind
, &k
);
3444 k
= gfc_default_integer_kind
;
3446 if (!less_than_bitsizekind ("I", i
, k
))
3454 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3456 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3458 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3459 gfc_current_intrinsic_arg
[0]->name
,
3460 gfc_current_intrinsic
, &ap
->expr
->where
);
3464 if (!array_check (ap
->expr
, 0))
3467 return check_reduction (ap
);
3472 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3474 if (!same_type_check (tsource
, 0, fsource
, 1))
3477 if (!type_check (mask
, 2, BT_LOGICAL
))
3480 if (tsource
->ts
.type
== BT_CHARACTER
)
3481 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3488 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3490 if (!type_check (i
, 0, BT_INTEGER
))
3493 if (!type_check (j
, 1, BT_INTEGER
))
3496 if (!type_check (mask
, 2, BT_INTEGER
))
3499 if (!same_type_check (i
, 0, j
, 1))
3502 if (!same_type_check (i
, 0, mask
, 2))
3510 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3512 if (!variable_check (from
, 0, false))
3514 if (!allocatable_check (from
, 0))
3516 if (gfc_is_coindexed (from
))
3518 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3519 "coindexed", &from
->where
);
3523 if (!variable_check (to
, 1, false))
3525 if (!allocatable_check (to
, 1))
3527 if (gfc_is_coindexed (to
))
3529 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3530 "coindexed", &to
->where
);
3534 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3536 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3537 "polymorphic if FROM is polymorphic",
3542 if (!same_type_check (to
, 1, from
, 0))
3545 if (to
->rank
!= from
->rank
)
3547 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3548 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3553 /* IR F08/0040; cf. 12-006A. */
3554 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3556 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3557 "must have the same corank %d/%d", &to
->where
,
3558 gfc_get_corank (from
), gfc_get_corank (to
));
3562 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3563 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3564 and cmp2 are allocatable. After the allocation is transferred,
3565 the 'to' chain is broken by the nullification of the 'from'. A bit
3566 of reflection reveals that this can only occur for derived types
3567 with recursive allocatable components. */
3568 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3569 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3571 gfc_ref
*to_ref
, *from_ref
;
3573 from_ref
= from
->ref
;
3574 bool aliasing
= true;
3576 for (; from_ref
&& to_ref
;
3577 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3579 if (to_ref
->type
!= from
->ref
->type
)
3581 else if (to_ref
->type
== REF_ARRAY
3582 && to_ref
->u
.ar
.type
!= AR_FULL
3583 && from_ref
->u
.ar
.type
!= AR_FULL
)
3584 /* Play safe; assume sections and elements are different. */
3586 else if (to_ref
->type
== REF_COMPONENT
3587 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3596 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3597 "restrictions (F2003 12.4.1.7)", &to
->where
);
3602 /* CLASS arguments: Make sure the vtab of from is present. */
3603 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3604 gfc_find_vtab (&from
->ts
);
3611 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3613 if (!type_check (x
, 0, BT_REAL
))
3616 if (!type_check (s
, 1, BT_REAL
))
3619 if (s
->expr_type
== EXPR_CONSTANT
)
3621 if (mpfr_sgn (s
->value
.real
) == 0)
3623 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3634 gfc_check_new_line (gfc_expr
*a
)
3636 if (!type_check (a
, 0, BT_CHARACTER
))
3644 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3646 if (!type_check (array
, 0, BT_REAL
))
3649 if (!array_check (array
, 0))
3652 if (!dim_rank_check (dim
, array
, false))
3659 gfc_check_null (gfc_expr
*mold
)
3661 symbol_attribute attr
;
3666 if (!variable_check (mold
, 0, true))
3669 attr
= gfc_variable_attr (mold
, NULL
);
3671 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3673 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3674 "ALLOCATABLE or procedure pointer",
3675 gfc_current_intrinsic_arg
[0]->name
,
3676 gfc_current_intrinsic
, &mold
->where
);
3680 if (attr
.allocatable
3681 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3682 "allocatable MOLD at %L", &mold
->where
))
3686 if (gfc_is_coindexed (mold
))
3688 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3689 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3690 gfc_current_intrinsic
, &mold
->where
);
3699 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3701 if (!array_check (array
, 0))
3704 if (!type_check (mask
, 1, BT_LOGICAL
))
3707 if (!gfc_check_conformance (array
, mask
,
3708 "arguments '%s' and '%s' for intrinsic '%s'",
3709 gfc_current_intrinsic_arg
[0]->name
,
3710 gfc_current_intrinsic_arg
[1]->name
,
3711 gfc_current_intrinsic
))
3716 mpz_t array_size
, vector_size
;
3717 bool have_array_size
, have_vector_size
;
3719 if (!same_type_check (array
, 0, vector
, 2))
3722 if (!rank_check (vector
, 2, 1))
3725 /* VECTOR requires at least as many elements as MASK
3726 has .TRUE. values. */
3727 have_array_size
= gfc_array_size(array
, &array_size
);
3728 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3730 if (have_vector_size
3731 && (mask
->expr_type
== EXPR_ARRAY
3732 || (mask
->expr_type
== EXPR_CONSTANT
3733 && have_array_size
)))
3735 int mask_true_values
= 0;
3737 if (mask
->expr_type
== EXPR_ARRAY
)
3739 gfc_constructor
*mask_ctor
;
3740 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3743 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3745 mask_true_values
= 0;
3749 if (mask_ctor
->expr
->value
.logical
)
3752 mask_ctor
= gfc_constructor_next (mask_ctor
);
3755 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3756 mask_true_values
= mpz_get_si (array_size
);
3758 if (mpz_get_si (vector_size
) < mask_true_values
)
3760 gfc_error ("%qs argument of %qs intrinsic at %L must "
3761 "provide at least as many elements as there "
3762 "are .TRUE. values in %qs (%ld/%d)",
3763 gfc_current_intrinsic_arg
[2]->name
,
3764 gfc_current_intrinsic
, &vector
->where
,
3765 gfc_current_intrinsic_arg
[1]->name
,
3766 mpz_get_si (vector_size
), mask_true_values
);
3771 if (have_array_size
)
3772 mpz_clear (array_size
);
3773 if (have_vector_size
)
3774 mpz_clear (vector_size
);
3782 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3784 if (!type_check (mask
, 0, BT_LOGICAL
))
3787 if (!array_check (mask
, 0))
3790 if (!dim_rank_check (dim
, mask
, false))
3798 gfc_check_precision (gfc_expr
*x
)
3800 if (!real_or_complex_check (x
, 0))
3808 gfc_check_present (gfc_expr
*a
)
3812 if (!variable_check (a
, 0, true))
3815 sym
= a
->symtree
->n
.sym
;
3816 if (!sym
->attr
.dummy
)
3818 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3819 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3820 gfc_current_intrinsic
, &a
->where
);
3824 if (!sym
->attr
.optional
)
3826 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3827 "an OPTIONAL dummy variable",
3828 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3833 /* 13.14.82 PRESENT(A)
3835 Argument. A shall be the name of an optional dummy argument that is
3836 accessible in the subprogram in which the PRESENT function reference
3840 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3841 && (a
->ref
->u
.ar
.type
== AR_FULL
3842 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3843 && a
->ref
->u
.ar
.as
->rank
== 0))))
3845 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3846 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3847 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3856 gfc_check_radix (gfc_expr
*x
)
3858 if (!int_or_real_check (x
, 0))
3866 gfc_check_range (gfc_expr
*x
)
3868 if (!numeric_check (x
, 0))
3876 gfc_check_rank (gfc_expr
*a
)
3878 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3879 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3881 bool is_variable
= true;
3883 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3884 if (a
->expr_type
== EXPR_FUNCTION
)
3885 is_variable
= a
->value
.function
.esym
3886 ? a
->value
.function
.esym
->result
->attr
.pointer
3887 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3889 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3890 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3893 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3894 "object", &a
->where
);
3902 /* real, float, sngl. */
3904 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3906 if (!numeric_check (a
, 0))
3909 if (!kind_check (kind
, 1, BT_REAL
))
3917 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3919 if (!type_check (path1
, 0, BT_CHARACTER
))
3921 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3924 if (!type_check (path2
, 1, BT_CHARACTER
))
3926 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3934 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3936 if (!type_check (path1
, 0, BT_CHARACTER
))
3938 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3941 if (!type_check (path2
, 1, BT_CHARACTER
))
3943 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3949 if (!type_check (status
, 2, BT_INTEGER
))
3952 if (!scalar_check (status
, 2))
3960 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3962 if (!type_check (x
, 0, BT_CHARACTER
))
3965 if (!scalar_check (x
, 0))
3968 if (!type_check (y
, 0, BT_INTEGER
))
3971 if (!scalar_check (y
, 1))
3979 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3980 gfc_expr
*pad
, gfc_expr
*order
)
3986 if (!array_check (source
, 0))
3989 if (!rank_check (shape
, 1, 1))
3992 if (!type_check (shape
, 1, BT_INTEGER
))
3995 if (!gfc_array_size (shape
, &size
))
3997 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3998 "array of constant size", &shape
->where
);
4002 shape_size
= mpz_get_ui (size
);
4005 if (shape_size
<= 0)
4007 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4008 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4012 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4014 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4015 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4018 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
4022 for (i
= 0; i
< shape_size
; ++i
)
4024 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4025 if (e
->expr_type
!= EXPR_CONSTANT
)
4028 gfc_extract_int (e
, &extent
);
4031 gfc_error ("%qs argument of %qs intrinsic at %L has "
4032 "negative element (%d)",
4033 gfc_current_intrinsic_arg
[1]->name
,
4034 gfc_current_intrinsic
, &e
->where
, extent
);
4039 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4040 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4041 && shape
->ref
->u
.ar
.as
4042 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4043 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4044 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4045 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4046 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4051 v
= shape
->symtree
->n
.sym
->value
;
4053 for (i
= 0; i
< shape_size
; i
++)
4055 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4059 gfc_extract_int (e
, &extent
);
4063 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4064 "cannot be negative", i
+ 1, &shape
->where
);
4072 if (!same_type_check (source
, 0, pad
, 2))
4075 if (!array_check (pad
, 2))
4081 if (!array_check (order
, 3))
4084 if (!type_check (order
, 3, BT_INTEGER
))
4087 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4089 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4092 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4095 gfc_array_size (order
, &size
);
4096 order_size
= mpz_get_ui (size
);
4099 if (order_size
!= shape_size
)
4101 gfc_error ("%qs argument of %qs intrinsic at %L "
4102 "has wrong number of elements (%d/%d)",
4103 gfc_current_intrinsic_arg
[3]->name
,
4104 gfc_current_intrinsic
, &order
->where
,
4105 order_size
, shape_size
);
4109 for (i
= 1; i
<= order_size
; ++i
)
4111 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4112 if (e
->expr_type
!= EXPR_CONSTANT
)
4115 gfc_extract_int (e
, &dim
);
4117 if (dim
< 1 || dim
> order_size
)
4119 gfc_error ("%qs argument of %qs intrinsic at %L "
4120 "has out-of-range dimension (%d)",
4121 gfc_current_intrinsic_arg
[3]->name
,
4122 gfc_current_intrinsic
, &e
->where
, dim
);
4126 if (perm
[dim
-1] != 0)
4128 gfc_error ("%qs argument of %qs intrinsic at %L has "
4129 "invalid permutation of dimensions (dimension "
4131 gfc_current_intrinsic_arg
[3]->name
,
4132 gfc_current_intrinsic
, &e
->where
, dim
);
4141 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4142 && gfc_is_constant_expr (shape
)
4143 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4144 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4146 /* Check the match in size between source and destination. */
4147 if (gfc_array_size (source
, &nelems
))
4153 mpz_init_set_ui (size
, 1);
4154 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4155 c
; c
= gfc_constructor_next (c
))
4156 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4158 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4164 gfc_error ("Without padding, there are not enough elements "
4165 "in the intrinsic RESHAPE source at %L to match "
4166 "the shape", &source
->where
);
4177 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4179 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4181 gfc_error ("%qs argument of %qs intrinsic at %L "
4182 "cannot be of type %s",
4183 gfc_current_intrinsic_arg
[0]->name
,
4184 gfc_current_intrinsic
,
4185 &a
->where
, gfc_typename (&a
->ts
));
4189 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4191 gfc_error ("%qs argument of %qs intrinsic at %L "
4192 "must be of an extensible type",
4193 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4198 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4200 gfc_error ("%qs argument of %qs intrinsic at %L "
4201 "cannot be of type %s",
4202 gfc_current_intrinsic_arg
[0]->name
,
4203 gfc_current_intrinsic
,
4204 &b
->where
, gfc_typename (&b
->ts
));
4208 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4210 gfc_error ("%qs argument of %qs intrinsic at %L "
4211 "must be of an extensible type",
4212 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4222 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4224 if (!type_check (x
, 0, BT_REAL
))
4227 if (!type_check (i
, 1, BT_INTEGER
))
4235 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4237 if (!type_check (x
, 0, BT_CHARACTER
))
4240 if (!type_check (y
, 1, BT_CHARACTER
))
4243 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4246 if (!kind_check (kind
, 3, BT_INTEGER
))
4248 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4249 "with KIND argument at %L",
4250 gfc_current_intrinsic
, &kind
->where
))
4253 if (!same_type_check (x
, 0, y
, 1))
4261 gfc_check_secnds (gfc_expr
*r
)
4263 if (!type_check (r
, 0, BT_REAL
))
4266 if (!kind_value_check (r
, 0, 4))
4269 if (!scalar_check (r
, 0))
4277 gfc_check_selected_char_kind (gfc_expr
*name
)
4279 if (!type_check (name
, 0, BT_CHARACTER
))
4282 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4285 if (!scalar_check (name
, 0))
4293 gfc_check_selected_int_kind (gfc_expr
*r
)
4295 if (!type_check (r
, 0, BT_INTEGER
))
4298 if (!scalar_check (r
, 0))
4306 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4308 if (p
== NULL
&& r
== NULL
4309 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4310 " neither %<P%> nor %<R%> argument at %L",
4311 gfc_current_intrinsic_where
))
4316 if (!type_check (p
, 0, BT_INTEGER
))
4319 if (!scalar_check (p
, 0))
4325 if (!type_check (r
, 1, BT_INTEGER
))
4328 if (!scalar_check (r
, 1))
4334 if (!type_check (radix
, 1, BT_INTEGER
))
4337 if (!scalar_check (radix
, 1))
4340 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4341 "RADIX argument at %L", gfc_current_intrinsic
,
4351 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4353 if (!type_check (x
, 0, BT_REAL
))
4356 if (!type_check (i
, 1, BT_INTEGER
))
4364 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4368 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4371 ar
= gfc_find_array_ref (source
);
4373 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4375 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4376 "an assumed size array", &source
->where
);
4380 if (!kind_check (kind
, 1, BT_INTEGER
))
4382 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4383 "with KIND argument at %L",
4384 gfc_current_intrinsic
, &kind
->where
))
4392 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4394 if (!type_check (i
, 0, BT_INTEGER
))
4397 if (!type_check (shift
, 0, BT_INTEGER
))
4400 if (!nonnegative_check ("SHIFT", shift
))
4403 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4411 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4413 if (!int_or_real_check (a
, 0))
4416 if (!same_type_check (a
, 0, b
, 1))
4424 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4426 if (!array_check (array
, 0))
4429 if (!dim_check (dim
, 1, true))
4432 if (!dim_rank_check (dim
, array
, 0))
4435 if (!kind_check (kind
, 2, BT_INTEGER
))
4437 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4438 "with KIND argument at %L",
4439 gfc_current_intrinsic
, &kind
->where
))
4448 gfc_check_sizeof (gfc_expr
*arg
)
4450 if (arg
->ts
.type
== BT_PROCEDURE
)
4452 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4453 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4458 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4459 if (arg
->ts
.type
== BT_ASSUMED
4460 && (arg
->symtree
->n
.sym
->as
== NULL
4461 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4462 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4463 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4465 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4466 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4471 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4472 && arg
->symtree
->n
.sym
->as
!= NULL
4473 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4474 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4476 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4477 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4478 gfc_current_intrinsic
, &arg
->where
);
4486 /* Check whether an expression is interoperable. When returning false,
4487 msg is set to a string telling why the expression is not interoperable,
4488 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4489 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4490 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4491 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4495 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4499 if (expr
->ts
.type
== BT_CLASS
)
4501 *msg
= "Expression is polymorphic";
4505 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4506 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4508 *msg
= "Expression is a noninteroperable derived type";
4512 if (expr
->ts
.type
== BT_PROCEDURE
)
4514 *msg
= "Procedure unexpected as argument";
4518 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4521 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4522 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4524 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4528 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4529 && expr
->ts
.kind
!= 1)
4531 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4535 if (expr
->ts
.type
== BT_CHARACTER
) {
4536 if (expr
->ts
.deferred
)
4538 /* TS 29113 allows deferred-length strings as dummy arguments,
4539 but it is not an interoperable type. */
4540 *msg
= "Expression shall not be a deferred-length string";
4544 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4545 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4546 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4548 if (!c_loc
&& expr
->ts
.u
.cl
4549 && (!expr
->ts
.u
.cl
->length
4550 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4551 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4553 *msg
= "Type shall have a character length of 1";
4558 /* Note: The following checks are about interoperatable variables, Fortran
4559 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4560 is allowed, e.g. assumed-shape arrays with TS 29113. */
4562 if (gfc_is_coarray (expr
))
4564 *msg
= "Coarrays are not interoperable";
4568 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4570 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4571 if (ar
->type
!= AR_FULL
)
4573 *msg
= "Only whole-arrays are interoperable";
4576 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4577 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4579 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4589 gfc_check_c_sizeof (gfc_expr
*arg
)
4593 if (!is_c_interoperable (arg
, &msg
, false, false))
4595 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4596 "interoperable data entity: %s",
4597 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4602 if (arg
->ts
.type
== BT_ASSUMED
)
4604 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4606 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4611 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4612 && arg
->symtree
->n
.sym
->as
!= NULL
4613 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4614 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4616 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4617 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4618 gfc_current_intrinsic
, &arg
->where
);
4627 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4629 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4630 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4631 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4632 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4634 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4635 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4639 if (!scalar_check (c_ptr_1
, 0))
4643 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4644 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4645 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4646 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4648 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4649 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4650 gfc_typename (&c_ptr_1
->ts
),
4651 gfc_typename (&c_ptr_2
->ts
));
4655 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4663 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4665 symbol_attribute attr
;
4668 if (cptr
->ts
.type
!= BT_DERIVED
4669 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4670 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4672 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4673 "type TYPE(C_PTR)", &cptr
->where
);
4677 if (!scalar_check (cptr
, 0))
4680 attr
= gfc_expr_attr (fptr
);
4684 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4689 if (fptr
->ts
.type
== BT_CLASS
)
4691 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4696 if (gfc_is_coindexed (fptr
))
4698 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4699 "coindexed", &fptr
->where
);
4703 if (fptr
->rank
== 0 && shape
)
4705 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4706 "FPTR", &fptr
->where
);
4709 else if (fptr
->rank
&& !shape
)
4711 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4712 "FPTR at %L", &fptr
->where
);
4716 if (shape
&& !rank_check (shape
, 2, 1))
4719 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4725 if (gfc_array_size (shape
, &size
))
4727 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4730 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4731 "size as the RANK of FPTR", &shape
->where
);
4738 if (fptr
->ts
.type
== BT_CLASS
)
4740 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4744 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
4745 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4746 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4753 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4755 symbol_attribute attr
;
4757 if (cptr
->ts
.type
!= BT_DERIVED
4758 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4759 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4761 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4762 "type TYPE(C_FUNPTR)", &cptr
->where
);
4766 if (!scalar_check (cptr
, 0))
4769 attr
= gfc_expr_attr (fptr
);
4771 if (!attr
.proc_pointer
)
4773 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4774 "pointer", &fptr
->where
);
4778 if (gfc_is_coindexed (fptr
))
4780 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4781 "coindexed", &fptr
->where
);
4785 if (!attr
.is_bind_c
)
4786 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4787 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4794 gfc_check_c_funloc (gfc_expr
*x
)
4796 symbol_attribute attr
;
4798 if (gfc_is_coindexed (x
))
4800 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4801 "coindexed", &x
->where
);
4805 attr
= gfc_expr_attr (x
);
4807 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4808 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4810 gfc_namespace
*ns
= gfc_current_ns
;
4812 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4813 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4815 gfc_error ("Function result %qs at %L is invalid as X argument "
4816 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4821 if (attr
.flavor
!= FL_PROCEDURE
)
4823 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4824 "or a procedure pointer", &x
->where
);
4828 if (!attr
.is_bind_c
)
4829 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4830 "at %L to C_FUNLOC", &x
->where
);
4836 gfc_check_c_loc (gfc_expr
*x
)
4838 symbol_attribute attr
;
4841 if (gfc_is_coindexed (x
))
4843 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4847 if (x
->ts
.type
== BT_CLASS
)
4849 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4854 attr
= gfc_expr_attr (x
);
4857 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4858 || attr
.flavor
== FL_PARAMETER
))
4860 gfc_error ("Argument X at %L to C_LOC shall have either "
4861 "the POINTER or the TARGET attribute", &x
->where
);
4865 if (x
->ts
.type
== BT_CHARACTER
4866 && gfc_var_strlen (x
) == 0)
4868 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4869 "string", &x
->where
);
4873 if (!is_c_interoperable (x
, &msg
, true, false))
4875 if (x
->ts
.type
== BT_CLASS
)
4877 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4883 && !gfc_notify_std (GFC_STD_F2008_TS
,
4884 "Noninteroperable array at %L as"
4885 " argument to C_LOC: %s", &x
->where
, msg
))
4888 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4890 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4892 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4893 && !attr
.allocatable
4894 && !gfc_notify_std (GFC_STD_F2008
,
4895 "Array of interoperable type at %L "
4896 "to C_LOC which is nonallocatable and neither "
4897 "assumed size nor explicit size", &x
->where
))
4899 else if (ar
->type
!= AR_FULL
4900 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4901 "to C_LOC", &x
->where
))
4910 gfc_check_sleep_sub (gfc_expr
*seconds
)
4912 if (!type_check (seconds
, 0, BT_INTEGER
))
4915 if (!scalar_check (seconds
, 0))
4922 gfc_check_sngl (gfc_expr
*a
)
4924 if (!type_check (a
, 0, BT_REAL
))
4927 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4928 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4929 "REAL argument to %s intrinsic at %L",
4930 gfc_current_intrinsic
, &a
->where
))
4937 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4939 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4941 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4942 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4943 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4951 if (!dim_check (dim
, 1, false))
4954 /* dim_rank_check() does not apply here. */
4956 && dim
->expr_type
== EXPR_CONSTANT
4957 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4958 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4960 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4961 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4962 gfc_current_intrinsic
, &dim
->where
);
4966 if (!type_check (ncopies
, 2, BT_INTEGER
))
4969 if (!scalar_check (ncopies
, 2))
4976 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4980 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4982 if (!type_check (unit
, 0, BT_INTEGER
))
4985 if (!scalar_check (unit
, 0))
4988 if (!type_check (c
, 1, BT_CHARACTER
))
4990 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4996 if (!type_check (status
, 2, BT_INTEGER
)
4997 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4998 || !scalar_check (status
, 2))
5006 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5008 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5013 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5015 if (!type_check (c
, 0, BT_CHARACTER
))
5017 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5023 if (!type_check (status
, 1, BT_INTEGER
)
5024 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5025 || !scalar_check (status
, 1))
5033 gfc_check_fgetput (gfc_expr
*c
)
5035 return gfc_check_fgetput_sub (c
, NULL
);
5040 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5042 if (!type_check (unit
, 0, BT_INTEGER
))
5045 if (!scalar_check (unit
, 0))
5048 if (!type_check (offset
, 1, BT_INTEGER
))
5051 if (!scalar_check (offset
, 1))
5054 if (!type_check (whence
, 2, BT_INTEGER
))
5057 if (!scalar_check (whence
, 2))
5063 if (!type_check (status
, 3, BT_INTEGER
))
5066 if (!kind_value_check (status
, 3, 4))
5069 if (!scalar_check (status
, 3))
5078 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5080 if (!type_check (unit
, 0, BT_INTEGER
))
5083 if (!scalar_check (unit
, 0))
5086 if (!type_check (array
, 1, BT_INTEGER
)
5087 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5090 if (!array_check (array
, 1))
5098 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5100 if (!type_check (unit
, 0, BT_INTEGER
))
5103 if (!scalar_check (unit
, 0))
5106 if (!type_check (array
, 1, BT_INTEGER
)
5107 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5110 if (!array_check (array
, 1))
5116 if (!type_check (status
, 2, BT_INTEGER
)
5117 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5120 if (!scalar_check (status
, 2))
5128 gfc_check_ftell (gfc_expr
*unit
)
5130 if (!type_check (unit
, 0, BT_INTEGER
))
5133 if (!scalar_check (unit
, 0))
5141 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5143 if (!type_check (unit
, 0, BT_INTEGER
))
5146 if (!scalar_check (unit
, 0))
5149 if (!type_check (offset
, 1, BT_INTEGER
))
5152 if (!scalar_check (offset
, 1))
5160 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5162 if (!type_check (name
, 0, BT_CHARACTER
))
5164 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5167 if (!type_check (array
, 1, BT_INTEGER
)
5168 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5171 if (!array_check (array
, 1))
5179 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5181 if (!type_check (name
, 0, BT_CHARACTER
))
5183 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5186 if (!type_check (array
, 1, BT_INTEGER
)
5187 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5190 if (!array_check (array
, 1))
5196 if (!type_check (status
, 2, BT_INTEGER
)
5197 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5200 if (!scalar_check (status
, 2))
5208 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5212 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5214 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5218 if (!coarray_check (coarray
, 0))
5223 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5224 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5228 if (gfc_array_size (sub
, &nelems
))
5230 int corank
= gfc_get_corank (coarray
);
5232 if (mpz_cmp_ui (nelems
, corank
) != 0)
5234 gfc_error ("The number of array elements of the SUB argument to "
5235 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5236 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5248 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5250 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5252 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5258 if (!type_check (distance
, 0, BT_INTEGER
))
5261 if (!nonnegative_check ("DISTANCE", distance
))
5264 if (!scalar_check (distance
, 0))
5267 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5268 "NUM_IMAGES at %L", &distance
->where
))
5274 if (!type_check (failed
, 1, BT_LOGICAL
))
5277 if (!scalar_check (failed
, 1))
5280 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5281 "NUM_IMAGES at %L", &failed
->where
))
5290 gfc_check_team_number (gfc_expr
*team
)
5292 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5294 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5300 if (team
->ts
.type
!= BT_DERIVED
5301 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
5302 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
5304 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
5305 "shall be of type TEAM_TYPE", &team
->where
);
5317 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5319 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5321 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5325 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5328 if (dim
!= NULL
&& coarray
== NULL
)
5330 gfc_error ("DIM argument without COARRAY argument not allowed for "
5331 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5335 if (distance
&& (coarray
|| dim
))
5337 gfc_error ("The DISTANCE argument may not be specified together with the "
5338 "COARRAY or DIM argument in intrinsic at %L",
5343 /* Assume that we have "this_image (distance)". */
5344 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5348 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5357 if (!type_check (distance
, 2, BT_INTEGER
))
5360 if (!nonnegative_check ("DISTANCE", distance
))
5363 if (!scalar_check (distance
, 2))
5366 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5367 "THIS_IMAGE at %L", &distance
->where
))
5373 if (!coarray_check (coarray
, 0))
5378 if (!dim_check (dim
, 1, false))
5381 if (!dim_corank_check (dim
, coarray
))
5388 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5389 by gfc_simplify_transfer. Return false if we cannot do so. */
5392 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5393 size_t *source_size
, size_t *result_size
,
5394 size_t *result_length_p
)
5396 size_t result_elt_size
;
5398 if (source
->expr_type
== EXPR_FUNCTION
)
5401 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5404 /* Calculate the size of the source. */
5405 *source_size
= gfc_target_expr_size (source
);
5406 if (*source_size
== 0)
5409 /* Determine the size of the element. */
5410 result_elt_size
= gfc_element_size (mold
);
5411 if (result_elt_size
== 0)
5414 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5419 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5422 result_length
= *source_size
/ result_elt_size
;
5423 if (result_length
* result_elt_size
< *source_size
)
5427 *result_size
= result_length
* result_elt_size
;
5428 if (result_length_p
)
5429 *result_length_p
= result_length
;
5432 *result_size
= result_elt_size
;
5439 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5444 if (mold
->ts
.type
== BT_HOLLERITH
)
5446 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5447 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5453 if (!type_check (size
, 2, BT_INTEGER
))
5456 if (!scalar_check (size
, 2))
5459 if (!nonoptional_check (size
, 2))
5463 if (!warn_surprising
)
5466 /* If we can't calculate the sizes, we cannot check any more.
5467 Return true for that case. */
5469 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5470 &result_size
, NULL
))
5473 if (source_size
< result_size
)
5474 gfc_warning (OPT_Wsurprising
,
5475 "Intrinsic TRANSFER at %L has partly undefined result: "
5476 "source size %ld < result size %ld", &source
->where
,
5477 (long) source_size
, (long) result_size
);
5484 gfc_check_transpose (gfc_expr
*matrix
)
5486 if (!rank_check (matrix
, 0, 2))
5494 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5496 if (!array_check (array
, 0))
5499 if (!dim_check (dim
, 1, false))
5502 if (!dim_rank_check (dim
, array
, 0))
5505 if (!kind_check (kind
, 2, BT_INTEGER
))
5507 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5508 "with KIND argument at %L",
5509 gfc_current_intrinsic
, &kind
->where
))
5517 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5519 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5521 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5525 if (!coarray_check (coarray
, 0))
5530 if (!dim_check (dim
, 1, false))
5533 if (!dim_corank_check (dim
, coarray
))
5537 if (!kind_check (kind
, 2, BT_INTEGER
))
5545 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5549 if (!rank_check (vector
, 0, 1))
5552 if (!array_check (mask
, 1))
5555 if (!type_check (mask
, 1, BT_LOGICAL
))
5558 if (!same_type_check (vector
, 0, field
, 2))
5561 if (mask
->expr_type
== EXPR_ARRAY
5562 && gfc_array_size (vector
, &vector_size
))
5564 int mask_true_count
= 0;
5565 gfc_constructor
*mask_ctor
;
5566 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5569 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5571 mask_true_count
= 0;
5575 if (mask_ctor
->expr
->value
.logical
)
5578 mask_ctor
= gfc_constructor_next (mask_ctor
);
5581 if (mpz_get_si (vector_size
) < mask_true_count
)
5583 gfc_error ("%qs argument of %qs intrinsic at %L must "
5584 "provide at least as many elements as there "
5585 "are .TRUE. values in %qs (%ld/%d)",
5586 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5587 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5588 mpz_get_si (vector_size
), mask_true_count
);
5592 mpz_clear (vector_size
);
5595 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5597 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5598 "the same rank as %qs or be a scalar",
5599 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5600 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5604 if (mask
->rank
== field
->rank
)
5607 for (i
= 0; i
< field
->rank
; i
++)
5608 if (! identical_dimen_shape (mask
, i
, field
, i
))
5610 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5611 "must have identical shape.",
5612 gfc_current_intrinsic_arg
[2]->name
,
5613 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5623 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5625 if (!type_check (x
, 0, BT_CHARACTER
))
5628 if (!same_type_check (x
, 0, y
, 1))
5631 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5634 if (!kind_check (kind
, 3, BT_INTEGER
))
5636 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5637 "with KIND argument at %L",
5638 gfc_current_intrinsic
, &kind
->where
))
5646 gfc_check_trim (gfc_expr
*x
)
5648 if (!type_check (x
, 0, BT_CHARACTER
))
5651 if (!scalar_check (x
, 0))
5659 gfc_check_ttynam (gfc_expr
*unit
)
5661 if (!scalar_check (unit
, 0))
5664 if (!type_check (unit
, 0, BT_INTEGER
))
5671 /************* Check functions for intrinsic subroutines *************/
5674 gfc_check_cpu_time (gfc_expr
*time
)
5676 if (!scalar_check (time
, 0))
5679 if (!type_check (time
, 0, BT_REAL
))
5682 if (!variable_check (time
, 0, false))
5690 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5691 gfc_expr
*zone
, gfc_expr
*values
)
5695 if (!type_check (date
, 0, BT_CHARACTER
))
5697 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5699 if (!scalar_check (date
, 0))
5701 if (!variable_check (date
, 0, false))
5707 if (!type_check (time
, 1, BT_CHARACTER
))
5709 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5711 if (!scalar_check (time
, 1))
5713 if (!variable_check (time
, 1, false))
5719 if (!type_check (zone
, 2, BT_CHARACTER
))
5721 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5723 if (!scalar_check (zone
, 2))
5725 if (!variable_check (zone
, 2, false))
5731 if (!type_check (values
, 3, BT_INTEGER
))
5733 if (!array_check (values
, 3))
5735 if (!rank_check (values
, 3, 1))
5737 if (!variable_check (values
, 3, false))
5746 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5747 gfc_expr
*to
, gfc_expr
*topos
)
5749 if (!type_check (from
, 0, BT_INTEGER
))
5752 if (!type_check (frompos
, 1, BT_INTEGER
))
5755 if (!type_check (len
, 2, BT_INTEGER
))
5758 if (!same_type_check (from
, 0, to
, 3))
5761 if (!variable_check (to
, 3, false))
5764 if (!type_check (topos
, 4, BT_INTEGER
))
5767 if (!nonnegative_check ("frompos", frompos
))
5770 if (!nonnegative_check ("topos", topos
))
5773 if (!nonnegative_check ("len", len
))
5776 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5779 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5787 gfc_check_random_number (gfc_expr
*harvest
)
5789 if (!type_check (harvest
, 0, BT_REAL
))
5792 if (!variable_check (harvest
, 0, false))
5800 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5802 unsigned int nargs
= 0, seed_size
;
5803 locus
*where
= NULL
;
5804 mpz_t put_size
, get_size
;
5806 /* Keep the number of bytes in sync with master_state in
5807 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5808 part of the state too. */
5809 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5813 if (size
->expr_type
!= EXPR_VARIABLE
5814 || !size
->symtree
->n
.sym
->attr
.optional
)
5817 if (!scalar_check (size
, 0))
5820 if (!type_check (size
, 0, BT_INTEGER
))
5823 if (!variable_check (size
, 0, false))
5826 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5832 if (put
->expr_type
!= EXPR_VARIABLE
5833 || !put
->symtree
->n
.sym
->attr
.optional
)
5836 where
= &put
->where
;
5839 if (!array_check (put
, 1))
5842 if (!rank_check (put
, 1, 1))
5845 if (!type_check (put
, 1, BT_INTEGER
))
5848 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5851 if (gfc_array_size (put
, &put_size
)
5852 && mpz_get_ui (put_size
) < seed_size
)
5853 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5854 "too small (%i/%i)",
5855 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5856 where
, (int) mpz_get_ui (put_size
), seed_size
);
5861 if (get
->expr_type
!= EXPR_VARIABLE
5862 || !get
->symtree
->n
.sym
->attr
.optional
)
5865 where
= &get
->where
;
5868 if (!array_check (get
, 2))
5871 if (!rank_check (get
, 2, 1))
5874 if (!type_check (get
, 2, BT_INTEGER
))
5877 if (!variable_check (get
, 2, false))
5880 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5883 if (gfc_array_size (get
, &get_size
)
5884 && mpz_get_ui (get_size
) < seed_size
)
5885 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5886 "too small (%i/%i)",
5887 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5888 where
, (int) mpz_get_ui (get_size
), seed_size
);
5891 /* RANDOM_SEED may not have more than one non-optional argument. */
5893 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5899 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5903 int num_percent
, nargs
;
5906 if (e
->expr_type
!= EXPR_CONSTANT
)
5909 len
= e
->value
.character
.length
;
5910 if (e
->value
.character
.string
[len
-1] != '\0')
5911 gfc_internal_error ("fe_runtime_error string must be null terminated");
5914 for (i
=0; i
<len
-1; i
++)
5915 if (e
->value
.character
.string
[i
] == '%')
5919 for (; a
; a
= a
->next
)
5922 if (nargs
-1 != num_percent
)
5923 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5924 nargs
, num_percent
++);
5930 gfc_check_second_sub (gfc_expr
*time
)
5932 if (!scalar_check (time
, 0))
5935 if (!type_check (time
, 0, BT_REAL
))
5938 if (!kind_value_check (time
, 0, 4))
5945 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5946 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5947 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5948 count_max are all optional arguments */
5951 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5952 gfc_expr
*count_max
)
5956 if (!scalar_check (count
, 0))
5959 if (!type_check (count
, 0, BT_INTEGER
))
5962 if (count
->ts
.kind
!= gfc_default_integer_kind
5963 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5964 "SYSTEM_CLOCK at %L has non-default kind",
5968 if (!variable_check (count
, 0, false))
5972 if (count_rate
!= NULL
)
5974 if (!scalar_check (count_rate
, 1))
5977 if (!variable_check (count_rate
, 1, false))
5980 if (count_rate
->ts
.type
== BT_REAL
)
5982 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5983 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5988 if (!type_check (count_rate
, 1, BT_INTEGER
))
5991 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5992 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5993 "SYSTEM_CLOCK at %L has non-default kind",
5994 &count_rate
->where
))
6000 if (count_max
!= NULL
)
6002 if (!scalar_check (count_max
, 2))
6005 if (!type_check (count_max
, 2, BT_INTEGER
))
6008 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6009 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6010 "SYSTEM_CLOCK at %L has non-default kind",
6014 if (!variable_check (count_max
, 2, false))
6023 gfc_check_irand (gfc_expr
*x
)
6028 if (!scalar_check (x
, 0))
6031 if (!type_check (x
, 0, BT_INTEGER
))
6034 if (!kind_value_check (x
, 0, 4))
6042 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6044 if (!scalar_check (seconds
, 0))
6046 if (!type_check (seconds
, 0, BT_INTEGER
))
6049 if (!int_or_proc_check (handler
, 1))
6051 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6057 if (!scalar_check (status
, 2))
6059 if (!type_check (status
, 2, BT_INTEGER
))
6061 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6069 gfc_check_rand (gfc_expr
*x
)
6074 if (!scalar_check (x
, 0))
6077 if (!type_check (x
, 0, BT_INTEGER
))
6080 if (!kind_value_check (x
, 0, 4))
6088 gfc_check_srand (gfc_expr
*x
)
6090 if (!scalar_check (x
, 0))
6093 if (!type_check (x
, 0, BT_INTEGER
))
6096 if (!kind_value_check (x
, 0, 4))
6104 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6106 if (!scalar_check (time
, 0))
6108 if (!type_check (time
, 0, BT_INTEGER
))
6111 if (!type_check (result
, 1, BT_CHARACTER
))
6113 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6121 gfc_check_dtime_etime (gfc_expr
*x
)
6123 if (!array_check (x
, 0))
6126 if (!rank_check (x
, 0, 1))
6129 if (!variable_check (x
, 0, false))
6132 if (!type_check (x
, 0, BT_REAL
))
6135 if (!kind_value_check (x
, 0, 4))
6143 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6145 if (!array_check (values
, 0))
6148 if (!rank_check (values
, 0, 1))
6151 if (!variable_check (values
, 0, false))
6154 if (!type_check (values
, 0, BT_REAL
))
6157 if (!kind_value_check (values
, 0, 4))
6160 if (!scalar_check (time
, 1))
6163 if (!type_check (time
, 1, BT_REAL
))
6166 if (!kind_value_check (time
, 1, 4))
6174 gfc_check_fdate_sub (gfc_expr
*date
)
6176 if (!type_check (date
, 0, BT_CHARACTER
))
6178 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6186 gfc_check_gerror (gfc_expr
*msg
)
6188 if (!type_check (msg
, 0, BT_CHARACTER
))
6190 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6198 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6200 if (!type_check (cwd
, 0, BT_CHARACTER
))
6202 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6208 if (!scalar_check (status
, 1))
6211 if (!type_check (status
, 1, BT_INTEGER
))
6219 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6221 if (!type_check (pos
, 0, BT_INTEGER
))
6224 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6226 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6227 "not wider than the default kind (%d)",
6228 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6229 &pos
->where
, gfc_default_integer_kind
);
6233 if (!type_check (value
, 1, BT_CHARACTER
))
6235 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6243 gfc_check_getlog (gfc_expr
*msg
)
6245 if (!type_check (msg
, 0, BT_CHARACTER
))
6247 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6255 gfc_check_exit (gfc_expr
*status
)
6260 if (!type_check (status
, 0, BT_INTEGER
))
6263 if (!scalar_check (status
, 0))
6271 gfc_check_flush (gfc_expr
*unit
)
6276 if (!type_check (unit
, 0, BT_INTEGER
))
6279 if (!scalar_check (unit
, 0))
6287 gfc_check_free (gfc_expr
*i
)
6289 if (!type_check (i
, 0, BT_INTEGER
))
6292 if (!scalar_check (i
, 0))
6300 gfc_check_hostnm (gfc_expr
*name
)
6302 if (!type_check (name
, 0, BT_CHARACTER
))
6304 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6312 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6314 if (!type_check (name
, 0, BT_CHARACTER
))
6316 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6322 if (!scalar_check (status
, 1))
6325 if (!type_check (status
, 1, BT_INTEGER
))
6333 gfc_check_itime_idate (gfc_expr
*values
)
6335 if (!array_check (values
, 0))
6338 if (!rank_check (values
, 0, 1))
6341 if (!variable_check (values
, 0, false))
6344 if (!type_check (values
, 0, BT_INTEGER
))
6347 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6355 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6357 if (!type_check (time
, 0, BT_INTEGER
))
6360 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6363 if (!scalar_check (time
, 0))
6366 if (!array_check (values
, 1))
6369 if (!rank_check (values
, 1, 1))
6372 if (!variable_check (values
, 1, false))
6375 if (!type_check (values
, 1, BT_INTEGER
))
6378 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6386 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6388 if (!scalar_check (unit
, 0))
6391 if (!type_check (unit
, 0, BT_INTEGER
))
6394 if (!type_check (name
, 1, BT_CHARACTER
))
6396 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6404 gfc_check_isatty (gfc_expr
*unit
)
6409 if (!type_check (unit
, 0, BT_INTEGER
))
6412 if (!scalar_check (unit
, 0))
6420 gfc_check_isnan (gfc_expr
*x
)
6422 if (!type_check (x
, 0, BT_REAL
))
6430 gfc_check_perror (gfc_expr
*string
)
6432 if (!type_check (string
, 0, BT_CHARACTER
))
6434 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6442 gfc_check_umask (gfc_expr
*mask
)
6444 if (!type_check (mask
, 0, BT_INTEGER
))
6447 if (!scalar_check (mask
, 0))
6455 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6457 if (!type_check (mask
, 0, BT_INTEGER
))
6460 if (!scalar_check (mask
, 0))
6466 if (!scalar_check (old
, 1))
6469 if (!type_check (old
, 1, BT_INTEGER
))
6477 gfc_check_unlink (gfc_expr
*name
)
6479 if (!type_check (name
, 0, BT_CHARACTER
))
6481 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6489 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6491 if (!type_check (name
, 0, BT_CHARACTER
))
6493 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6499 if (!scalar_check (status
, 1))
6502 if (!type_check (status
, 1, BT_INTEGER
))
6510 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6512 if (!scalar_check (number
, 0))
6514 if (!type_check (number
, 0, BT_INTEGER
))
6517 if (!int_or_proc_check (handler
, 1))
6519 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6527 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6529 if (!scalar_check (number
, 0))
6531 if (!type_check (number
, 0, BT_INTEGER
))
6534 if (!int_or_proc_check (handler
, 1))
6536 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6542 if (!type_check (status
, 2, BT_INTEGER
))
6544 if (!scalar_check (status
, 2))
6552 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6554 if (!type_check (cmd
, 0, BT_CHARACTER
))
6556 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6559 if (!scalar_check (status
, 1))
6562 if (!type_check (status
, 1, BT_INTEGER
))
6565 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6572 /* This is used for the GNU intrinsics AND, OR and XOR. */
6574 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6576 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6578 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6579 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6580 gfc_current_intrinsic
, &i
->where
);
6584 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6586 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6587 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6588 gfc_current_intrinsic
, &j
->where
);
6592 if (i
->ts
.type
!= j
->ts
.type
)
6594 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6595 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6596 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6601 if (!scalar_check (i
, 0))
6604 if (!scalar_check (j
, 1))
6612 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6615 if (a
->expr_type
== EXPR_NULL
)
6617 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6618 "argument to STORAGE_SIZE, because it returns a "
6619 "disassociated pointer", &a
->where
);
6623 if (a
->ts
.type
== BT_ASSUMED
)
6625 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6626 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6631 if (a
->ts
.type
== BT_PROCEDURE
)
6633 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6634 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6635 gfc_current_intrinsic
, &a
->where
);
6642 if (!type_check (kind
, 1, BT_INTEGER
))
6645 if (!scalar_check (kind
, 1))
6648 if (kind
->expr_type
!= EXPR_CONSTANT
)
6650 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6651 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,