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_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1257 gfc_expr
*new_val
, gfc_expr
*stat
)
1259 if (atom
->expr_type
== EXPR_FUNCTION
1260 && atom
->value
.function
.isym
1261 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1262 atom
= atom
->value
.function
.actual
->expr
;
1264 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1267 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1270 if (!same_type_check (atom
, 0, old
, 1))
1273 if (!same_type_check (atom
, 0, compare
, 2))
1276 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1278 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1279 "definable", gfc_current_intrinsic
, &atom
->where
);
1283 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1285 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1286 "definable", gfc_current_intrinsic
, &old
->where
);
1294 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1296 if (event
->ts
.type
!= BT_DERIVED
1297 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1298 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1300 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1301 "shall be of type EVENT_TYPE", &event
->where
);
1305 if (!scalar_check (event
, 0))
1308 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1310 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1311 "shall be definable", &count
->where
);
1315 if (!type_check (count
, 1, BT_INTEGER
))
1318 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1319 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1321 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1323 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1324 "shall have at least the range of the default integer",
1331 if (!type_check (stat
, 2, BT_INTEGER
))
1333 if (!scalar_check (stat
, 2))
1335 if (!variable_check (stat
, 2, false))
1338 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1339 gfc_current_intrinsic
, &stat
->where
))
1348 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1351 if (atom
->expr_type
== EXPR_FUNCTION
1352 && atom
->value
.function
.isym
1353 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1354 atom
= atom
->value
.function
.actual
->expr
;
1356 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1358 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1359 "integer of ATOMIC_INT_KIND", &atom
->where
,
1360 gfc_current_intrinsic
);
1364 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1367 if (!scalar_check (old
, 2))
1370 if (!same_type_check (atom
, 0, old
, 2))
1373 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1375 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1376 "definable", gfc_current_intrinsic
, &atom
->where
);
1380 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1382 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1383 "definable", gfc_current_intrinsic
, &old
->where
);
1391 /* BESJN and BESYN functions. */
1394 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1396 if (!type_check (n
, 0, BT_INTEGER
))
1398 if (n
->expr_type
== EXPR_CONSTANT
)
1401 gfc_extract_int (n
, &i
);
1402 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1403 "N at %L", &n
->where
))
1407 if (!type_check (x
, 1, BT_REAL
))
1414 /* Transformational version of the Bessel JN and YN functions. */
1417 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1419 if (!type_check (n1
, 0, BT_INTEGER
))
1421 if (!scalar_check (n1
, 0))
1423 if (!nonnegative_check ("N1", n1
))
1426 if (!type_check (n2
, 1, BT_INTEGER
))
1428 if (!scalar_check (n2
, 1))
1430 if (!nonnegative_check ("N2", n2
))
1433 if (!type_check (x
, 2, BT_REAL
))
1435 if (!scalar_check (x
, 2))
1443 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1445 if (!type_check (i
, 0, BT_INTEGER
))
1448 if (!type_check (j
, 1, BT_INTEGER
))
1456 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1458 if (!type_check (i
, 0, BT_INTEGER
))
1461 if (!type_check (pos
, 1, BT_INTEGER
))
1464 if (!nonnegative_check ("pos", pos
))
1467 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1475 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1477 if (!type_check (i
, 0, BT_INTEGER
))
1479 if (!kind_check (kind
, 1, BT_CHARACTER
))
1487 gfc_check_chdir (gfc_expr
*dir
)
1489 if (!type_check (dir
, 0, BT_CHARACTER
))
1491 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1499 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1501 if (!type_check (dir
, 0, BT_CHARACTER
))
1503 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1509 if (!type_check (status
, 1, BT_INTEGER
))
1511 if (!scalar_check (status
, 1))
1519 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1521 if (!type_check (name
, 0, BT_CHARACTER
))
1523 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1526 if (!type_check (mode
, 1, BT_CHARACTER
))
1528 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1536 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1538 if (!type_check (name
, 0, BT_CHARACTER
))
1540 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1543 if (!type_check (mode
, 1, BT_CHARACTER
))
1545 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1551 if (!type_check (status
, 2, BT_INTEGER
))
1554 if (!scalar_check (status
, 2))
1562 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1564 if (!numeric_check (x
, 0))
1569 if (!numeric_check (y
, 1))
1572 if (x
->ts
.type
== BT_COMPLEX
)
1574 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1575 "present if %<x%> is COMPLEX",
1576 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1581 if (y
->ts
.type
== BT_COMPLEX
)
1583 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1584 "of either REAL or INTEGER",
1585 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1592 if (!kind_check (kind
, 2, BT_COMPLEX
))
1595 if (!kind
&& warn_conversion
1596 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1597 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1598 "COMPLEX(%d) at %L might lose precision, consider using "
1599 "the KIND argument", gfc_typename (&x
->ts
),
1600 gfc_default_real_kind
, &x
->where
);
1601 else if (y
&& !kind
&& warn_conversion
1602 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1603 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1604 "COMPLEX(%d) at %L might lose precision, consider using "
1605 "the KIND argument", gfc_typename (&y
->ts
),
1606 gfc_default_real_kind
, &y
->where
);
1612 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1613 gfc_expr
*errmsg
, bool co_reduce
)
1615 if (!variable_check (a
, 0, false))
1618 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1622 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1623 if (gfc_has_vector_subscript (a
))
1625 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1626 "subroutine %s shall not have a vector subscript",
1627 &a
->where
, gfc_current_intrinsic
);
1631 if (gfc_is_coindexed (a
))
1633 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1634 "coindexed", &a
->where
, gfc_current_intrinsic
);
1638 if (image_idx
!= NULL
)
1640 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1642 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1648 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1650 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1652 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1654 if (stat
->ts
.kind
!= 4)
1656 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1657 "variable", &stat
->where
);
1664 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1666 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1668 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1670 if (errmsg
->ts
.kind
!= 1)
1672 gfc_error ("The errmsg= argument at %L must be a default-kind "
1673 "character variable", &errmsg
->where
);
1678 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1680 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1690 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1693 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1695 gfc_error ("Support for the A argument at %L which is polymorphic A "
1696 "argument or has allocatable components is not yet "
1697 "implemented", &a
->where
);
1700 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1705 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1706 gfc_expr
*stat
, gfc_expr
*errmsg
)
1708 symbol_attribute attr
;
1709 gfc_formal_arglist
*formal
;
1712 if (a
->ts
.type
== BT_CLASS
)
1714 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1719 if (gfc_expr_attr (a
).alloc_comp
)
1721 gfc_error ("Support for the A argument at %L with allocatable components"
1722 " is not yet implemented", &a
->where
);
1726 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1729 if (!gfc_resolve_expr (op
))
1732 attr
= gfc_expr_attr (op
);
1733 if (!attr
.pure
|| !attr
.function
)
1735 gfc_error ("OPERATOR argument at %L must be a PURE function",
1742 /* None of the intrinsics fulfills the criteria of taking two arguments,
1743 returning the same type and kind as the arguments and being permitted
1744 as actual argument. */
1745 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1746 op
->symtree
->n
.sym
->name
, &op
->where
);
1750 if (gfc_is_proc_ptr_comp (op
))
1752 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1753 sym
= comp
->ts
.interface
;
1756 sym
= op
->symtree
->n
.sym
;
1758 formal
= sym
->formal
;
1760 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1762 gfc_error ("The function passed as OPERATOR at %L shall have two "
1763 "arguments", &op
->where
);
1767 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1768 gfc_set_default_type (sym
->result
, 0, NULL
);
1770 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1772 gfc_error ("The A argument at %L has type %s but the function passed as "
1773 "OPERATOR at %L returns %s",
1774 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1775 gfc_typename (&sym
->result
->ts
));
1778 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1779 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1781 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1782 "%s and %s but shall have type %s", &op
->where
,
1783 gfc_typename (&formal
->sym
->ts
),
1784 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1787 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1788 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1789 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1790 || formal
->next
->sym
->attr
.pointer
)
1792 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1793 "nonallocatable nonpointer arguments and return a "
1794 "nonallocatable nonpointer scalar", &op
->where
);
1798 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1800 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1801 "attribute either for none or both arguments", &op
->where
);
1805 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1807 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1808 "attribute either for none or both arguments", &op
->where
);
1812 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1814 gfc_error ("The function passed as OPERATOR at %L shall have the "
1815 "ASYNCHRONOUS attribute either for none or both arguments",
1820 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1822 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1823 "OPTIONAL attribute for either of the arguments", &op
->where
);
1827 if (a
->ts
.type
== BT_CHARACTER
)
1830 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1833 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1834 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1836 cl
= formal
->sym
->ts
.u
.cl
;
1837 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1838 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1840 cl
= formal
->next
->sym
->ts
.u
.cl
;
1841 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1842 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1845 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1846 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1849 && ((formal_size1
&& actual_size
!= formal_size1
)
1850 || (formal_size2
&& actual_size
!= formal_size2
)))
1852 gfc_error ("The character length of the A argument at %L and of the "
1853 "arguments of the OPERATOR at %L shall be the same",
1854 &a
->where
, &op
->where
);
1857 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1859 gfc_error ("The character length of the A argument at %L and of the "
1860 "function result of the OPERATOR at %L shall be the same",
1861 &a
->where
, &op
->where
);
1871 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1874 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1875 && a
->ts
.type
!= BT_CHARACTER
)
1877 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1878 "integer, real or character",
1879 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1883 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1888 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1891 if (!numeric_check (a
, 0))
1893 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1898 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1900 if (!int_or_real_check (x
, 0))
1902 if (!scalar_check (x
, 0))
1905 if (!int_or_real_check (y
, 1))
1907 if (!scalar_check (y
, 1))
1915 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1917 if (!logical_array_check (mask
, 0))
1919 if (!dim_check (dim
, 1, false))
1921 if (!dim_rank_check (dim
, mask
, 0))
1923 if (!kind_check (kind
, 2, BT_INTEGER
))
1925 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1926 "with KIND argument at %L",
1927 gfc_current_intrinsic
, &kind
->where
))
1935 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1937 if (!array_check (array
, 0))
1940 if (!type_check (shift
, 1, BT_INTEGER
))
1943 if (!dim_check (dim
, 2, true))
1946 if (!dim_rank_check (dim
, array
, false))
1949 if (array
->rank
== 1 || shift
->rank
== 0)
1951 if (!scalar_check (shift
, 1))
1954 else if (shift
->rank
== array
->rank
- 1)
1959 else if (dim
->expr_type
== EXPR_CONSTANT
)
1960 gfc_extract_int (dim
, &d
);
1967 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1970 if (!identical_dimen_shape (array
, i
, shift
, j
))
1972 gfc_error ("%qs argument of %qs intrinsic at %L has "
1973 "invalid shape in dimension %d (%ld/%ld)",
1974 gfc_current_intrinsic_arg
[1]->name
,
1975 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1976 mpz_get_si (array
->shape
[i
]),
1977 mpz_get_si (shift
->shape
[j
]));
1987 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
1988 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1989 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1998 gfc_check_ctime (gfc_expr
*time
)
2000 if (!scalar_check (time
, 0))
2003 if (!type_check (time
, 0, BT_INTEGER
))
2010 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2012 if (!double_check (y
, 0) || !double_check (x
, 1))
2019 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2021 if (!numeric_check (x
, 0))
2026 if (!numeric_check (y
, 1))
2029 if (x
->ts
.type
== BT_COMPLEX
)
2031 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2032 "present if %<x%> is COMPLEX",
2033 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2038 if (y
->ts
.type
== BT_COMPLEX
)
2040 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2041 "of either REAL or INTEGER",
2042 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2053 gfc_check_dble (gfc_expr
*x
)
2055 if (!numeric_check (x
, 0))
2063 gfc_check_digits (gfc_expr
*x
)
2065 if (!int_or_real_check (x
, 0))
2073 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2075 switch (vector_a
->ts
.type
)
2078 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2085 if (!numeric_check (vector_b
, 1))
2090 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2091 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2092 gfc_current_intrinsic
, &vector_a
->where
);
2096 if (!rank_check (vector_a
, 0, 1))
2099 if (!rank_check (vector_b
, 1, 1))
2102 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2104 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2105 "intrinsic %<dot_product%>",
2106 gfc_current_intrinsic_arg
[0]->name
,
2107 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2116 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2118 if (!type_check (x
, 0, BT_REAL
)
2119 || !type_check (y
, 1, BT_REAL
))
2122 if (x
->ts
.kind
!= gfc_default_real_kind
)
2124 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2125 "real", gfc_current_intrinsic_arg
[0]->name
,
2126 gfc_current_intrinsic
, &x
->where
);
2130 if (y
->ts
.kind
!= gfc_default_real_kind
)
2132 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2133 "real", gfc_current_intrinsic_arg
[1]->name
,
2134 gfc_current_intrinsic
, &y
->where
);
2143 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2145 if (!type_check (i
, 0, BT_INTEGER
))
2148 if (!type_check (j
, 1, BT_INTEGER
))
2151 if (i
->is_boz
&& j
->is_boz
)
2153 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2154 "constants", &i
->where
, &j
->where
);
2158 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
2161 if (!type_check (shift
, 2, BT_INTEGER
))
2164 if (!nonnegative_check ("SHIFT", shift
))
2169 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
2171 i
->ts
.kind
= j
->ts
.kind
;
2175 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2177 j
->ts
.kind
= i
->ts
.kind
;
2185 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2190 if (!array_check (array
, 0))
2193 if (!type_check (shift
, 1, BT_INTEGER
))
2196 if (!dim_check (dim
, 3, true))
2199 if (!dim_rank_check (dim
, array
, false))
2204 else if (dim
->expr_type
== EXPR_CONSTANT
)
2205 gfc_extract_int (dim
, &d
);
2209 if (array
->rank
== 1 || shift
->rank
== 0)
2211 if (!scalar_check (shift
, 1))
2214 else if (shift
->rank
== array
->rank
- 1)
2219 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2222 if (!identical_dimen_shape (array
, i
, shift
, j
))
2224 gfc_error ("%qs argument of %qs intrinsic at %L has "
2225 "invalid shape in dimension %d (%ld/%ld)",
2226 gfc_current_intrinsic_arg
[1]->name
,
2227 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2228 mpz_get_si (array
->shape
[i
]),
2229 mpz_get_si (shift
->shape
[j
]));
2239 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2240 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2241 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2245 if (boundary
!= NULL
)
2247 if (!same_type_check (array
, 0, boundary
, 2))
2250 /* Reject unequal string lengths and emit a better error message than
2251 gfc_check_same_strlen would. */
2252 if (array
->ts
.type
== BT_CHARACTER
)
2254 ssize_t len_a
, len_b
;
2256 len_a
= gfc_var_strlen (array
);
2257 len_b
= gfc_var_strlen (boundary
);
2258 if (len_a
!= -1 && len_b
!= -1 && len_a
!= len_b
)
2260 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2261 gfc_current_intrinsic_arg
[2]->name
,
2262 gfc_current_intrinsic_arg
[0]->name
,
2263 &boundary
->where
, gfc_current_intrinsic
);
2268 if (array
->rank
== 1 || boundary
->rank
== 0)
2270 if (!scalar_check (boundary
, 2))
2273 else if (boundary
->rank
== array
->rank
- 1)
2278 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2282 if (!identical_dimen_shape (array
, i
, boundary
, j
))
2284 gfc_error ("%qs argument of %qs intrinsic at %L has "
2285 "invalid shape in dimension %d (%ld/%ld)",
2286 gfc_current_intrinsic_arg
[2]->name
,
2287 gfc_current_intrinsic
, &shift
->where
, i
+1,
2288 mpz_get_si (array
->shape
[i
]),
2289 mpz_get_si (boundary
->shape
[j
]));
2299 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2300 "rank %d or be a scalar",
2301 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2302 &shift
->where
, array
->rank
- 1);
2308 switch (array
->ts
.type
)
2318 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2319 "of type %qs", gfc_current_intrinsic_arg
[2]->name
,
2320 gfc_current_intrinsic
, &array
->where
,
2321 gfc_current_intrinsic_arg
[0]->name
,
2322 gfc_typename (&array
->ts
));
2331 gfc_check_float (gfc_expr
*a
)
2333 if (!type_check (a
, 0, BT_INTEGER
))
2336 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2337 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2338 "kind argument to %s intrinsic at %L",
2339 gfc_current_intrinsic
, &a
->where
))
2345 /* A single complex argument. */
2348 gfc_check_fn_c (gfc_expr
*a
)
2350 if (!type_check (a
, 0, BT_COMPLEX
))
2357 /* A single real argument. */
2360 gfc_check_fn_r (gfc_expr
*a
)
2362 if (!type_check (a
, 0, BT_REAL
))
2368 /* A single double argument. */
2371 gfc_check_fn_d (gfc_expr
*a
)
2373 if (!double_check (a
, 0))
2379 /* A single real or complex argument. */
2382 gfc_check_fn_rc (gfc_expr
*a
)
2384 if (!real_or_complex_check (a
, 0))
2392 gfc_check_fn_rc2008 (gfc_expr
*a
)
2394 if (!real_or_complex_check (a
, 0))
2397 if (a
->ts
.type
== BT_COMPLEX
2398 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2399 "of %qs intrinsic at %L",
2400 gfc_current_intrinsic_arg
[0]->name
,
2401 gfc_current_intrinsic
, &a
->where
))
2409 gfc_check_fnum (gfc_expr
*unit
)
2411 if (!type_check (unit
, 0, BT_INTEGER
))
2414 if (!scalar_check (unit
, 0))
2422 gfc_check_huge (gfc_expr
*x
)
2424 if (!int_or_real_check (x
, 0))
2432 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2434 if (!type_check (x
, 0, BT_REAL
))
2436 if (!same_type_check (x
, 0, y
, 1))
2443 /* Check that the single argument is an integer. */
2446 gfc_check_i (gfc_expr
*i
)
2448 if (!type_check (i
, 0, BT_INTEGER
))
2456 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2458 if (!type_check (i
, 0, BT_INTEGER
))
2461 if (!type_check (j
, 1, BT_INTEGER
))
2464 if (i
->ts
.kind
!= j
->ts
.kind
)
2466 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2476 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2478 if (!type_check (i
, 0, BT_INTEGER
))
2481 if (!type_check (pos
, 1, BT_INTEGER
))
2484 if (!type_check (len
, 2, BT_INTEGER
))
2487 if (!nonnegative_check ("pos", pos
))
2490 if (!nonnegative_check ("len", len
))
2493 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2501 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2505 if (!type_check (c
, 0, BT_CHARACTER
))
2508 if (!kind_check (kind
, 1, BT_INTEGER
))
2511 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2512 "with KIND argument at %L",
2513 gfc_current_intrinsic
, &kind
->where
))
2516 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2522 /* Substring references don't have the charlength set. */
2524 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2527 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2531 /* Check that the argument is length one. Non-constant lengths
2532 can't be checked here, so assume they are ok. */
2533 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2535 /* If we already have a length for this expression then use it. */
2536 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2538 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2545 start
= ref
->u
.ss
.start
;
2546 end
= ref
->u
.ss
.end
;
2549 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2550 || start
->expr_type
!= EXPR_CONSTANT
)
2553 i
= mpz_get_si (end
->value
.integer
) + 1
2554 - mpz_get_si (start
->value
.integer
);
2562 gfc_error ("Argument of %s at %L must be of length one",
2563 gfc_current_intrinsic
, &c
->where
);
2572 gfc_check_idnint (gfc_expr
*a
)
2574 if (!double_check (a
, 0))
2582 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2584 if (!type_check (i
, 0, BT_INTEGER
))
2587 if (!type_check (j
, 1, BT_INTEGER
))
2590 if (i
->ts
.kind
!= j
->ts
.kind
)
2592 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2602 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2605 if (!type_check (string
, 0, BT_CHARACTER
)
2606 || !type_check (substring
, 1, BT_CHARACTER
))
2609 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2612 if (!kind_check (kind
, 3, BT_INTEGER
))
2614 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2615 "with KIND argument at %L",
2616 gfc_current_intrinsic
, &kind
->where
))
2619 if (string
->ts
.kind
!= substring
->ts
.kind
)
2621 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2622 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2623 gfc_current_intrinsic
, &substring
->where
,
2624 gfc_current_intrinsic_arg
[0]->name
);
2633 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2635 if (!numeric_check (x
, 0))
2638 if (!kind_check (kind
, 1, BT_INTEGER
))
2646 gfc_check_intconv (gfc_expr
*x
)
2648 if (!numeric_check (x
, 0))
2656 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2658 if (!type_check (i
, 0, BT_INTEGER
))
2661 if (!type_check (j
, 1, BT_INTEGER
))
2664 if (i
->ts
.kind
!= j
->ts
.kind
)
2666 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2676 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2678 if (!type_check (i
, 0, BT_INTEGER
)
2679 || !type_check (shift
, 1, BT_INTEGER
))
2682 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2690 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2692 if (!type_check (i
, 0, BT_INTEGER
)
2693 || !type_check (shift
, 1, BT_INTEGER
))
2700 if (!type_check (size
, 2, BT_INTEGER
))
2703 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2706 if (size
->expr_type
== EXPR_CONSTANT
)
2708 gfc_extract_int (size
, &i3
);
2711 gfc_error ("SIZE at %L must be positive", &size
->where
);
2715 if (shift
->expr_type
== EXPR_CONSTANT
)
2717 gfc_extract_int (shift
, &i2
);
2723 gfc_error ("The absolute value of SHIFT at %L must be less "
2724 "than or equal to SIZE at %L", &shift
->where
,
2731 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2739 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2741 if (!type_check (pid
, 0, BT_INTEGER
))
2744 if (!type_check (sig
, 1, BT_INTEGER
))
2752 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2754 if (!type_check (pid
, 0, BT_INTEGER
))
2757 if (!scalar_check (pid
, 0))
2760 if (!type_check (sig
, 1, BT_INTEGER
))
2763 if (!scalar_check (sig
, 1))
2769 if (!type_check (status
, 2, BT_INTEGER
))
2772 if (!scalar_check (status
, 2))
2780 gfc_check_kind (gfc_expr
*x
)
2782 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
2784 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2785 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2786 gfc_current_intrinsic
, &x
->where
);
2789 if (x
->ts
.type
== BT_PROCEDURE
)
2791 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2792 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2802 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2804 if (!array_check (array
, 0))
2807 if (!dim_check (dim
, 1, false))
2810 if (!dim_rank_check (dim
, array
, 1))
2813 if (!kind_check (kind
, 2, BT_INTEGER
))
2815 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2816 "with KIND argument at %L",
2817 gfc_current_intrinsic
, &kind
->where
))
2825 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2827 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2829 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2833 if (!coarray_check (coarray
, 0))
2838 if (!dim_check (dim
, 1, false))
2841 if (!dim_corank_check (dim
, coarray
))
2845 if (!kind_check (kind
, 2, BT_INTEGER
))
2853 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2855 if (!type_check (s
, 0, BT_CHARACTER
))
2858 if (!kind_check (kind
, 1, BT_INTEGER
))
2860 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2861 "with KIND argument at %L",
2862 gfc_current_intrinsic
, &kind
->where
))
2870 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2872 if (!type_check (a
, 0, BT_CHARACTER
))
2874 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2877 if (!type_check (b
, 1, BT_CHARACTER
))
2879 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2887 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2889 if (!type_check (path1
, 0, BT_CHARACTER
))
2891 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2894 if (!type_check (path2
, 1, BT_CHARACTER
))
2896 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2904 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2906 if (!type_check (path1
, 0, BT_CHARACTER
))
2908 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2911 if (!type_check (path2
, 1, BT_CHARACTER
))
2913 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2919 if (!type_check (status
, 2, BT_INTEGER
))
2922 if (!scalar_check (status
, 2))
2930 gfc_check_loc (gfc_expr
*expr
)
2932 return variable_check (expr
, 0, true);
2937 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2939 if (!type_check (path1
, 0, BT_CHARACTER
))
2941 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2944 if (!type_check (path2
, 1, BT_CHARACTER
))
2946 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2954 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2956 if (!type_check (path1
, 0, BT_CHARACTER
))
2958 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2961 if (!type_check (path2
, 1, BT_CHARACTER
))
2963 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2969 if (!type_check (status
, 2, BT_INTEGER
))
2972 if (!scalar_check (status
, 2))
2980 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2982 if (!type_check (a
, 0, BT_LOGICAL
))
2984 if (!kind_check (kind
, 1, BT_LOGICAL
))
2991 /* Min/max family. */
2994 min_max_args (gfc_actual_arglist
*args
)
2996 gfc_actual_arglist
*arg
;
2997 int i
, j
, nargs
, *nlabels
, nlabelless
;
2998 bool a1
= false, a2
= false;
3000 if (args
== NULL
|| args
->next
== NULL
)
3002 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3003 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
3010 if (!args
->next
->name
)
3014 for (arg
= args
; arg
; arg
= arg
->next
)
3021 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3023 nlabels
= XALLOCAVEC (int, nargs
);
3024 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
3030 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
3032 n
= strtol (&arg
->name
[1], &endp
, 10);
3033 if (endp
[0] != '\0')
3037 if (n
<= nlabelless
)
3050 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3051 !a1
? "a1" : "a2", gfc_current_intrinsic
,
3052 gfc_current_intrinsic_where
);
3056 /* Check for duplicates. */
3057 for (i
= 0; i
< nargs
; i
++)
3058 for (j
= i
+ 1; j
< nargs
; j
++)
3059 if (nlabels
[i
] == nlabels
[j
])
3065 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3066 &arg
->expr
->where
, gfc_current_intrinsic
);
3070 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3071 &arg
->expr
->where
, gfc_current_intrinsic
);
3077 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3079 gfc_actual_arglist
*arg
, *tmp
;
3083 if (!min_max_args (arglist
))
3086 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3089 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3091 if (x
->ts
.type
== type
)
3093 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3094 "kinds at %L", &x
->where
))
3099 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3100 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3101 gfc_basic_typename (type
), kind
);
3106 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3107 if (!gfc_check_conformance (tmp
->expr
, x
,
3108 "arguments 'a%d' and 'a%d' for "
3109 "intrinsic '%s'", m
, n
,
3110 gfc_current_intrinsic
))
3119 gfc_check_min_max (gfc_actual_arglist
*arg
)
3123 if (!min_max_args (arg
))
3128 if (x
->ts
.type
== BT_CHARACTER
)
3130 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3131 "with CHARACTER argument at %L",
3132 gfc_current_intrinsic
, &x
->where
))
3135 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3137 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3138 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3142 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3147 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3149 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3154 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3156 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3161 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3163 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3167 /* End of min/max family. */
3170 gfc_check_malloc (gfc_expr
*size
)
3172 if (!type_check (size
, 0, BT_INTEGER
))
3175 if (!scalar_check (size
, 0))
3183 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3185 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3187 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3188 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3189 gfc_current_intrinsic
, &matrix_a
->where
);
3193 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3195 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3196 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3197 gfc_current_intrinsic
, &matrix_b
->where
);
3201 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3202 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3204 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3205 gfc_current_intrinsic
, &matrix_a
->where
,
3206 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3210 switch (matrix_a
->rank
)
3213 if (!rank_check (matrix_b
, 1, 2))
3215 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3216 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3218 gfc_error ("Different shape on dimension 1 for arguments %qs "
3219 "and %qs at %L for intrinsic matmul",
3220 gfc_current_intrinsic_arg
[0]->name
,
3221 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3227 if (matrix_b
->rank
!= 2)
3229 if (!rank_check (matrix_b
, 1, 1))
3232 /* matrix_b has rank 1 or 2 here. Common check for the cases
3233 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3234 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3235 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3237 gfc_error ("Different shape on dimension 2 for argument %qs and "
3238 "dimension 1 for argument %qs at %L for intrinsic "
3239 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3240 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3246 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3247 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3248 gfc_current_intrinsic
, &matrix_a
->where
);
3256 /* Whoever came up with this interface was probably on something.
3257 The possibilities for the occupation of the second and third
3264 NULL MASK minloc(array, mask=m)
3267 I.e. in the case of minloc(array,mask), mask will be in the second
3268 position of the argument list and we'll have to fix that up. Also,
3269 add the BACK argument if that isn't present. */
3272 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3274 gfc_expr
*a
, *m
, *d
, *k
, *b
;
3277 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3281 m
= ap
->next
->next
->expr
;
3282 k
= ap
->next
->next
->next
->expr
;
3283 b
= ap
->next
->next
->next
->next
->expr
;
3287 if (!type_check (b
, 4, BT_LOGICAL
) || !scalar_check (b
,4))
3290 /* TODO: Remove this once BACK is actually implemented. */
3291 if (b
->expr_type
!= EXPR_CONSTANT
|| b
->value
.logical
!= 0)
3293 gfc_error ("BACK argument to %qs intrinsic not yet "
3294 "implemented", gfc_current_intrinsic
);
3300 b
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, 0);
3301 ap
->next
->next
->next
->next
->expr
= b
;
3304 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3305 && ap
->next
->name
== NULL
)
3309 ap
->next
->expr
= NULL
;
3310 ap
->next
->next
->expr
= m
;
3313 if (!dim_check (d
, 1, false))
3316 if (!dim_rank_check (d
, a
, 0))
3319 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3323 && !gfc_check_conformance (a
, m
,
3324 "arguments '%s' and '%s' for intrinsic %s",
3325 gfc_current_intrinsic_arg
[0]->name
,
3326 gfc_current_intrinsic_arg
[2]->name
,
3327 gfc_current_intrinsic
))
3330 if (!kind_check (k
, 1, BT_INTEGER
))
3337 /* Similar to minloc/maxloc, the argument list might need to be
3338 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3339 difference is that MINLOC/MAXLOC take an additional KIND argument.
3340 The possibilities are:
3346 NULL MASK minval(array, mask=m)
3349 I.e. in the case of minval(array,mask), mask will be in the second
3350 position of the argument list and we'll have to fix that up. */
3353 check_reduction (gfc_actual_arglist
*ap
)
3355 gfc_expr
*a
, *m
, *d
;
3359 m
= ap
->next
->next
->expr
;
3361 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3362 && ap
->next
->name
== NULL
)
3366 ap
->next
->expr
= NULL
;
3367 ap
->next
->next
->expr
= m
;
3370 if (!dim_check (d
, 1, false))
3373 if (!dim_rank_check (d
, a
, 0))
3376 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3380 && !gfc_check_conformance (a
, m
,
3381 "arguments '%s' and '%s' for intrinsic %s",
3382 gfc_current_intrinsic_arg
[0]->name
,
3383 gfc_current_intrinsic_arg
[2]->name
,
3384 gfc_current_intrinsic
))
3392 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3394 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
3395 || !array_check (ap
->expr
, 0))
3398 return check_reduction (ap
);
3403 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3405 if (!numeric_check (ap
->expr
, 0)
3406 || !array_check (ap
->expr
, 0))
3409 return check_reduction (ap
);
3413 /* For IANY, IALL and IPARITY. */
3416 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3420 if (!type_check (i
, 0, BT_INTEGER
))
3423 if (!nonnegative_check ("I", i
))
3426 if (!kind_check (kind
, 1, BT_INTEGER
))
3430 gfc_extract_int (kind
, &k
);
3432 k
= gfc_default_integer_kind
;
3434 if (!less_than_bitsizekind ("I", i
, k
))
3442 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3444 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3446 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3447 gfc_current_intrinsic_arg
[0]->name
,
3448 gfc_current_intrinsic
, &ap
->expr
->where
);
3452 if (!array_check (ap
->expr
, 0))
3455 return check_reduction (ap
);
3460 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3462 if (!same_type_check (tsource
, 0, fsource
, 1))
3465 if (!type_check (mask
, 2, BT_LOGICAL
))
3468 if (tsource
->ts
.type
== BT_CHARACTER
)
3469 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3476 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3478 if (!type_check (i
, 0, BT_INTEGER
))
3481 if (!type_check (j
, 1, BT_INTEGER
))
3484 if (!type_check (mask
, 2, BT_INTEGER
))
3487 if (!same_type_check (i
, 0, j
, 1))
3490 if (!same_type_check (i
, 0, mask
, 2))
3498 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3500 if (!variable_check (from
, 0, false))
3502 if (!allocatable_check (from
, 0))
3504 if (gfc_is_coindexed (from
))
3506 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3507 "coindexed", &from
->where
);
3511 if (!variable_check (to
, 1, false))
3513 if (!allocatable_check (to
, 1))
3515 if (gfc_is_coindexed (to
))
3517 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3518 "coindexed", &to
->where
);
3522 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3524 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3525 "polymorphic if FROM is polymorphic",
3530 if (!same_type_check (to
, 1, from
, 0))
3533 if (to
->rank
!= from
->rank
)
3535 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3536 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3541 /* IR F08/0040; cf. 12-006A. */
3542 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3544 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3545 "must have the same corank %d/%d", &to
->where
,
3546 gfc_get_corank (from
), gfc_get_corank (to
));
3550 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3551 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3552 and cmp2 are allocatable. After the allocation is transferred,
3553 the 'to' chain is broken by the nullification of the 'from'. A bit
3554 of reflection reveals that this can only occur for derived types
3555 with recursive allocatable components. */
3556 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3557 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3559 gfc_ref
*to_ref
, *from_ref
;
3561 from_ref
= from
->ref
;
3562 bool aliasing
= true;
3564 for (; from_ref
&& to_ref
;
3565 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3567 if (to_ref
->type
!= from
->ref
->type
)
3569 else if (to_ref
->type
== REF_ARRAY
3570 && to_ref
->u
.ar
.type
!= AR_FULL
3571 && from_ref
->u
.ar
.type
!= AR_FULL
)
3572 /* Play safe; assume sections and elements are different. */
3574 else if (to_ref
->type
== REF_COMPONENT
3575 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3584 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3585 "restrictions (F2003 12.4.1.7)", &to
->where
);
3590 /* CLASS arguments: Make sure the vtab of from is present. */
3591 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3592 gfc_find_vtab (&from
->ts
);
3599 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3601 if (!type_check (x
, 0, BT_REAL
))
3604 if (!type_check (s
, 1, BT_REAL
))
3607 if (s
->expr_type
== EXPR_CONSTANT
)
3609 if (mpfr_sgn (s
->value
.real
) == 0)
3611 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3622 gfc_check_new_line (gfc_expr
*a
)
3624 if (!type_check (a
, 0, BT_CHARACTER
))
3632 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3634 if (!type_check (array
, 0, BT_REAL
))
3637 if (!array_check (array
, 0))
3640 if (!dim_rank_check (dim
, array
, false))
3647 gfc_check_null (gfc_expr
*mold
)
3649 symbol_attribute attr
;
3654 if (!variable_check (mold
, 0, true))
3657 attr
= gfc_variable_attr (mold
, NULL
);
3659 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3661 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3662 "ALLOCATABLE or procedure pointer",
3663 gfc_current_intrinsic_arg
[0]->name
,
3664 gfc_current_intrinsic
, &mold
->where
);
3668 if (attr
.allocatable
3669 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3670 "allocatable MOLD at %L", &mold
->where
))
3674 if (gfc_is_coindexed (mold
))
3676 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3677 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3678 gfc_current_intrinsic
, &mold
->where
);
3687 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3689 if (!array_check (array
, 0))
3692 if (!type_check (mask
, 1, BT_LOGICAL
))
3695 if (!gfc_check_conformance (array
, mask
,
3696 "arguments '%s' and '%s' for intrinsic '%s'",
3697 gfc_current_intrinsic_arg
[0]->name
,
3698 gfc_current_intrinsic_arg
[1]->name
,
3699 gfc_current_intrinsic
))
3704 mpz_t array_size
, vector_size
;
3705 bool have_array_size
, have_vector_size
;
3707 if (!same_type_check (array
, 0, vector
, 2))
3710 if (!rank_check (vector
, 2, 1))
3713 /* VECTOR requires at least as many elements as MASK
3714 has .TRUE. values. */
3715 have_array_size
= gfc_array_size(array
, &array_size
);
3716 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3718 if (have_vector_size
3719 && (mask
->expr_type
== EXPR_ARRAY
3720 || (mask
->expr_type
== EXPR_CONSTANT
3721 && have_array_size
)))
3723 int mask_true_values
= 0;
3725 if (mask
->expr_type
== EXPR_ARRAY
)
3727 gfc_constructor
*mask_ctor
;
3728 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3731 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3733 mask_true_values
= 0;
3737 if (mask_ctor
->expr
->value
.logical
)
3740 mask_ctor
= gfc_constructor_next (mask_ctor
);
3743 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3744 mask_true_values
= mpz_get_si (array_size
);
3746 if (mpz_get_si (vector_size
) < mask_true_values
)
3748 gfc_error ("%qs argument of %qs intrinsic at %L must "
3749 "provide at least as many elements as there "
3750 "are .TRUE. values in %qs (%ld/%d)",
3751 gfc_current_intrinsic_arg
[2]->name
,
3752 gfc_current_intrinsic
, &vector
->where
,
3753 gfc_current_intrinsic_arg
[1]->name
,
3754 mpz_get_si (vector_size
), mask_true_values
);
3759 if (have_array_size
)
3760 mpz_clear (array_size
);
3761 if (have_vector_size
)
3762 mpz_clear (vector_size
);
3770 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3772 if (!type_check (mask
, 0, BT_LOGICAL
))
3775 if (!array_check (mask
, 0))
3778 if (!dim_rank_check (dim
, mask
, false))
3786 gfc_check_precision (gfc_expr
*x
)
3788 if (!real_or_complex_check (x
, 0))
3796 gfc_check_present (gfc_expr
*a
)
3800 if (!variable_check (a
, 0, true))
3803 sym
= a
->symtree
->n
.sym
;
3804 if (!sym
->attr
.dummy
)
3806 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3807 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3808 gfc_current_intrinsic
, &a
->where
);
3812 if (!sym
->attr
.optional
)
3814 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3815 "an OPTIONAL dummy variable",
3816 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3821 /* 13.14.82 PRESENT(A)
3823 Argument. A shall be the name of an optional dummy argument that is
3824 accessible in the subprogram in which the PRESENT function reference
3828 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3829 && (a
->ref
->u
.ar
.type
== AR_FULL
3830 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3831 && a
->ref
->u
.ar
.as
->rank
== 0))))
3833 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3834 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3835 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3844 gfc_check_radix (gfc_expr
*x
)
3846 if (!int_or_real_check (x
, 0))
3854 gfc_check_range (gfc_expr
*x
)
3856 if (!numeric_check (x
, 0))
3864 gfc_check_rank (gfc_expr
*a
)
3866 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3867 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3869 bool is_variable
= true;
3871 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3872 if (a
->expr_type
== EXPR_FUNCTION
)
3873 is_variable
= a
->value
.function
.esym
3874 ? a
->value
.function
.esym
->result
->attr
.pointer
3875 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3877 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3878 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3881 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3882 "object", &a
->where
);
3890 /* real, float, sngl. */
3892 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3894 if (!numeric_check (a
, 0))
3897 if (!kind_check (kind
, 1, BT_REAL
))
3905 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3907 if (!type_check (path1
, 0, BT_CHARACTER
))
3909 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3912 if (!type_check (path2
, 1, BT_CHARACTER
))
3914 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3922 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3924 if (!type_check (path1
, 0, BT_CHARACTER
))
3926 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3929 if (!type_check (path2
, 1, BT_CHARACTER
))
3931 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3937 if (!type_check (status
, 2, BT_INTEGER
))
3940 if (!scalar_check (status
, 2))
3948 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3950 if (!type_check (x
, 0, BT_CHARACTER
))
3953 if (!scalar_check (x
, 0))
3956 if (!type_check (y
, 0, BT_INTEGER
))
3959 if (!scalar_check (y
, 1))
3967 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3968 gfc_expr
*pad
, gfc_expr
*order
)
3974 if (!array_check (source
, 0))
3977 if (!rank_check (shape
, 1, 1))
3980 if (!type_check (shape
, 1, BT_INTEGER
))
3983 if (!gfc_array_size (shape
, &size
))
3985 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3986 "array of constant size", &shape
->where
);
3990 shape_size
= mpz_get_ui (size
);
3993 if (shape_size
<= 0)
3995 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3996 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4000 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4002 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4003 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4006 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
4010 for (i
= 0; i
< shape_size
; ++i
)
4012 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4013 if (e
->expr_type
!= EXPR_CONSTANT
)
4016 gfc_extract_int (e
, &extent
);
4019 gfc_error ("%qs argument of %qs intrinsic at %L has "
4020 "negative element (%d)",
4021 gfc_current_intrinsic_arg
[1]->name
,
4022 gfc_current_intrinsic
, &e
->where
, extent
);
4027 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4028 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4029 && shape
->ref
->u
.ar
.as
4030 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4031 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4032 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4033 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4034 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4039 v
= shape
->symtree
->n
.sym
->value
;
4041 for (i
= 0; i
< shape_size
; i
++)
4043 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4047 gfc_extract_int (e
, &extent
);
4051 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4052 "cannot be negative", i
+ 1, &shape
->where
);
4060 if (!same_type_check (source
, 0, pad
, 2))
4063 if (!array_check (pad
, 2))
4069 if (!array_check (order
, 3))
4072 if (!type_check (order
, 3, BT_INTEGER
))
4075 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4077 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4080 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4083 gfc_array_size (order
, &size
);
4084 order_size
= mpz_get_ui (size
);
4087 if (order_size
!= shape_size
)
4089 gfc_error ("%qs argument of %qs intrinsic at %L "
4090 "has wrong number of elements (%d/%d)",
4091 gfc_current_intrinsic_arg
[3]->name
,
4092 gfc_current_intrinsic
, &order
->where
,
4093 order_size
, shape_size
);
4097 for (i
= 1; i
<= order_size
; ++i
)
4099 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4100 if (e
->expr_type
!= EXPR_CONSTANT
)
4103 gfc_extract_int (e
, &dim
);
4105 if (dim
< 1 || dim
> order_size
)
4107 gfc_error ("%qs argument of %qs intrinsic at %L "
4108 "has out-of-range dimension (%d)",
4109 gfc_current_intrinsic_arg
[3]->name
,
4110 gfc_current_intrinsic
, &e
->where
, dim
);
4114 if (perm
[dim
-1] != 0)
4116 gfc_error ("%qs argument of %qs intrinsic at %L has "
4117 "invalid permutation of dimensions (dimension "
4119 gfc_current_intrinsic_arg
[3]->name
,
4120 gfc_current_intrinsic
, &e
->where
, dim
);
4129 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4130 && gfc_is_constant_expr (shape
)
4131 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4132 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4134 /* Check the match in size between source and destination. */
4135 if (gfc_array_size (source
, &nelems
))
4141 mpz_init_set_ui (size
, 1);
4142 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4143 c
; c
= gfc_constructor_next (c
))
4144 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4146 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4152 gfc_error ("Without padding, there are not enough elements "
4153 "in the intrinsic RESHAPE source at %L to match "
4154 "the shape", &source
->where
);
4165 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4167 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4169 gfc_error ("%qs argument of %qs intrinsic at %L "
4170 "cannot be of type %s",
4171 gfc_current_intrinsic_arg
[0]->name
,
4172 gfc_current_intrinsic
,
4173 &a
->where
, gfc_typename (&a
->ts
));
4177 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4179 gfc_error ("%qs argument of %qs intrinsic at %L "
4180 "must be of an extensible type",
4181 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4186 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4188 gfc_error ("%qs argument of %qs intrinsic at %L "
4189 "cannot be of type %s",
4190 gfc_current_intrinsic_arg
[0]->name
,
4191 gfc_current_intrinsic
,
4192 &b
->where
, gfc_typename (&b
->ts
));
4196 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4198 gfc_error ("%qs argument of %qs intrinsic at %L "
4199 "must be of an extensible type",
4200 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4210 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4212 if (!type_check (x
, 0, BT_REAL
))
4215 if (!type_check (i
, 1, BT_INTEGER
))
4223 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4225 if (!type_check (x
, 0, BT_CHARACTER
))
4228 if (!type_check (y
, 1, BT_CHARACTER
))
4231 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4234 if (!kind_check (kind
, 3, BT_INTEGER
))
4236 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4237 "with KIND argument at %L",
4238 gfc_current_intrinsic
, &kind
->where
))
4241 if (!same_type_check (x
, 0, y
, 1))
4249 gfc_check_secnds (gfc_expr
*r
)
4251 if (!type_check (r
, 0, BT_REAL
))
4254 if (!kind_value_check (r
, 0, 4))
4257 if (!scalar_check (r
, 0))
4265 gfc_check_selected_char_kind (gfc_expr
*name
)
4267 if (!type_check (name
, 0, BT_CHARACTER
))
4270 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4273 if (!scalar_check (name
, 0))
4281 gfc_check_selected_int_kind (gfc_expr
*r
)
4283 if (!type_check (r
, 0, BT_INTEGER
))
4286 if (!scalar_check (r
, 0))
4294 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4296 if (p
== NULL
&& r
== NULL
4297 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4298 " neither %<P%> nor %<R%> argument at %L",
4299 gfc_current_intrinsic_where
))
4304 if (!type_check (p
, 0, BT_INTEGER
))
4307 if (!scalar_check (p
, 0))
4313 if (!type_check (r
, 1, BT_INTEGER
))
4316 if (!scalar_check (r
, 1))
4322 if (!type_check (radix
, 1, BT_INTEGER
))
4325 if (!scalar_check (radix
, 1))
4328 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4329 "RADIX argument at %L", gfc_current_intrinsic
,
4339 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4341 if (!type_check (x
, 0, BT_REAL
))
4344 if (!type_check (i
, 1, BT_INTEGER
))
4352 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4356 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4359 ar
= gfc_find_array_ref (source
);
4361 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4363 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4364 "an assumed size array", &source
->where
);
4368 if (!kind_check (kind
, 1, BT_INTEGER
))
4370 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4371 "with KIND argument at %L",
4372 gfc_current_intrinsic
, &kind
->where
))
4380 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4382 if (!type_check (i
, 0, BT_INTEGER
))
4385 if (!type_check (shift
, 0, BT_INTEGER
))
4388 if (!nonnegative_check ("SHIFT", shift
))
4391 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4399 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4401 if (!int_or_real_check (a
, 0))
4404 if (!same_type_check (a
, 0, b
, 1))
4412 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4414 if (!array_check (array
, 0))
4417 if (!dim_check (dim
, 1, true))
4420 if (!dim_rank_check (dim
, array
, 0))
4423 if (!kind_check (kind
, 2, BT_INTEGER
))
4425 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4426 "with KIND argument at %L",
4427 gfc_current_intrinsic
, &kind
->where
))
4436 gfc_check_sizeof (gfc_expr
*arg
)
4438 if (arg
->ts
.type
== BT_PROCEDURE
)
4440 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4441 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4446 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4447 if (arg
->ts
.type
== BT_ASSUMED
4448 && (arg
->symtree
->n
.sym
->as
== NULL
4449 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4450 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4451 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4453 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4454 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4459 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4460 && arg
->symtree
->n
.sym
->as
!= NULL
4461 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4462 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4464 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4465 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4466 gfc_current_intrinsic
, &arg
->where
);
4474 /* Check whether an expression is interoperable. When returning false,
4475 msg is set to a string telling why the expression is not interoperable,
4476 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4477 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4478 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4479 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4483 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4487 if (expr
->ts
.type
== BT_CLASS
)
4489 *msg
= "Expression is polymorphic";
4493 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4494 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4496 *msg
= "Expression is a noninteroperable derived type";
4500 if (expr
->ts
.type
== BT_PROCEDURE
)
4502 *msg
= "Procedure unexpected as argument";
4506 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4509 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4510 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4512 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4516 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4517 && expr
->ts
.kind
!= 1)
4519 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4523 if (expr
->ts
.type
== BT_CHARACTER
) {
4524 if (expr
->ts
.deferred
)
4526 /* TS 29113 allows deferred-length strings as dummy arguments,
4527 but it is not an interoperable type. */
4528 *msg
= "Expression shall not be a deferred-length string";
4532 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4533 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4534 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4536 if (!c_loc
&& expr
->ts
.u
.cl
4537 && (!expr
->ts
.u
.cl
->length
4538 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4539 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4541 *msg
= "Type shall have a character length of 1";
4546 /* Note: The following checks are about interoperatable variables, Fortran
4547 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4548 is allowed, e.g. assumed-shape arrays with TS 29113. */
4550 if (gfc_is_coarray (expr
))
4552 *msg
= "Coarrays are not interoperable";
4556 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4558 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4559 if (ar
->type
!= AR_FULL
)
4561 *msg
= "Only whole-arrays are interoperable";
4564 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4565 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4567 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4577 gfc_check_c_sizeof (gfc_expr
*arg
)
4581 if (!is_c_interoperable (arg
, &msg
, false, false))
4583 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4584 "interoperable data entity: %s",
4585 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4590 if (arg
->ts
.type
== BT_ASSUMED
)
4592 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4594 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4599 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4600 && arg
->symtree
->n
.sym
->as
!= NULL
4601 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4602 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4604 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4605 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4606 gfc_current_intrinsic
, &arg
->where
);
4615 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4617 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4618 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4619 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4620 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4622 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4623 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4627 if (!scalar_check (c_ptr_1
, 0))
4631 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4632 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4633 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4634 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4636 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4637 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4638 gfc_typename (&c_ptr_1
->ts
),
4639 gfc_typename (&c_ptr_2
->ts
));
4643 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4651 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4653 symbol_attribute attr
;
4656 if (cptr
->ts
.type
!= BT_DERIVED
4657 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4658 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4660 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4661 "type TYPE(C_PTR)", &cptr
->where
);
4665 if (!scalar_check (cptr
, 0))
4668 attr
= gfc_expr_attr (fptr
);
4672 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4677 if (fptr
->ts
.type
== BT_CLASS
)
4679 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4684 if (gfc_is_coindexed (fptr
))
4686 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4687 "coindexed", &fptr
->where
);
4691 if (fptr
->rank
== 0 && shape
)
4693 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4694 "FPTR", &fptr
->where
);
4697 else if (fptr
->rank
&& !shape
)
4699 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4700 "FPTR at %L", &fptr
->where
);
4704 if (shape
&& !rank_check (shape
, 2, 1))
4707 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4713 if (gfc_array_size (shape
, &size
))
4715 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4718 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4719 "size as the RANK of FPTR", &shape
->where
);
4726 if (fptr
->ts
.type
== BT_CLASS
)
4728 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4732 if (!is_c_interoperable (fptr
, &msg
, false, true))
4733 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4734 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4741 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4743 symbol_attribute attr
;
4745 if (cptr
->ts
.type
!= BT_DERIVED
4746 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4747 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4749 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4750 "type TYPE(C_FUNPTR)", &cptr
->where
);
4754 if (!scalar_check (cptr
, 0))
4757 attr
= gfc_expr_attr (fptr
);
4759 if (!attr
.proc_pointer
)
4761 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4762 "pointer", &fptr
->where
);
4766 if (gfc_is_coindexed (fptr
))
4768 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4769 "coindexed", &fptr
->where
);
4773 if (!attr
.is_bind_c
)
4774 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4775 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4782 gfc_check_c_funloc (gfc_expr
*x
)
4784 symbol_attribute attr
;
4786 if (gfc_is_coindexed (x
))
4788 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4789 "coindexed", &x
->where
);
4793 attr
= gfc_expr_attr (x
);
4795 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4796 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4798 gfc_namespace
*ns
= gfc_current_ns
;
4800 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4801 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4803 gfc_error ("Function result %qs at %L is invalid as X argument "
4804 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4809 if (attr
.flavor
!= FL_PROCEDURE
)
4811 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4812 "or a procedure pointer", &x
->where
);
4816 if (!attr
.is_bind_c
)
4817 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4818 "at %L to C_FUNLOC", &x
->where
);
4824 gfc_check_c_loc (gfc_expr
*x
)
4826 symbol_attribute attr
;
4829 if (gfc_is_coindexed (x
))
4831 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4835 if (x
->ts
.type
== BT_CLASS
)
4837 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4842 attr
= gfc_expr_attr (x
);
4845 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4846 || attr
.flavor
== FL_PARAMETER
))
4848 gfc_error ("Argument X at %L to C_LOC shall have either "
4849 "the POINTER or the TARGET attribute", &x
->where
);
4853 if (x
->ts
.type
== BT_CHARACTER
4854 && gfc_var_strlen (x
) == 0)
4856 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4857 "string", &x
->where
);
4861 if (!is_c_interoperable (x
, &msg
, true, false))
4863 if (x
->ts
.type
== BT_CLASS
)
4865 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4871 && !gfc_notify_std (GFC_STD_F2008_TS
,
4872 "Noninteroperable array at %L as"
4873 " argument to C_LOC: %s", &x
->where
, msg
))
4876 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4878 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4880 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4881 && !attr
.allocatable
4882 && !gfc_notify_std (GFC_STD_F2008
,
4883 "Array of interoperable type at %L "
4884 "to C_LOC which is nonallocatable and neither "
4885 "assumed size nor explicit size", &x
->where
))
4887 else if (ar
->type
!= AR_FULL
4888 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4889 "to C_LOC", &x
->where
))
4898 gfc_check_sleep_sub (gfc_expr
*seconds
)
4900 if (!type_check (seconds
, 0, BT_INTEGER
))
4903 if (!scalar_check (seconds
, 0))
4910 gfc_check_sngl (gfc_expr
*a
)
4912 if (!type_check (a
, 0, BT_REAL
))
4915 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4916 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4917 "REAL argument to %s intrinsic at %L",
4918 gfc_current_intrinsic
, &a
->where
))
4925 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4927 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4929 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4930 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4931 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4939 if (!dim_check (dim
, 1, false))
4942 /* dim_rank_check() does not apply here. */
4944 && dim
->expr_type
== EXPR_CONSTANT
4945 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4946 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4948 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4949 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4950 gfc_current_intrinsic
, &dim
->where
);
4954 if (!type_check (ncopies
, 2, BT_INTEGER
))
4957 if (!scalar_check (ncopies
, 2))
4964 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4968 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4970 if (!type_check (unit
, 0, BT_INTEGER
))
4973 if (!scalar_check (unit
, 0))
4976 if (!type_check (c
, 1, BT_CHARACTER
))
4978 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4984 if (!type_check (status
, 2, BT_INTEGER
)
4985 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4986 || !scalar_check (status
, 2))
4994 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4996 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5001 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5003 if (!type_check (c
, 0, BT_CHARACTER
))
5005 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5011 if (!type_check (status
, 1, BT_INTEGER
)
5012 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5013 || !scalar_check (status
, 1))
5021 gfc_check_fgetput (gfc_expr
*c
)
5023 return gfc_check_fgetput_sub (c
, NULL
);
5028 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5030 if (!type_check (unit
, 0, BT_INTEGER
))
5033 if (!scalar_check (unit
, 0))
5036 if (!type_check (offset
, 1, BT_INTEGER
))
5039 if (!scalar_check (offset
, 1))
5042 if (!type_check (whence
, 2, BT_INTEGER
))
5045 if (!scalar_check (whence
, 2))
5051 if (!type_check (status
, 3, BT_INTEGER
))
5054 if (!kind_value_check (status
, 3, 4))
5057 if (!scalar_check (status
, 3))
5066 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5068 if (!type_check (unit
, 0, BT_INTEGER
))
5071 if (!scalar_check (unit
, 0))
5074 if (!type_check (array
, 1, BT_INTEGER
)
5075 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5078 if (!array_check (array
, 1))
5086 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5088 if (!type_check (unit
, 0, BT_INTEGER
))
5091 if (!scalar_check (unit
, 0))
5094 if (!type_check (array
, 1, BT_INTEGER
)
5095 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5098 if (!array_check (array
, 1))
5104 if (!type_check (status
, 2, BT_INTEGER
)
5105 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5108 if (!scalar_check (status
, 2))
5116 gfc_check_ftell (gfc_expr
*unit
)
5118 if (!type_check (unit
, 0, BT_INTEGER
))
5121 if (!scalar_check (unit
, 0))
5129 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5131 if (!type_check (unit
, 0, BT_INTEGER
))
5134 if (!scalar_check (unit
, 0))
5137 if (!type_check (offset
, 1, BT_INTEGER
))
5140 if (!scalar_check (offset
, 1))
5148 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5150 if (!type_check (name
, 0, BT_CHARACTER
))
5152 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5155 if (!type_check (array
, 1, BT_INTEGER
)
5156 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5159 if (!array_check (array
, 1))
5167 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5169 if (!type_check (name
, 0, BT_CHARACTER
))
5171 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5174 if (!type_check (array
, 1, BT_INTEGER
)
5175 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5178 if (!array_check (array
, 1))
5184 if (!type_check (status
, 2, BT_INTEGER
)
5185 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5188 if (!scalar_check (status
, 2))
5196 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5200 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5202 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5206 if (!coarray_check (coarray
, 0))
5211 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5212 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5216 if (gfc_array_size (sub
, &nelems
))
5218 int corank
= gfc_get_corank (coarray
);
5220 if (mpz_cmp_ui (nelems
, corank
) != 0)
5222 gfc_error ("The number of array elements of the SUB argument to "
5223 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5224 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5236 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5238 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5240 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5246 if (!type_check (distance
, 0, BT_INTEGER
))
5249 if (!nonnegative_check ("DISTANCE", distance
))
5252 if (!scalar_check (distance
, 0))
5255 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5256 "NUM_IMAGES at %L", &distance
->where
))
5262 if (!type_check (failed
, 1, BT_LOGICAL
))
5265 if (!scalar_check (failed
, 1))
5268 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5269 "NUM_IMAGES at %L", &failed
->where
))
5278 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5280 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5282 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5286 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5289 if (dim
!= NULL
&& coarray
== NULL
)
5291 gfc_error ("DIM argument without COARRAY argument not allowed for "
5292 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5296 if (distance
&& (coarray
|| dim
))
5298 gfc_error ("The DISTANCE argument may not be specified together with the "
5299 "COARRAY or DIM argument in intrinsic at %L",
5304 /* Assume that we have "this_image (distance)". */
5305 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5309 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5318 if (!type_check (distance
, 2, BT_INTEGER
))
5321 if (!nonnegative_check ("DISTANCE", distance
))
5324 if (!scalar_check (distance
, 2))
5327 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5328 "THIS_IMAGE at %L", &distance
->where
))
5334 if (!coarray_check (coarray
, 0))
5339 if (!dim_check (dim
, 1, false))
5342 if (!dim_corank_check (dim
, coarray
))
5349 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5350 by gfc_simplify_transfer. Return false if we cannot do so. */
5353 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5354 size_t *source_size
, size_t *result_size
,
5355 size_t *result_length_p
)
5357 size_t result_elt_size
;
5359 if (source
->expr_type
== EXPR_FUNCTION
)
5362 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5365 /* Calculate the size of the source. */
5366 *source_size
= gfc_target_expr_size (source
);
5367 if (*source_size
== 0)
5370 /* Determine the size of the element. */
5371 result_elt_size
= gfc_element_size (mold
);
5372 if (result_elt_size
== 0)
5375 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5380 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5383 result_length
= *source_size
/ result_elt_size
;
5384 if (result_length
* result_elt_size
< *source_size
)
5388 *result_size
= result_length
* result_elt_size
;
5389 if (result_length_p
)
5390 *result_length_p
= result_length
;
5393 *result_size
= result_elt_size
;
5400 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5405 if (mold
->ts
.type
== BT_HOLLERITH
)
5407 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5408 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5414 if (!type_check (size
, 2, BT_INTEGER
))
5417 if (!scalar_check (size
, 2))
5420 if (!nonoptional_check (size
, 2))
5424 if (!warn_surprising
)
5427 /* If we can't calculate the sizes, we cannot check any more.
5428 Return true for that case. */
5430 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5431 &result_size
, NULL
))
5434 if (source_size
< result_size
)
5435 gfc_warning (OPT_Wsurprising
,
5436 "Intrinsic TRANSFER at %L has partly undefined result: "
5437 "source size %ld < result size %ld", &source
->where
,
5438 (long) source_size
, (long) result_size
);
5445 gfc_check_transpose (gfc_expr
*matrix
)
5447 if (!rank_check (matrix
, 0, 2))
5455 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5457 if (!array_check (array
, 0))
5460 if (!dim_check (dim
, 1, false))
5463 if (!dim_rank_check (dim
, array
, 0))
5466 if (!kind_check (kind
, 2, BT_INTEGER
))
5468 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5469 "with KIND argument at %L",
5470 gfc_current_intrinsic
, &kind
->where
))
5478 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5480 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5482 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5486 if (!coarray_check (coarray
, 0))
5491 if (!dim_check (dim
, 1, false))
5494 if (!dim_corank_check (dim
, coarray
))
5498 if (!kind_check (kind
, 2, BT_INTEGER
))
5506 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5510 if (!rank_check (vector
, 0, 1))
5513 if (!array_check (mask
, 1))
5516 if (!type_check (mask
, 1, BT_LOGICAL
))
5519 if (!same_type_check (vector
, 0, field
, 2))
5522 if (mask
->expr_type
== EXPR_ARRAY
5523 && gfc_array_size (vector
, &vector_size
))
5525 int mask_true_count
= 0;
5526 gfc_constructor
*mask_ctor
;
5527 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5530 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5532 mask_true_count
= 0;
5536 if (mask_ctor
->expr
->value
.logical
)
5539 mask_ctor
= gfc_constructor_next (mask_ctor
);
5542 if (mpz_get_si (vector_size
) < mask_true_count
)
5544 gfc_error ("%qs argument of %qs intrinsic at %L must "
5545 "provide at least as many elements as there "
5546 "are .TRUE. values in %qs (%ld/%d)",
5547 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5548 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5549 mpz_get_si (vector_size
), mask_true_count
);
5553 mpz_clear (vector_size
);
5556 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5558 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5559 "the same rank as %qs or be a scalar",
5560 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5561 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5565 if (mask
->rank
== field
->rank
)
5568 for (i
= 0; i
< field
->rank
; i
++)
5569 if (! identical_dimen_shape (mask
, i
, field
, i
))
5571 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5572 "must have identical shape.",
5573 gfc_current_intrinsic_arg
[2]->name
,
5574 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5584 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5586 if (!type_check (x
, 0, BT_CHARACTER
))
5589 if (!same_type_check (x
, 0, y
, 1))
5592 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5595 if (!kind_check (kind
, 3, BT_INTEGER
))
5597 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5598 "with KIND argument at %L",
5599 gfc_current_intrinsic
, &kind
->where
))
5607 gfc_check_trim (gfc_expr
*x
)
5609 if (!type_check (x
, 0, BT_CHARACTER
))
5612 if (!scalar_check (x
, 0))
5620 gfc_check_ttynam (gfc_expr
*unit
)
5622 if (!scalar_check (unit
, 0))
5625 if (!type_check (unit
, 0, BT_INTEGER
))
5632 /************* Check functions for intrinsic subroutines *************/
5635 gfc_check_cpu_time (gfc_expr
*time
)
5637 if (!scalar_check (time
, 0))
5640 if (!type_check (time
, 0, BT_REAL
))
5643 if (!variable_check (time
, 0, false))
5651 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5652 gfc_expr
*zone
, gfc_expr
*values
)
5656 if (!type_check (date
, 0, BT_CHARACTER
))
5658 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5660 if (!scalar_check (date
, 0))
5662 if (!variable_check (date
, 0, false))
5668 if (!type_check (time
, 1, BT_CHARACTER
))
5670 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5672 if (!scalar_check (time
, 1))
5674 if (!variable_check (time
, 1, false))
5680 if (!type_check (zone
, 2, BT_CHARACTER
))
5682 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5684 if (!scalar_check (zone
, 2))
5686 if (!variable_check (zone
, 2, false))
5692 if (!type_check (values
, 3, BT_INTEGER
))
5694 if (!array_check (values
, 3))
5696 if (!rank_check (values
, 3, 1))
5698 if (!variable_check (values
, 3, false))
5707 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5708 gfc_expr
*to
, gfc_expr
*topos
)
5710 if (!type_check (from
, 0, BT_INTEGER
))
5713 if (!type_check (frompos
, 1, BT_INTEGER
))
5716 if (!type_check (len
, 2, BT_INTEGER
))
5719 if (!same_type_check (from
, 0, to
, 3))
5722 if (!variable_check (to
, 3, false))
5725 if (!type_check (topos
, 4, BT_INTEGER
))
5728 if (!nonnegative_check ("frompos", frompos
))
5731 if (!nonnegative_check ("topos", topos
))
5734 if (!nonnegative_check ("len", len
))
5737 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5740 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5748 gfc_check_random_number (gfc_expr
*harvest
)
5750 if (!type_check (harvest
, 0, BT_REAL
))
5753 if (!variable_check (harvest
, 0, false))
5761 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5763 unsigned int nargs
= 0, seed_size
;
5764 locus
*where
= NULL
;
5765 mpz_t put_size
, get_size
;
5767 /* Keep the number of bytes in sync with master_state in
5768 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5769 part of the state too. */
5770 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5774 if (size
->expr_type
!= EXPR_VARIABLE
5775 || !size
->symtree
->n
.sym
->attr
.optional
)
5778 if (!scalar_check (size
, 0))
5781 if (!type_check (size
, 0, BT_INTEGER
))
5784 if (!variable_check (size
, 0, false))
5787 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5793 if (put
->expr_type
!= EXPR_VARIABLE
5794 || !put
->symtree
->n
.sym
->attr
.optional
)
5797 where
= &put
->where
;
5800 if (!array_check (put
, 1))
5803 if (!rank_check (put
, 1, 1))
5806 if (!type_check (put
, 1, BT_INTEGER
))
5809 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5812 if (gfc_array_size (put
, &put_size
)
5813 && mpz_get_ui (put_size
) < seed_size
)
5814 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5815 "too small (%i/%i)",
5816 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5817 where
, (int) mpz_get_ui (put_size
), seed_size
);
5822 if (get
->expr_type
!= EXPR_VARIABLE
5823 || !get
->symtree
->n
.sym
->attr
.optional
)
5826 where
= &get
->where
;
5829 if (!array_check (get
, 2))
5832 if (!rank_check (get
, 2, 1))
5835 if (!type_check (get
, 2, BT_INTEGER
))
5838 if (!variable_check (get
, 2, false))
5841 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5844 if (gfc_array_size (get
, &get_size
)
5845 && mpz_get_ui (get_size
) < seed_size
)
5846 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5847 "too small (%i/%i)",
5848 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5849 where
, (int) mpz_get_ui (get_size
), seed_size
);
5852 /* RANDOM_SEED may not have more than one non-optional argument. */
5854 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5860 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5864 int num_percent
, nargs
;
5867 if (e
->expr_type
!= EXPR_CONSTANT
)
5870 len
= e
->value
.character
.length
;
5871 if (e
->value
.character
.string
[len
-1] != '\0')
5872 gfc_internal_error ("fe_runtime_error string must be null terminated");
5875 for (i
=0; i
<len
-1; i
++)
5876 if (e
->value
.character
.string
[i
] == '%')
5880 for (; a
; a
= a
->next
)
5883 if (nargs
-1 != num_percent
)
5884 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5885 nargs
, num_percent
++);
5891 gfc_check_second_sub (gfc_expr
*time
)
5893 if (!scalar_check (time
, 0))
5896 if (!type_check (time
, 0, BT_REAL
))
5899 if (!kind_value_check (time
, 0, 4))
5906 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5907 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5908 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5909 count_max are all optional arguments */
5912 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5913 gfc_expr
*count_max
)
5917 if (!scalar_check (count
, 0))
5920 if (!type_check (count
, 0, BT_INTEGER
))
5923 if (count
->ts
.kind
!= gfc_default_integer_kind
5924 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5925 "SYSTEM_CLOCK at %L has non-default kind",
5929 if (!variable_check (count
, 0, false))
5933 if (count_rate
!= NULL
)
5935 if (!scalar_check (count_rate
, 1))
5938 if (!variable_check (count_rate
, 1, false))
5941 if (count_rate
->ts
.type
== BT_REAL
)
5943 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5944 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5949 if (!type_check (count_rate
, 1, BT_INTEGER
))
5952 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5953 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5954 "SYSTEM_CLOCK at %L has non-default kind",
5955 &count_rate
->where
))
5961 if (count_max
!= NULL
)
5963 if (!scalar_check (count_max
, 2))
5966 if (!type_check (count_max
, 2, BT_INTEGER
))
5969 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5970 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5971 "SYSTEM_CLOCK at %L has non-default kind",
5975 if (!variable_check (count_max
, 2, false))
5984 gfc_check_irand (gfc_expr
*x
)
5989 if (!scalar_check (x
, 0))
5992 if (!type_check (x
, 0, BT_INTEGER
))
5995 if (!kind_value_check (x
, 0, 4))
6003 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6005 if (!scalar_check (seconds
, 0))
6007 if (!type_check (seconds
, 0, BT_INTEGER
))
6010 if (!int_or_proc_check (handler
, 1))
6012 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6018 if (!scalar_check (status
, 2))
6020 if (!type_check (status
, 2, BT_INTEGER
))
6022 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6030 gfc_check_rand (gfc_expr
*x
)
6035 if (!scalar_check (x
, 0))
6038 if (!type_check (x
, 0, BT_INTEGER
))
6041 if (!kind_value_check (x
, 0, 4))
6049 gfc_check_srand (gfc_expr
*x
)
6051 if (!scalar_check (x
, 0))
6054 if (!type_check (x
, 0, BT_INTEGER
))
6057 if (!kind_value_check (x
, 0, 4))
6065 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6067 if (!scalar_check (time
, 0))
6069 if (!type_check (time
, 0, BT_INTEGER
))
6072 if (!type_check (result
, 1, BT_CHARACTER
))
6074 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6082 gfc_check_dtime_etime (gfc_expr
*x
)
6084 if (!array_check (x
, 0))
6087 if (!rank_check (x
, 0, 1))
6090 if (!variable_check (x
, 0, false))
6093 if (!type_check (x
, 0, BT_REAL
))
6096 if (!kind_value_check (x
, 0, 4))
6104 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6106 if (!array_check (values
, 0))
6109 if (!rank_check (values
, 0, 1))
6112 if (!variable_check (values
, 0, false))
6115 if (!type_check (values
, 0, BT_REAL
))
6118 if (!kind_value_check (values
, 0, 4))
6121 if (!scalar_check (time
, 1))
6124 if (!type_check (time
, 1, BT_REAL
))
6127 if (!kind_value_check (time
, 1, 4))
6135 gfc_check_fdate_sub (gfc_expr
*date
)
6137 if (!type_check (date
, 0, BT_CHARACTER
))
6139 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6147 gfc_check_gerror (gfc_expr
*msg
)
6149 if (!type_check (msg
, 0, BT_CHARACTER
))
6151 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6159 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6161 if (!type_check (cwd
, 0, BT_CHARACTER
))
6163 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6169 if (!scalar_check (status
, 1))
6172 if (!type_check (status
, 1, BT_INTEGER
))
6180 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6182 if (!type_check (pos
, 0, BT_INTEGER
))
6185 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6187 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6188 "not wider than the default kind (%d)",
6189 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6190 &pos
->where
, gfc_default_integer_kind
);
6194 if (!type_check (value
, 1, BT_CHARACTER
))
6196 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6204 gfc_check_getlog (gfc_expr
*msg
)
6206 if (!type_check (msg
, 0, BT_CHARACTER
))
6208 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6216 gfc_check_exit (gfc_expr
*status
)
6221 if (!type_check (status
, 0, BT_INTEGER
))
6224 if (!scalar_check (status
, 0))
6232 gfc_check_flush (gfc_expr
*unit
)
6237 if (!type_check (unit
, 0, BT_INTEGER
))
6240 if (!scalar_check (unit
, 0))
6248 gfc_check_free (gfc_expr
*i
)
6250 if (!type_check (i
, 0, BT_INTEGER
))
6253 if (!scalar_check (i
, 0))
6261 gfc_check_hostnm (gfc_expr
*name
)
6263 if (!type_check (name
, 0, BT_CHARACTER
))
6265 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6273 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6275 if (!type_check (name
, 0, BT_CHARACTER
))
6277 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6283 if (!scalar_check (status
, 1))
6286 if (!type_check (status
, 1, BT_INTEGER
))
6294 gfc_check_itime_idate (gfc_expr
*values
)
6296 if (!array_check (values
, 0))
6299 if (!rank_check (values
, 0, 1))
6302 if (!variable_check (values
, 0, false))
6305 if (!type_check (values
, 0, BT_INTEGER
))
6308 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6316 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6318 if (!type_check (time
, 0, BT_INTEGER
))
6321 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6324 if (!scalar_check (time
, 0))
6327 if (!array_check (values
, 1))
6330 if (!rank_check (values
, 1, 1))
6333 if (!variable_check (values
, 1, false))
6336 if (!type_check (values
, 1, BT_INTEGER
))
6339 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6347 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6349 if (!scalar_check (unit
, 0))
6352 if (!type_check (unit
, 0, BT_INTEGER
))
6355 if (!type_check (name
, 1, BT_CHARACTER
))
6357 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6365 gfc_check_isatty (gfc_expr
*unit
)
6370 if (!type_check (unit
, 0, BT_INTEGER
))
6373 if (!scalar_check (unit
, 0))
6381 gfc_check_isnan (gfc_expr
*x
)
6383 if (!type_check (x
, 0, BT_REAL
))
6391 gfc_check_perror (gfc_expr
*string
)
6393 if (!type_check (string
, 0, BT_CHARACTER
))
6395 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6403 gfc_check_umask (gfc_expr
*mask
)
6405 if (!type_check (mask
, 0, BT_INTEGER
))
6408 if (!scalar_check (mask
, 0))
6416 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6418 if (!type_check (mask
, 0, BT_INTEGER
))
6421 if (!scalar_check (mask
, 0))
6427 if (!scalar_check (old
, 1))
6430 if (!type_check (old
, 1, BT_INTEGER
))
6438 gfc_check_unlink (gfc_expr
*name
)
6440 if (!type_check (name
, 0, BT_CHARACTER
))
6442 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6450 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6452 if (!type_check (name
, 0, BT_CHARACTER
))
6454 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6460 if (!scalar_check (status
, 1))
6463 if (!type_check (status
, 1, BT_INTEGER
))
6471 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6473 if (!scalar_check (number
, 0))
6475 if (!type_check (number
, 0, BT_INTEGER
))
6478 if (!int_or_proc_check (handler
, 1))
6480 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6488 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6490 if (!scalar_check (number
, 0))
6492 if (!type_check (number
, 0, BT_INTEGER
))
6495 if (!int_or_proc_check (handler
, 1))
6497 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6503 if (!type_check (status
, 2, BT_INTEGER
))
6505 if (!scalar_check (status
, 2))
6513 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6515 if (!type_check (cmd
, 0, BT_CHARACTER
))
6517 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6520 if (!scalar_check (status
, 1))
6523 if (!type_check (status
, 1, BT_INTEGER
))
6526 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6533 /* This is used for the GNU intrinsics AND, OR and XOR. */
6535 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6537 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6539 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6540 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6541 gfc_current_intrinsic
, &i
->where
);
6545 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6547 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6548 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6549 gfc_current_intrinsic
, &j
->where
);
6553 if (i
->ts
.type
!= j
->ts
.type
)
6555 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6556 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6557 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6562 if (!scalar_check (i
, 0))
6565 if (!scalar_check (j
, 1))
6573 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6576 if (a
->expr_type
== EXPR_NULL
)
6578 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6579 "argument to STORAGE_SIZE, because it returns a "
6580 "disassociated pointer", &a
->where
);
6584 if (a
->ts
.type
== BT_ASSUMED
)
6586 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6587 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6592 if (a
->ts
.type
== BT_PROCEDURE
)
6594 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6595 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6596 gfc_current_intrinsic
, &a
->where
);
6603 if (!type_check (kind
, 1, BT_INTEGER
))
6606 if (!scalar_check (kind
, 1))
6609 if (kind
->expr_type
!= EXPR_CONSTANT
)
6611 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6612 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,