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. */
3271 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3273 gfc_expr
*a
, *m
, *d
, *k
;
3276 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3280 m
= ap
->next
->next
->expr
;
3281 k
= ap
->next
->next
->next
->expr
;
3283 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3284 && ap
->next
->name
== NULL
)
3288 ap
->next
->expr
= NULL
;
3289 ap
->next
->next
->expr
= m
;
3292 if (!dim_check (d
, 1, false))
3295 if (!dim_rank_check (d
, a
, 0))
3298 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3302 && !gfc_check_conformance (a
, m
,
3303 "arguments '%s' and '%s' for intrinsic %s",
3304 gfc_current_intrinsic_arg
[0]->name
,
3305 gfc_current_intrinsic_arg
[2]->name
,
3306 gfc_current_intrinsic
))
3309 if (!kind_check (k
, 1, BT_INTEGER
))
3316 /* Similar to minloc/maxloc, the argument list might need to be
3317 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3318 difference is that MINLOC/MAXLOC take an additional KIND argument.
3319 The possibilities are:
3325 NULL MASK minval(array, mask=m)
3328 I.e. in the case of minval(array,mask), mask will be in the second
3329 position of the argument list and we'll have to fix that up. */
3332 check_reduction (gfc_actual_arglist
*ap
)
3334 gfc_expr
*a
, *m
, *d
;
3338 m
= ap
->next
->next
->expr
;
3340 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3341 && ap
->next
->name
== NULL
)
3345 ap
->next
->expr
= NULL
;
3346 ap
->next
->next
->expr
= m
;
3349 if (!dim_check (d
, 1, false))
3352 if (!dim_rank_check (d
, a
, 0))
3355 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3359 && !gfc_check_conformance (a
, m
,
3360 "arguments '%s' and '%s' for intrinsic %s",
3361 gfc_current_intrinsic_arg
[0]->name
,
3362 gfc_current_intrinsic_arg
[2]->name
,
3363 gfc_current_intrinsic
))
3371 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3373 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
3374 || !array_check (ap
->expr
, 0))
3377 return check_reduction (ap
);
3382 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3384 if (!numeric_check (ap
->expr
, 0)
3385 || !array_check (ap
->expr
, 0))
3388 return check_reduction (ap
);
3392 /* For IANY, IALL and IPARITY. */
3395 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3399 if (!type_check (i
, 0, BT_INTEGER
))
3402 if (!nonnegative_check ("I", i
))
3405 if (!kind_check (kind
, 1, BT_INTEGER
))
3409 gfc_extract_int (kind
, &k
);
3411 k
= gfc_default_integer_kind
;
3413 if (!less_than_bitsizekind ("I", i
, k
))
3421 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3423 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3425 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3426 gfc_current_intrinsic_arg
[0]->name
,
3427 gfc_current_intrinsic
, &ap
->expr
->where
);
3431 if (!array_check (ap
->expr
, 0))
3434 return check_reduction (ap
);
3439 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3441 if (!same_type_check (tsource
, 0, fsource
, 1))
3444 if (!type_check (mask
, 2, BT_LOGICAL
))
3447 if (tsource
->ts
.type
== BT_CHARACTER
)
3448 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3455 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3457 if (!type_check (i
, 0, BT_INTEGER
))
3460 if (!type_check (j
, 1, BT_INTEGER
))
3463 if (!type_check (mask
, 2, BT_INTEGER
))
3466 if (!same_type_check (i
, 0, j
, 1))
3469 if (!same_type_check (i
, 0, mask
, 2))
3477 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3479 if (!variable_check (from
, 0, false))
3481 if (!allocatable_check (from
, 0))
3483 if (gfc_is_coindexed (from
))
3485 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3486 "coindexed", &from
->where
);
3490 if (!variable_check (to
, 1, false))
3492 if (!allocatable_check (to
, 1))
3494 if (gfc_is_coindexed (to
))
3496 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3497 "coindexed", &to
->where
);
3501 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3503 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3504 "polymorphic if FROM is polymorphic",
3509 if (!same_type_check (to
, 1, from
, 0))
3512 if (to
->rank
!= from
->rank
)
3514 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3515 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3520 /* IR F08/0040; cf. 12-006A. */
3521 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3523 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3524 "must have the same corank %d/%d", &to
->where
,
3525 gfc_get_corank (from
), gfc_get_corank (to
));
3529 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3530 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3531 and cmp2 are allocatable. After the allocation is transferred,
3532 the 'to' chain is broken by the nullification of the 'from'. A bit
3533 of reflection reveals that this can only occur for derived types
3534 with recursive allocatable components. */
3535 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3536 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3538 gfc_ref
*to_ref
, *from_ref
;
3540 from_ref
= from
->ref
;
3541 bool aliasing
= true;
3543 for (; from_ref
&& to_ref
;
3544 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3546 if (to_ref
->type
!= from
->ref
->type
)
3548 else if (to_ref
->type
== REF_ARRAY
3549 && to_ref
->u
.ar
.type
!= AR_FULL
3550 && from_ref
->u
.ar
.type
!= AR_FULL
)
3551 /* Play safe; assume sections and elements are different. */
3553 else if (to_ref
->type
== REF_COMPONENT
3554 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3563 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3564 "restrictions (F2003 12.4.1.7)", &to
->where
);
3569 /* CLASS arguments: Make sure the vtab of from is present. */
3570 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3571 gfc_find_vtab (&from
->ts
);
3578 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3580 if (!type_check (x
, 0, BT_REAL
))
3583 if (!type_check (s
, 1, BT_REAL
))
3586 if (s
->expr_type
== EXPR_CONSTANT
)
3588 if (mpfr_sgn (s
->value
.real
) == 0)
3590 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3601 gfc_check_new_line (gfc_expr
*a
)
3603 if (!type_check (a
, 0, BT_CHARACTER
))
3611 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3613 if (!type_check (array
, 0, BT_REAL
))
3616 if (!array_check (array
, 0))
3619 if (!dim_rank_check (dim
, array
, false))
3626 gfc_check_null (gfc_expr
*mold
)
3628 symbol_attribute attr
;
3633 if (!variable_check (mold
, 0, true))
3636 attr
= gfc_variable_attr (mold
, NULL
);
3638 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3640 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3641 "ALLOCATABLE or procedure pointer",
3642 gfc_current_intrinsic_arg
[0]->name
,
3643 gfc_current_intrinsic
, &mold
->where
);
3647 if (attr
.allocatable
3648 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3649 "allocatable MOLD at %L", &mold
->where
))
3653 if (gfc_is_coindexed (mold
))
3655 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3656 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3657 gfc_current_intrinsic
, &mold
->where
);
3666 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3668 if (!array_check (array
, 0))
3671 if (!type_check (mask
, 1, BT_LOGICAL
))
3674 if (!gfc_check_conformance (array
, mask
,
3675 "arguments '%s' and '%s' for intrinsic '%s'",
3676 gfc_current_intrinsic_arg
[0]->name
,
3677 gfc_current_intrinsic_arg
[1]->name
,
3678 gfc_current_intrinsic
))
3683 mpz_t array_size
, vector_size
;
3684 bool have_array_size
, have_vector_size
;
3686 if (!same_type_check (array
, 0, vector
, 2))
3689 if (!rank_check (vector
, 2, 1))
3692 /* VECTOR requires at least as many elements as MASK
3693 has .TRUE. values. */
3694 have_array_size
= gfc_array_size(array
, &array_size
);
3695 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3697 if (have_vector_size
3698 && (mask
->expr_type
== EXPR_ARRAY
3699 || (mask
->expr_type
== EXPR_CONSTANT
3700 && have_array_size
)))
3702 int mask_true_values
= 0;
3704 if (mask
->expr_type
== EXPR_ARRAY
)
3706 gfc_constructor
*mask_ctor
;
3707 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3710 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3712 mask_true_values
= 0;
3716 if (mask_ctor
->expr
->value
.logical
)
3719 mask_ctor
= gfc_constructor_next (mask_ctor
);
3722 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3723 mask_true_values
= mpz_get_si (array_size
);
3725 if (mpz_get_si (vector_size
) < mask_true_values
)
3727 gfc_error ("%qs argument of %qs intrinsic at %L must "
3728 "provide at least as many elements as there "
3729 "are .TRUE. values in %qs (%ld/%d)",
3730 gfc_current_intrinsic_arg
[2]->name
,
3731 gfc_current_intrinsic
, &vector
->where
,
3732 gfc_current_intrinsic_arg
[1]->name
,
3733 mpz_get_si (vector_size
), mask_true_values
);
3738 if (have_array_size
)
3739 mpz_clear (array_size
);
3740 if (have_vector_size
)
3741 mpz_clear (vector_size
);
3749 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3751 if (!type_check (mask
, 0, BT_LOGICAL
))
3754 if (!array_check (mask
, 0))
3757 if (!dim_rank_check (dim
, mask
, false))
3765 gfc_check_precision (gfc_expr
*x
)
3767 if (!real_or_complex_check (x
, 0))
3775 gfc_check_present (gfc_expr
*a
)
3779 if (!variable_check (a
, 0, true))
3782 sym
= a
->symtree
->n
.sym
;
3783 if (!sym
->attr
.dummy
)
3785 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3786 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3787 gfc_current_intrinsic
, &a
->where
);
3791 if (!sym
->attr
.optional
)
3793 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3794 "an OPTIONAL dummy variable",
3795 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3800 /* 13.14.82 PRESENT(A)
3802 Argument. A shall be the name of an optional dummy argument that is
3803 accessible in the subprogram in which the PRESENT function reference
3807 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3808 && (a
->ref
->u
.ar
.type
== AR_FULL
3809 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3810 && a
->ref
->u
.ar
.as
->rank
== 0))))
3812 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3813 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3814 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3823 gfc_check_radix (gfc_expr
*x
)
3825 if (!int_or_real_check (x
, 0))
3833 gfc_check_range (gfc_expr
*x
)
3835 if (!numeric_check (x
, 0))
3843 gfc_check_rank (gfc_expr
*a
)
3845 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3846 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3848 bool is_variable
= true;
3850 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3851 if (a
->expr_type
== EXPR_FUNCTION
)
3852 is_variable
= a
->value
.function
.esym
3853 ? a
->value
.function
.esym
->result
->attr
.pointer
3854 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3856 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3857 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3860 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3861 "object", &a
->where
);
3869 /* real, float, sngl. */
3871 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3873 if (!numeric_check (a
, 0))
3876 if (!kind_check (kind
, 1, BT_REAL
))
3884 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3886 if (!type_check (path1
, 0, BT_CHARACTER
))
3888 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3891 if (!type_check (path2
, 1, BT_CHARACTER
))
3893 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3901 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3903 if (!type_check (path1
, 0, BT_CHARACTER
))
3905 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3908 if (!type_check (path2
, 1, BT_CHARACTER
))
3910 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3916 if (!type_check (status
, 2, BT_INTEGER
))
3919 if (!scalar_check (status
, 2))
3927 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3929 if (!type_check (x
, 0, BT_CHARACTER
))
3932 if (!scalar_check (x
, 0))
3935 if (!type_check (y
, 0, BT_INTEGER
))
3938 if (!scalar_check (y
, 1))
3946 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3947 gfc_expr
*pad
, gfc_expr
*order
)
3953 if (!array_check (source
, 0))
3956 if (!rank_check (shape
, 1, 1))
3959 if (!type_check (shape
, 1, BT_INTEGER
))
3962 if (!gfc_array_size (shape
, &size
))
3964 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3965 "array of constant size", &shape
->where
);
3969 shape_size
= mpz_get_ui (size
);
3972 if (shape_size
<= 0)
3974 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3975 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3979 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3981 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
3982 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3985 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3989 for (i
= 0; i
< shape_size
; ++i
)
3991 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3992 if (e
->expr_type
!= EXPR_CONSTANT
)
3995 gfc_extract_int (e
, &extent
);
3998 gfc_error ("%qs argument of %qs intrinsic at %L has "
3999 "negative element (%d)",
4000 gfc_current_intrinsic_arg
[1]->name
,
4001 gfc_current_intrinsic
, &e
->where
, extent
);
4006 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4007 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4008 && shape
->ref
->u
.ar
.as
4009 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4010 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4011 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4012 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4013 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4018 v
= shape
->symtree
->n
.sym
->value
;
4020 for (i
= 0; i
< shape_size
; i
++)
4022 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4026 gfc_extract_int (e
, &extent
);
4030 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4031 "cannot be negative", i
+ 1, &shape
->where
);
4039 if (!same_type_check (source
, 0, pad
, 2))
4042 if (!array_check (pad
, 2))
4048 if (!array_check (order
, 3))
4051 if (!type_check (order
, 3, BT_INTEGER
))
4054 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4056 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4059 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4062 gfc_array_size (order
, &size
);
4063 order_size
= mpz_get_ui (size
);
4066 if (order_size
!= shape_size
)
4068 gfc_error ("%qs argument of %qs intrinsic at %L "
4069 "has wrong number of elements (%d/%d)",
4070 gfc_current_intrinsic_arg
[3]->name
,
4071 gfc_current_intrinsic
, &order
->where
,
4072 order_size
, shape_size
);
4076 for (i
= 1; i
<= order_size
; ++i
)
4078 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4079 if (e
->expr_type
!= EXPR_CONSTANT
)
4082 gfc_extract_int (e
, &dim
);
4084 if (dim
< 1 || dim
> order_size
)
4086 gfc_error ("%qs argument of %qs intrinsic at %L "
4087 "has out-of-range dimension (%d)",
4088 gfc_current_intrinsic_arg
[3]->name
,
4089 gfc_current_intrinsic
, &e
->where
, dim
);
4093 if (perm
[dim
-1] != 0)
4095 gfc_error ("%qs argument of %qs intrinsic at %L has "
4096 "invalid permutation of dimensions (dimension "
4098 gfc_current_intrinsic_arg
[3]->name
,
4099 gfc_current_intrinsic
, &e
->where
, dim
);
4108 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4109 && gfc_is_constant_expr (shape
)
4110 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4111 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4113 /* Check the match in size between source and destination. */
4114 if (gfc_array_size (source
, &nelems
))
4120 mpz_init_set_ui (size
, 1);
4121 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4122 c
; c
= gfc_constructor_next (c
))
4123 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4125 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4131 gfc_error ("Without padding, there are not enough elements "
4132 "in the intrinsic RESHAPE source at %L to match "
4133 "the shape", &source
->where
);
4144 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4146 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4148 gfc_error ("%qs argument of %qs intrinsic at %L "
4149 "cannot be of type %s",
4150 gfc_current_intrinsic_arg
[0]->name
,
4151 gfc_current_intrinsic
,
4152 &a
->where
, gfc_typename (&a
->ts
));
4156 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4158 gfc_error ("%qs argument of %qs intrinsic at %L "
4159 "must be of an extensible type",
4160 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4165 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4167 gfc_error ("%qs argument of %qs intrinsic at %L "
4168 "cannot be of type %s",
4169 gfc_current_intrinsic_arg
[0]->name
,
4170 gfc_current_intrinsic
,
4171 &b
->where
, gfc_typename (&b
->ts
));
4175 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4177 gfc_error ("%qs argument of %qs intrinsic at %L "
4178 "must be of an extensible type",
4179 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4189 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4191 if (!type_check (x
, 0, BT_REAL
))
4194 if (!type_check (i
, 1, BT_INTEGER
))
4202 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4204 if (!type_check (x
, 0, BT_CHARACTER
))
4207 if (!type_check (y
, 1, BT_CHARACTER
))
4210 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4213 if (!kind_check (kind
, 3, BT_INTEGER
))
4215 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4216 "with KIND argument at %L",
4217 gfc_current_intrinsic
, &kind
->where
))
4220 if (!same_type_check (x
, 0, y
, 1))
4228 gfc_check_secnds (gfc_expr
*r
)
4230 if (!type_check (r
, 0, BT_REAL
))
4233 if (!kind_value_check (r
, 0, 4))
4236 if (!scalar_check (r
, 0))
4244 gfc_check_selected_char_kind (gfc_expr
*name
)
4246 if (!type_check (name
, 0, BT_CHARACTER
))
4249 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4252 if (!scalar_check (name
, 0))
4260 gfc_check_selected_int_kind (gfc_expr
*r
)
4262 if (!type_check (r
, 0, BT_INTEGER
))
4265 if (!scalar_check (r
, 0))
4273 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4275 if (p
== NULL
&& r
== NULL
4276 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4277 " neither %<P%> nor %<R%> argument at %L",
4278 gfc_current_intrinsic_where
))
4283 if (!type_check (p
, 0, BT_INTEGER
))
4286 if (!scalar_check (p
, 0))
4292 if (!type_check (r
, 1, BT_INTEGER
))
4295 if (!scalar_check (r
, 1))
4301 if (!type_check (radix
, 1, BT_INTEGER
))
4304 if (!scalar_check (radix
, 1))
4307 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4308 "RADIX argument at %L", gfc_current_intrinsic
,
4318 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4320 if (!type_check (x
, 0, BT_REAL
))
4323 if (!type_check (i
, 1, BT_INTEGER
))
4331 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4335 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4338 ar
= gfc_find_array_ref (source
);
4340 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4342 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4343 "an assumed size array", &source
->where
);
4347 if (!kind_check (kind
, 1, BT_INTEGER
))
4349 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4350 "with KIND argument at %L",
4351 gfc_current_intrinsic
, &kind
->where
))
4359 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4361 if (!type_check (i
, 0, BT_INTEGER
))
4364 if (!type_check (shift
, 0, BT_INTEGER
))
4367 if (!nonnegative_check ("SHIFT", shift
))
4370 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4378 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4380 if (!int_or_real_check (a
, 0))
4383 if (!same_type_check (a
, 0, b
, 1))
4391 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4393 if (!array_check (array
, 0))
4396 if (!dim_check (dim
, 1, true))
4399 if (!dim_rank_check (dim
, array
, 0))
4402 if (!kind_check (kind
, 2, BT_INTEGER
))
4404 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4405 "with KIND argument at %L",
4406 gfc_current_intrinsic
, &kind
->where
))
4415 gfc_check_sizeof (gfc_expr
*arg
)
4417 if (arg
->ts
.type
== BT_PROCEDURE
)
4419 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4420 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4425 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4426 if (arg
->ts
.type
== BT_ASSUMED
4427 && (arg
->symtree
->n
.sym
->as
== NULL
4428 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4429 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4430 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4432 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4433 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4438 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4439 && arg
->symtree
->n
.sym
->as
!= NULL
4440 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4441 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4443 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4444 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4445 gfc_current_intrinsic
, &arg
->where
);
4453 /* Check whether an expression is interoperable. When returning false,
4454 msg is set to a string telling why the expression is not interoperable,
4455 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4456 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4457 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4458 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4462 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4466 if (expr
->ts
.type
== BT_CLASS
)
4468 *msg
= "Expression is polymorphic";
4472 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4473 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4475 *msg
= "Expression is a noninteroperable derived type";
4479 if (expr
->ts
.type
== BT_PROCEDURE
)
4481 *msg
= "Procedure unexpected as argument";
4485 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4488 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4489 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4491 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4495 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4496 && expr
->ts
.kind
!= 1)
4498 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4502 if (expr
->ts
.type
== BT_CHARACTER
) {
4503 if (expr
->ts
.deferred
)
4505 /* TS 29113 allows deferred-length strings as dummy arguments,
4506 but it is not an interoperable type. */
4507 *msg
= "Expression shall not be a deferred-length string";
4511 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4512 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4513 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4515 if (!c_loc
&& expr
->ts
.u
.cl
4516 && (!expr
->ts
.u
.cl
->length
4517 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4518 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4520 *msg
= "Type shall have a character length of 1";
4525 /* Note: The following checks are about interoperatable variables, Fortran
4526 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4527 is allowed, e.g. assumed-shape arrays with TS 29113. */
4529 if (gfc_is_coarray (expr
))
4531 *msg
= "Coarrays are not interoperable";
4535 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4537 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4538 if (ar
->type
!= AR_FULL
)
4540 *msg
= "Only whole-arrays are interoperable";
4543 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4544 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4546 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4556 gfc_check_c_sizeof (gfc_expr
*arg
)
4560 if (!is_c_interoperable (arg
, &msg
, false, false))
4562 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4563 "interoperable data entity: %s",
4564 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4569 if (arg
->ts
.type
== BT_ASSUMED
)
4571 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4573 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4578 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4579 && arg
->symtree
->n
.sym
->as
!= NULL
4580 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4581 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4583 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4584 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4585 gfc_current_intrinsic
, &arg
->where
);
4594 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4596 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4597 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4598 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4599 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4601 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4602 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4606 if (!scalar_check (c_ptr_1
, 0))
4610 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4611 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4612 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4613 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4615 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4616 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4617 gfc_typename (&c_ptr_1
->ts
),
4618 gfc_typename (&c_ptr_2
->ts
));
4622 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4630 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4632 symbol_attribute attr
;
4635 if (cptr
->ts
.type
!= BT_DERIVED
4636 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4637 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4639 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4640 "type TYPE(C_PTR)", &cptr
->where
);
4644 if (!scalar_check (cptr
, 0))
4647 attr
= gfc_expr_attr (fptr
);
4651 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4656 if (fptr
->ts
.type
== BT_CLASS
)
4658 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4663 if (gfc_is_coindexed (fptr
))
4665 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4666 "coindexed", &fptr
->where
);
4670 if (fptr
->rank
== 0 && shape
)
4672 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4673 "FPTR", &fptr
->where
);
4676 else if (fptr
->rank
&& !shape
)
4678 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4679 "FPTR at %L", &fptr
->where
);
4683 if (shape
&& !rank_check (shape
, 2, 1))
4686 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4692 if (gfc_array_size (shape
, &size
))
4694 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4697 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4698 "size as the RANK of FPTR", &shape
->where
);
4705 if (fptr
->ts
.type
== BT_CLASS
)
4707 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4711 if (!is_c_interoperable (fptr
, &msg
, false, true))
4712 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4713 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4720 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4722 symbol_attribute attr
;
4724 if (cptr
->ts
.type
!= BT_DERIVED
4725 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4726 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4728 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4729 "type TYPE(C_FUNPTR)", &cptr
->where
);
4733 if (!scalar_check (cptr
, 0))
4736 attr
= gfc_expr_attr (fptr
);
4738 if (!attr
.proc_pointer
)
4740 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4741 "pointer", &fptr
->where
);
4745 if (gfc_is_coindexed (fptr
))
4747 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4748 "coindexed", &fptr
->where
);
4752 if (!attr
.is_bind_c
)
4753 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4754 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4761 gfc_check_c_funloc (gfc_expr
*x
)
4763 symbol_attribute attr
;
4765 if (gfc_is_coindexed (x
))
4767 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4768 "coindexed", &x
->where
);
4772 attr
= gfc_expr_attr (x
);
4774 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4775 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4777 gfc_namespace
*ns
= gfc_current_ns
;
4779 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4780 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4782 gfc_error ("Function result %qs at %L is invalid as X argument "
4783 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4788 if (attr
.flavor
!= FL_PROCEDURE
)
4790 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4791 "or a procedure pointer", &x
->where
);
4795 if (!attr
.is_bind_c
)
4796 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4797 "at %L to C_FUNLOC", &x
->where
);
4803 gfc_check_c_loc (gfc_expr
*x
)
4805 symbol_attribute attr
;
4808 if (gfc_is_coindexed (x
))
4810 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4814 if (x
->ts
.type
== BT_CLASS
)
4816 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4821 attr
= gfc_expr_attr (x
);
4824 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4825 || attr
.flavor
== FL_PARAMETER
))
4827 gfc_error ("Argument X at %L to C_LOC shall have either "
4828 "the POINTER or the TARGET attribute", &x
->where
);
4832 if (x
->ts
.type
== BT_CHARACTER
4833 && gfc_var_strlen (x
) == 0)
4835 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4836 "string", &x
->where
);
4840 if (!is_c_interoperable (x
, &msg
, true, false))
4842 if (x
->ts
.type
== BT_CLASS
)
4844 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4850 && !gfc_notify_std (GFC_STD_F2008_TS
,
4851 "Noninteroperable array at %L as"
4852 " argument to C_LOC: %s", &x
->where
, msg
))
4855 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4857 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4859 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4860 && !attr
.allocatable
4861 && !gfc_notify_std (GFC_STD_F2008
,
4862 "Array of interoperable type at %L "
4863 "to C_LOC which is nonallocatable and neither "
4864 "assumed size nor explicit size", &x
->where
))
4866 else if (ar
->type
!= AR_FULL
4867 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4868 "to C_LOC", &x
->where
))
4877 gfc_check_sleep_sub (gfc_expr
*seconds
)
4879 if (!type_check (seconds
, 0, BT_INTEGER
))
4882 if (!scalar_check (seconds
, 0))
4889 gfc_check_sngl (gfc_expr
*a
)
4891 if (!type_check (a
, 0, BT_REAL
))
4894 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4895 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4896 "REAL argument to %s intrinsic at %L",
4897 gfc_current_intrinsic
, &a
->where
))
4904 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4906 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4908 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4909 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4910 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4918 if (!dim_check (dim
, 1, false))
4921 /* dim_rank_check() does not apply here. */
4923 && dim
->expr_type
== EXPR_CONSTANT
4924 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4925 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4927 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4928 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4929 gfc_current_intrinsic
, &dim
->where
);
4933 if (!type_check (ncopies
, 2, BT_INTEGER
))
4936 if (!scalar_check (ncopies
, 2))
4943 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4947 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4949 if (!type_check (unit
, 0, BT_INTEGER
))
4952 if (!scalar_check (unit
, 0))
4955 if (!type_check (c
, 1, BT_CHARACTER
))
4957 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4963 if (!type_check (status
, 2, BT_INTEGER
)
4964 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4965 || !scalar_check (status
, 2))
4973 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4975 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4980 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4982 if (!type_check (c
, 0, BT_CHARACTER
))
4984 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4990 if (!type_check (status
, 1, BT_INTEGER
)
4991 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4992 || !scalar_check (status
, 1))
5000 gfc_check_fgetput (gfc_expr
*c
)
5002 return gfc_check_fgetput_sub (c
, NULL
);
5007 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5009 if (!type_check (unit
, 0, BT_INTEGER
))
5012 if (!scalar_check (unit
, 0))
5015 if (!type_check (offset
, 1, BT_INTEGER
))
5018 if (!scalar_check (offset
, 1))
5021 if (!type_check (whence
, 2, BT_INTEGER
))
5024 if (!scalar_check (whence
, 2))
5030 if (!type_check (status
, 3, BT_INTEGER
))
5033 if (!kind_value_check (status
, 3, 4))
5036 if (!scalar_check (status
, 3))
5045 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5047 if (!type_check (unit
, 0, BT_INTEGER
))
5050 if (!scalar_check (unit
, 0))
5053 if (!type_check (array
, 1, BT_INTEGER
)
5054 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5057 if (!array_check (array
, 1))
5065 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5067 if (!type_check (unit
, 0, BT_INTEGER
))
5070 if (!scalar_check (unit
, 0))
5073 if (!type_check (array
, 1, BT_INTEGER
)
5074 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5077 if (!array_check (array
, 1))
5083 if (!type_check (status
, 2, BT_INTEGER
)
5084 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5087 if (!scalar_check (status
, 2))
5095 gfc_check_ftell (gfc_expr
*unit
)
5097 if (!type_check (unit
, 0, BT_INTEGER
))
5100 if (!scalar_check (unit
, 0))
5108 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5110 if (!type_check (unit
, 0, BT_INTEGER
))
5113 if (!scalar_check (unit
, 0))
5116 if (!type_check (offset
, 1, BT_INTEGER
))
5119 if (!scalar_check (offset
, 1))
5127 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5129 if (!type_check (name
, 0, BT_CHARACTER
))
5131 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5134 if (!type_check (array
, 1, BT_INTEGER
)
5135 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5138 if (!array_check (array
, 1))
5146 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5148 if (!type_check (name
, 0, BT_CHARACTER
))
5150 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5153 if (!type_check (array
, 1, BT_INTEGER
)
5154 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5157 if (!array_check (array
, 1))
5163 if (!type_check (status
, 2, BT_INTEGER
)
5164 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5167 if (!scalar_check (status
, 2))
5175 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5179 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5181 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5185 if (!coarray_check (coarray
, 0))
5190 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5191 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5195 if (gfc_array_size (sub
, &nelems
))
5197 int corank
= gfc_get_corank (coarray
);
5199 if (mpz_cmp_ui (nelems
, corank
) != 0)
5201 gfc_error ("The number of array elements of the SUB argument to "
5202 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5203 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5215 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5217 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5219 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5225 if (!type_check (distance
, 0, BT_INTEGER
))
5228 if (!nonnegative_check ("DISTANCE", distance
))
5231 if (!scalar_check (distance
, 0))
5234 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5235 "NUM_IMAGES at %L", &distance
->where
))
5241 if (!type_check (failed
, 1, BT_LOGICAL
))
5244 if (!scalar_check (failed
, 1))
5247 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5248 "NUM_IMAGES at %L", &failed
->where
))
5257 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5259 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5261 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5265 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5268 if (dim
!= NULL
&& coarray
== NULL
)
5270 gfc_error ("DIM argument without COARRAY argument not allowed for "
5271 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5275 if (distance
&& (coarray
|| dim
))
5277 gfc_error ("The DISTANCE argument may not be specified together with the "
5278 "COARRAY or DIM argument in intrinsic at %L",
5283 /* Assume that we have "this_image (distance)". */
5284 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5288 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5297 if (!type_check (distance
, 2, BT_INTEGER
))
5300 if (!nonnegative_check ("DISTANCE", distance
))
5303 if (!scalar_check (distance
, 2))
5306 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5307 "THIS_IMAGE at %L", &distance
->where
))
5313 if (!coarray_check (coarray
, 0))
5318 if (!dim_check (dim
, 1, false))
5321 if (!dim_corank_check (dim
, coarray
))
5328 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5329 by gfc_simplify_transfer. Return false if we cannot do so. */
5332 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5333 size_t *source_size
, size_t *result_size
,
5334 size_t *result_length_p
)
5336 size_t result_elt_size
;
5338 if (source
->expr_type
== EXPR_FUNCTION
)
5341 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5344 /* Calculate the size of the source. */
5345 *source_size
= gfc_target_expr_size (source
);
5346 if (*source_size
== 0)
5349 /* Determine the size of the element. */
5350 result_elt_size
= gfc_element_size (mold
);
5351 if (result_elt_size
== 0)
5354 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5359 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5362 result_length
= *source_size
/ result_elt_size
;
5363 if (result_length
* result_elt_size
< *source_size
)
5367 *result_size
= result_length
* result_elt_size
;
5368 if (result_length_p
)
5369 *result_length_p
= result_length
;
5372 *result_size
= result_elt_size
;
5379 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5384 if (mold
->ts
.type
== BT_HOLLERITH
)
5386 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5387 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5393 if (!type_check (size
, 2, BT_INTEGER
))
5396 if (!scalar_check (size
, 2))
5399 if (!nonoptional_check (size
, 2))
5403 if (!warn_surprising
)
5406 /* If we can't calculate the sizes, we cannot check any more.
5407 Return true for that case. */
5409 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5410 &result_size
, NULL
))
5413 if (source_size
< result_size
)
5414 gfc_warning (OPT_Wsurprising
,
5415 "Intrinsic TRANSFER at %L has partly undefined result: "
5416 "source size %ld < result size %ld", &source
->where
,
5417 (long) source_size
, (long) result_size
);
5424 gfc_check_transpose (gfc_expr
*matrix
)
5426 if (!rank_check (matrix
, 0, 2))
5434 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5436 if (!array_check (array
, 0))
5439 if (!dim_check (dim
, 1, false))
5442 if (!dim_rank_check (dim
, array
, 0))
5445 if (!kind_check (kind
, 2, BT_INTEGER
))
5447 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5448 "with KIND argument at %L",
5449 gfc_current_intrinsic
, &kind
->where
))
5457 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5459 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5461 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5465 if (!coarray_check (coarray
, 0))
5470 if (!dim_check (dim
, 1, false))
5473 if (!dim_corank_check (dim
, coarray
))
5477 if (!kind_check (kind
, 2, BT_INTEGER
))
5485 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5489 if (!rank_check (vector
, 0, 1))
5492 if (!array_check (mask
, 1))
5495 if (!type_check (mask
, 1, BT_LOGICAL
))
5498 if (!same_type_check (vector
, 0, field
, 2))
5501 if (mask
->expr_type
== EXPR_ARRAY
5502 && gfc_array_size (vector
, &vector_size
))
5504 int mask_true_count
= 0;
5505 gfc_constructor
*mask_ctor
;
5506 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5509 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5511 mask_true_count
= 0;
5515 if (mask_ctor
->expr
->value
.logical
)
5518 mask_ctor
= gfc_constructor_next (mask_ctor
);
5521 if (mpz_get_si (vector_size
) < mask_true_count
)
5523 gfc_error ("%qs argument of %qs intrinsic at %L must "
5524 "provide at least as many elements as there "
5525 "are .TRUE. values in %qs (%ld/%d)",
5526 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5527 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5528 mpz_get_si (vector_size
), mask_true_count
);
5532 mpz_clear (vector_size
);
5535 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5537 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5538 "the same rank as %qs or be a scalar",
5539 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5540 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5544 if (mask
->rank
== field
->rank
)
5547 for (i
= 0; i
< field
->rank
; i
++)
5548 if (! identical_dimen_shape (mask
, i
, field
, i
))
5550 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5551 "must have identical shape.",
5552 gfc_current_intrinsic_arg
[2]->name
,
5553 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5563 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5565 if (!type_check (x
, 0, BT_CHARACTER
))
5568 if (!same_type_check (x
, 0, y
, 1))
5571 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5574 if (!kind_check (kind
, 3, BT_INTEGER
))
5576 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5577 "with KIND argument at %L",
5578 gfc_current_intrinsic
, &kind
->where
))
5586 gfc_check_trim (gfc_expr
*x
)
5588 if (!type_check (x
, 0, BT_CHARACTER
))
5591 if (!scalar_check (x
, 0))
5599 gfc_check_ttynam (gfc_expr
*unit
)
5601 if (!scalar_check (unit
, 0))
5604 if (!type_check (unit
, 0, BT_INTEGER
))
5611 /************* Check functions for intrinsic subroutines *************/
5614 gfc_check_cpu_time (gfc_expr
*time
)
5616 if (!scalar_check (time
, 0))
5619 if (!type_check (time
, 0, BT_REAL
))
5622 if (!variable_check (time
, 0, false))
5630 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5631 gfc_expr
*zone
, gfc_expr
*values
)
5635 if (!type_check (date
, 0, BT_CHARACTER
))
5637 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5639 if (!scalar_check (date
, 0))
5641 if (!variable_check (date
, 0, false))
5647 if (!type_check (time
, 1, BT_CHARACTER
))
5649 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5651 if (!scalar_check (time
, 1))
5653 if (!variable_check (time
, 1, false))
5659 if (!type_check (zone
, 2, BT_CHARACTER
))
5661 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5663 if (!scalar_check (zone
, 2))
5665 if (!variable_check (zone
, 2, false))
5671 if (!type_check (values
, 3, BT_INTEGER
))
5673 if (!array_check (values
, 3))
5675 if (!rank_check (values
, 3, 1))
5677 if (!variable_check (values
, 3, false))
5686 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5687 gfc_expr
*to
, gfc_expr
*topos
)
5689 if (!type_check (from
, 0, BT_INTEGER
))
5692 if (!type_check (frompos
, 1, BT_INTEGER
))
5695 if (!type_check (len
, 2, BT_INTEGER
))
5698 if (!same_type_check (from
, 0, to
, 3))
5701 if (!variable_check (to
, 3, false))
5704 if (!type_check (topos
, 4, BT_INTEGER
))
5707 if (!nonnegative_check ("frompos", frompos
))
5710 if (!nonnegative_check ("topos", topos
))
5713 if (!nonnegative_check ("len", len
))
5716 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5719 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5727 gfc_check_random_number (gfc_expr
*harvest
)
5729 if (!type_check (harvest
, 0, BT_REAL
))
5732 if (!variable_check (harvest
, 0, false))
5740 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5742 unsigned int nargs
= 0, seed_size
;
5743 locus
*where
= NULL
;
5744 mpz_t put_size
, get_size
;
5746 /* Keep the number of bytes in sync with master_state in
5747 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5748 part of the state too. */
5749 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5753 if (size
->expr_type
!= EXPR_VARIABLE
5754 || !size
->symtree
->n
.sym
->attr
.optional
)
5757 if (!scalar_check (size
, 0))
5760 if (!type_check (size
, 0, BT_INTEGER
))
5763 if (!variable_check (size
, 0, false))
5766 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5772 if (put
->expr_type
!= EXPR_VARIABLE
5773 || !put
->symtree
->n
.sym
->attr
.optional
)
5776 where
= &put
->where
;
5779 if (!array_check (put
, 1))
5782 if (!rank_check (put
, 1, 1))
5785 if (!type_check (put
, 1, BT_INTEGER
))
5788 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5791 if (gfc_array_size (put
, &put_size
)
5792 && mpz_get_ui (put_size
) < seed_size
)
5793 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5794 "too small (%i/%i)",
5795 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5796 where
, (int) mpz_get_ui (put_size
), seed_size
);
5801 if (get
->expr_type
!= EXPR_VARIABLE
5802 || !get
->symtree
->n
.sym
->attr
.optional
)
5805 where
= &get
->where
;
5808 if (!array_check (get
, 2))
5811 if (!rank_check (get
, 2, 1))
5814 if (!type_check (get
, 2, BT_INTEGER
))
5817 if (!variable_check (get
, 2, false))
5820 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5823 if (gfc_array_size (get
, &get_size
)
5824 && mpz_get_ui (get_size
) < seed_size
)
5825 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5826 "too small (%i/%i)",
5827 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5828 where
, (int) mpz_get_ui (get_size
), seed_size
);
5831 /* RANDOM_SEED may not have more than one non-optional argument. */
5833 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5839 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5843 int num_percent
, nargs
;
5846 if (e
->expr_type
!= EXPR_CONSTANT
)
5849 len
= e
->value
.character
.length
;
5850 if (e
->value
.character
.string
[len
-1] != '\0')
5851 gfc_internal_error ("fe_runtime_error string must be null terminated");
5854 for (i
=0; i
<len
-1; i
++)
5855 if (e
->value
.character
.string
[i
] == '%')
5859 for (; a
; a
= a
->next
)
5862 if (nargs
-1 != num_percent
)
5863 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5864 nargs
, num_percent
++);
5870 gfc_check_second_sub (gfc_expr
*time
)
5872 if (!scalar_check (time
, 0))
5875 if (!type_check (time
, 0, BT_REAL
))
5878 if (!kind_value_check (time
, 0, 4))
5885 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5886 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5887 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5888 count_max are all optional arguments */
5891 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5892 gfc_expr
*count_max
)
5896 if (!scalar_check (count
, 0))
5899 if (!type_check (count
, 0, BT_INTEGER
))
5902 if (count
->ts
.kind
!= gfc_default_integer_kind
5903 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5904 "SYSTEM_CLOCK at %L has non-default kind",
5908 if (!variable_check (count
, 0, false))
5912 if (count_rate
!= NULL
)
5914 if (!scalar_check (count_rate
, 1))
5917 if (!variable_check (count_rate
, 1, false))
5920 if (count_rate
->ts
.type
== BT_REAL
)
5922 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5923 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5928 if (!type_check (count_rate
, 1, BT_INTEGER
))
5931 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5932 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5933 "SYSTEM_CLOCK at %L has non-default kind",
5934 &count_rate
->where
))
5940 if (count_max
!= NULL
)
5942 if (!scalar_check (count_max
, 2))
5945 if (!type_check (count_max
, 2, BT_INTEGER
))
5948 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5949 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5950 "SYSTEM_CLOCK at %L has non-default kind",
5954 if (!variable_check (count_max
, 2, false))
5963 gfc_check_irand (gfc_expr
*x
)
5968 if (!scalar_check (x
, 0))
5971 if (!type_check (x
, 0, BT_INTEGER
))
5974 if (!kind_value_check (x
, 0, 4))
5982 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5984 if (!scalar_check (seconds
, 0))
5986 if (!type_check (seconds
, 0, BT_INTEGER
))
5989 if (!int_or_proc_check (handler
, 1))
5991 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5997 if (!scalar_check (status
, 2))
5999 if (!type_check (status
, 2, BT_INTEGER
))
6001 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6009 gfc_check_rand (gfc_expr
*x
)
6014 if (!scalar_check (x
, 0))
6017 if (!type_check (x
, 0, BT_INTEGER
))
6020 if (!kind_value_check (x
, 0, 4))
6028 gfc_check_srand (gfc_expr
*x
)
6030 if (!scalar_check (x
, 0))
6033 if (!type_check (x
, 0, BT_INTEGER
))
6036 if (!kind_value_check (x
, 0, 4))
6044 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6046 if (!scalar_check (time
, 0))
6048 if (!type_check (time
, 0, BT_INTEGER
))
6051 if (!type_check (result
, 1, BT_CHARACTER
))
6053 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6061 gfc_check_dtime_etime (gfc_expr
*x
)
6063 if (!array_check (x
, 0))
6066 if (!rank_check (x
, 0, 1))
6069 if (!variable_check (x
, 0, false))
6072 if (!type_check (x
, 0, BT_REAL
))
6075 if (!kind_value_check (x
, 0, 4))
6083 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6085 if (!array_check (values
, 0))
6088 if (!rank_check (values
, 0, 1))
6091 if (!variable_check (values
, 0, false))
6094 if (!type_check (values
, 0, BT_REAL
))
6097 if (!kind_value_check (values
, 0, 4))
6100 if (!scalar_check (time
, 1))
6103 if (!type_check (time
, 1, BT_REAL
))
6106 if (!kind_value_check (time
, 1, 4))
6114 gfc_check_fdate_sub (gfc_expr
*date
)
6116 if (!type_check (date
, 0, BT_CHARACTER
))
6118 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6126 gfc_check_gerror (gfc_expr
*msg
)
6128 if (!type_check (msg
, 0, BT_CHARACTER
))
6130 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6138 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6140 if (!type_check (cwd
, 0, BT_CHARACTER
))
6142 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6148 if (!scalar_check (status
, 1))
6151 if (!type_check (status
, 1, BT_INTEGER
))
6159 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6161 if (!type_check (pos
, 0, BT_INTEGER
))
6164 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6166 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6167 "not wider than the default kind (%d)",
6168 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6169 &pos
->where
, gfc_default_integer_kind
);
6173 if (!type_check (value
, 1, BT_CHARACTER
))
6175 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6183 gfc_check_getlog (gfc_expr
*msg
)
6185 if (!type_check (msg
, 0, BT_CHARACTER
))
6187 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6195 gfc_check_exit (gfc_expr
*status
)
6200 if (!type_check (status
, 0, BT_INTEGER
))
6203 if (!scalar_check (status
, 0))
6211 gfc_check_flush (gfc_expr
*unit
)
6216 if (!type_check (unit
, 0, BT_INTEGER
))
6219 if (!scalar_check (unit
, 0))
6227 gfc_check_free (gfc_expr
*i
)
6229 if (!type_check (i
, 0, BT_INTEGER
))
6232 if (!scalar_check (i
, 0))
6240 gfc_check_hostnm (gfc_expr
*name
)
6242 if (!type_check (name
, 0, BT_CHARACTER
))
6244 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6252 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6254 if (!type_check (name
, 0, BT_CHARACTER
))
6256 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6262 if (!scalar_check (status
, 1))
6265 if (!type_check (status
, 1, BT_INTEGER
))
6273 gfc_check_itime_idate (gfc_expr
*values
)
6275 if (!array_check (values
, 0))
6278 if (!rank_check (values
, 0, 1))
6281 if (!variable_check (values
, 0, false))
6284 if (!type_check (values
, 0, BT_INTEGER
))
6287 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6295 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6297 if (!type_check (time
, 0, BT_INTEGER
))
6300 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6303 if (!scalar_check (time
, 0))
6306 if (!array_check (values
, 1))
6309 if (!rank_check (values
, 1, 1))
6312 if (!variable_check (values
, 1, false))
6315 if (!type_check (values
, 1, BT_INTEGER
))
6318 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6326 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6328 if (!scalar_check (unit
, 0))
6331 if (!type_check (unit
, 0, BT_INTEGER
))
6334 if (!type_check (name
, 1, BT_CHARACTER
))
6336 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6344 gfc_check_isatty (gfc_expr
*unit
)
6349 if (!type_check (unit
, 0, BT_INTEGER
))
6352 if (!scalar_check (unit
, 0))
6360 gfc_check_isnan (gfc_expr
*x
)
6362 if (!type_check (x
, 0, BT_REAL
))
6370 gfc_check_perror (gfc_expr
*string
)
6372 if (!type_check (string
, 0, BT_CHARACTER
))
6374 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6382 gfc_check_umask (gfc_expr
*mask
)
6384 if (!type_check (mask
, 0, BT_INTEGER
))
6387 if (!scalar_check (mask
, 0))
6395 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6397 if (!type_check (mask
, 0, BT_INTEGER
))
6400 if (!scalar_check (mask
, 0))
6406 if (!scalar_check (old
, 1))
6409 if (!type_check (old
, 1, BT_INTEGER
))
6417 gfc_check_unlink (gfc_expr
*name
)
6419 if (!type_check (name
, 0, BT_CHARACTER
))
6421 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6429 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6431 if (!type_check (name
, 0, BT_CHARACTER
))
6433 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6439 if (!scalar_check (status
, 1))
6442 if (!type_check (status
, 1, BT_INTEGER
))
6450 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6452 if (!scalar_check (number
, 0))
6454 if (!type_check (number
, 0, BT_INTEGER
))
6457 if (!int_or_proc_check (handler
, 1))
6459 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6467 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6469 if (!scalar_check (number
, 0))
6471 if (!type_check (number
, 0, BT_INTEGER
))
6474 if (!int_or_proc_check (handler
, 1))
6476 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6482 if (!type_check (status
, 2, BT_INTEGER
))
6484 if (!scalar_check (status
, 2))
6492 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6494 if (!type_check (cmd
, 0, BT_CHARACTER
))
6496 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6499 if (!scalar_check (status
, 1))
6502 if (!type_check (status
, 1, BT_INTEGER
))
6505 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6512 /* This is used for the GNU intrinsics AND, OR and XOR. */
6514 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6516 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6518 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6519 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6520 gfc_current_intrinsic
, &i
->where
);
6524 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6526 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6527 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6528 gfc_current_intrinsic
, &j
->where
);
6532 if (i
->ts
.type
!= j
->ts
.type
)
6534 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6535 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6536 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6541 if (!scalar_check (i
, 0))
6544 if (!scalar_check (j
, 1))
6552 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6555 if (a
->expr_type
== EXPR_NULL
)
6557 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6558 "argument to STORAGE_SIZE, because it returns a "
6559 "disassociated pointer", &a
->where
);
6563 if (a
->ts
.type
== BT_ASSUMED
)
6565 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6566 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6571 if (a
->ts
.type
== BT_PROCEDURE
)
6573 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6574 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6575 gfc_current_intrinsic
, &a
->where
);
6582 if (!type_check (kind
, 1, BT_INTEGER
))
6585 if (!scalar_check (kind
, 1))
6588 if (kind
->expr_type
!= EXPR_CONSTANT
)
6590 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6591 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,