2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 /* Users sometime use a subroutine designator as an actual argument to
76 an intrinsic subprogram that expects an argument with a numeric type. */
77 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
80 if (gfc_numeric_ts (&e
->ts
))
83 /* If the expression has not got a type, check if its namespace can
84 offer a default type. */
85 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
86 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
87 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
88 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
90 e
->ts
= e
->symtree
->n
.sym
->ts
;
96 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
97 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
104 /* Check that an expression is integer or real. */
107 int_or_real_check (gfc_expr
*e
, int n
)
109 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
111 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
112 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
113 gfc_current_intrinsic
, &e
->where
);
121 /* Check that an expression is real or complex. */
124 real_or_complex_check (gfc_expr
*e
, int n
)
126 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
128 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
129 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
130 gfc_current_intrinsic
, &e
->where
);
138 /* Check that an expression is INTEGER or PROCEDURE. */
141 int_or_proc_check (gfc_expr
*e
, int n
)
143 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
145 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
146 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
147 gfc_current_intrinsic
, &e
->where
);
155 /* Check that the expression is an optional constant integer
156 and that it specifies a valid kind for that type. */
159 kind_check (gfc_expr
*k
, int n
, bt type
)
166 if (!type_check (k
, n
, BT_INTEGER
))
169 if (!scalar_check (k
, n
))
172 if (!gfc_check_init_expr (k
))
174 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
175 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
180 if (gfc_extract_int (k
, &kind
)
181 || gfc_validate_kind (type
, kind
, true) < 0)
183 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
192 /* Make sure the expression is a double precision real. */
195 double_check (gfc_expr
*d
, int n
)
197 if (!type_check (d
, n
, BT_REAL
))
200 if (d
->ts
.kind
!= gfc_default_double_kind
)
202 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
203 "precision", gfc_current_intrinsic_arg
[n
]->name
,
204 gfc_current_intrinsic
, &d
->where
);
213 coarray_check (gfc_expr
*e
, int n
)
215 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
216 && CLASS_DATA (e
)->attr
.codimension
217 && CLASS_DATA (e
)->as
->corank
)
219 gfc_add_class_array_ref (e
);
223 if (!gfc_is_coarray (e
))
225 gfc_error ("Expected coarray variable as %qs argument to the %s "
226 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
227 gfc_current_intrinsic
, &e
->where
);
235 /* Make sure the expression is a logical array. */
238 logical_array_check (gfc_expr
*array
, int n
)
240 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
242 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
243 "array", gfc_current_intrinsic_arg
[n
]->name
,
244 gfc_current_intrinsic
, &array
->where
);
252 /* Make sure an expression is an array. */
255 array_check (gfc_expr
*e
, int n
)
257 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
258 && CLASS_DATA (e
)->attr
.dimension
259 && CLASS_DATA (e
)->as
->rank
)
261 gfc_add_class_array_ref (e
);
265 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
268 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
269 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
276 /* If expr is a constant, then check to ensure that it is greater than
280 nonnegative_check (const char *arg
, gfc_expr
*expr
)
284 if (expr
->expr_type
== EXPR_CONSTANT
)
286 gfc_extract_int (expr
, &i
);
289 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
298 /* If expr is a constant, then check to ensure that it is greater than zero. */
301 positive_check (int n
, gfc_expr
*expr
)
305 if (expr
->expr_type
== EXPR_CONSTANT
)
307 gfc_extract_int (expr
, &i
);
310 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
311 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
321 /* If expr2 is constant, then check that the value is less than
322 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
325 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
326 gfc_expr
*expr2
, bool or_equal
)
330 if (expr2
->expr_type
== EXPR_CONSTANT
)
332 gfc_extract_int (expr2
, &i2
);
333 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
335 /* For ISHFT[C], check that |shift| <= bit_size(i). */
341 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
343 gfc_error ("The absolute value of SHIFT at %L must be less "
344 "than or equal to BIT_SIZE(%qs)",
345 &expr2
->where
, arg1
);
352 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
354 gfc_error ("%qs at %L must be less than "
355 "or equal to BIT_SIZE(%qs)",
356 arg2
, &expr2
->where
, arg1
);
362 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
364 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
365 arg2
, &expr2
->where
, arg1
);
375 /* If expr is constant, then check that the value is less than or equal
376 to the bit_size of the kind k. */
379 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
383 if (expr
->expr_type
!= EXPR_CONSTANT
)
386 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
387 gfc_extract_int (expr
, &val
);
389 if (val
> gfc_integer_kinds
[i
].bit_size
)
391 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
392 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
400 /* If expr2 and expr3 are constants, then check that the value is less than
401 or equal to bit_size(expr1). */
404 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
405 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
409 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
411 gfc_extract_int (expr2
, &i2
);
412 gfc_extract_int (expr3
, &i3
);
414 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
415 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
417 gfc_error ("%<%s + %s%> at %L must be less than or equal "
419 arg2
, arg3
, &expr2
->where
, arg1
);
427 /* Make sure two expressions have the same type. */
430 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
432 gfc_typespec
*ets
= &e
->ts
;
433 gfc_typespec
*fts
= &f
->ts
;
435 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
436 ets
= &e
->symtree
->n
.sym
->ts
;
437 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
438 fts
= &f
->symtree
->n
.sym
->ts
;
440 if (gfc_compare_types (ets
, fts
))
443 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
444 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
445 gfc_current_intrinsic
, &f
->where
,
446 gfc_current_intrinsic_arg
[n
]->name
);
452 /* Make sure that an expression has a certain (nonzero) rank. */
455 rank_check (gfc_expr
*e
, int n
, int rank
)
460 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
461 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
468 /* Make sure a variable expression is not an optional dummy argument. */
471 nonoptional_check (gfc_expr
*e
, int n
)
473 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
475 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
476 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
480 /* TODO: Recursive check on nonoptional variables? */
486 /* Check for ALLOCATABLE attribute. */
489 allocatable_check (gfc_expr
*e
, int n
)
491 symbol_attribute attr
;
493 attr
= gfc_variable_attr (e
, NULL
);
494 if (!attr
.allocatable
|| attr
.associate_var
)
496 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
497 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
506 /* Check that an expression has a particular kind. */
509 kind_value_check (gfc_expr
*e
, int n
, int k
)
514 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
515 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
522 /* Make sure an expression is a variable. */
525 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
527 if (e
->expr_type
== EXPR_VARIABLE
528 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
529 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
530 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
533 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
534 && CLASS_DATA (e
->symtree
->n
.sym
)
535 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
536 : e
->symtree
->n
.sym
->attr
.pointer
;
538 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
540 if (pointer
&& ref
->type
== REF_COMPONENT
)
542 if (ref
->type
== REF_COMPONENT
543 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
544 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
545 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
546 && ref
->u
.c
.component
->attr
.pointer
)))
552 gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
553 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
554 gfc_current_intrinsic
, &e
->where
);
559 if (e
->expr_type
== EXPR_VARIABLE
560 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
561 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
564 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
565 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
568 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
569 if (ns
->proc_name
== e
->symtree
->n
.sym
)
573 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
574 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
580 /* Check the common DIM parameter for correctness. */
583 dim_check (gfc_expr
*dim
, int n
, bool optional
)
588 if (!type_check (dim
, n
, BT_INTEGER
))
591 if (!scalar_check (dim
, n
))
594 if (!optional
&& !nonoptional_check (dim
, n
))
601 /* If a coarray DIM parameter is a constant, make sure that it is greater than
602 zero and less than or equal to the corank of the given array. */
605 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
609 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
611 if (dim
->expr_type
!= EXPR_CONSTANT
)
614 if (array
->ts
.type
== BT_CLASS
)
617 corank
= gfc_get_corank (array
);
619 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
620 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
622 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
623 "codimension index", gfc_current_intrinsic
, &dim
->where
);
632 /* If a DIM parameter is a constant, make sure that it is greater than
633 zero and less than or equal to the rank of the given array. If
634 allow_assumed is zero then dim must be less than the rank of the array
635 for assumed size arrays. */
638 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
646 if (dim
->expr_type
!= EXPR_CONSTANT
)
649 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
650 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
651 rank
= array
->rank
+ 1;
655 /* Assumed-rank array. */
657 rank
= GFC_MAX_DIMENSIONS
;
659 if (array
->expr_type
== EXPR_VARIABLE
)
661 ar
= gfc_find_array_ref (array
);
662 if (ar
->as
->type
== AS_ASSUMED_SIZE
664 && ar
->type
!= AR_ELEMENT
665 && ar
->type
!= AR_SECTION
)
669 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
670 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
672 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
673 "dimension index", gfc_current_intrinsic
, &dim
->where
);
682 /* Compare the size of a along dimension ai with the size of b along
683 dimension bi, returning 0 if they are known not to be identical,
684 and 1 if they are identical, or if this cannot be determined. */
687 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
689 mpz_t a_size
, b_size
;
692 gcc_assert (a
->rank
> ai
);
693 gcc_assert (b
->rank
> bi
);
697 if (gfc_array_dimen_size (a
, ai
, &a_size
))
699 if (gfc_array_dimen_size (b
, bi
, &b_size
))
701 if (mpz_cmp (a_size
, b_size
) != 0)
711 /* Calculate the length of a character variable, including substrings.
712 Strip away parentheses if necessary. Return -1 if no length could
716 gfc_var_strlen (const gfc_expr
*a
)
720 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
723 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
733 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
734 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
736 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
738 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
739 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
741 else if (ra
->u
.ss
.start
742 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
748 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
749 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
750 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
751 else if (a
->expr_type
== EXPR_CONSTANT
752 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
753 return a
->value
.character
.length
;
759 /* Check whether two character expressions have the same length;
760 returns true if they have or if the length cannot be determined,
761 otherwise return false and raise a gfc_error. */
764 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
768 len_a
= gfc_var_strlen(a
);
769 len_b
= gfc_var_strlen(b
);
771 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
775 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
776 len_a
, len_b
, name
, &a
->where
);
782 /***** Check functions *****/
784 /* Check subroutine suitable for intrinsics taking a real argument and
785 a kind argument for the result. */
788 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
790 if (!type_check (a
, 0, BT_REAL
))
792 if (!kind_check (kind
, 1, type
))
799 /* Check subroutine suitable for ceiling, floor and nint. */
802 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
804 return check_a_kind (a
, kind
, BT_INTEGER
);
808 /* Check subroutine suitable for aint, anint. */
811 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
813 return check_a_kind (a
, kind
, BT_REAL
);
818 gfc_check_abs (gfc_expr
*a
)
820 if (!numeric_check (a
, 0))
828 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
830 if (!type_check (a
, 0, BT_INTEGER
))
832 if (!kind_check (kind
, 1, BT_CHARACTER
))
840 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
842 if (!type_check (name
, 0, BT_CHARACTER
)
843 || !scalar_check (name
, 0))
845 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
848 if (!type_check (mode
, 1, BT_CHARACTER
)
849 || !scalar_check (mode
, 1))
851 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
859 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
861 if (!logical_array_check (mask
, 0))
864 if (!dim_check (dim
, 1, false))
867 if (!dim_rank_check (dim
, mask
, 0))
875 gfc_check_allocated (gfc_expr
*array
)
877 /* Tests on allocated components of coarrays need to detour the check to
878 argument of the _caf_get. */
879 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
880 && array
->value
.function
.isym
881 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
883 array
= array
->value
.function
.actual
->expr
;
888 if (!variable_check (array
, 0, false))
890 if (!allocatable_check (array
, 0))
897 /* Common check function where the first argument must be real or
898 integer and the second argument must be the same as the first. */
901 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
903 if (!int_or_real_check (a
, 0))
906 if (a
->ts
.type
!= p
->ts
.type
)
908 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
909 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
910 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
915 if (a
->ts
.kind
!= p
->ts
.kind
)
917 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
927 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
929 if (!double_check (x
, 0) || !double_check (y
, 1))
937 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
939 symbol_attribute attr1
, attr2
;
944 where
= &pointer
->where
;
946 if (pointer
->expr_type
== EXPR_NULL
)
949 attr1
= gfc_expr_attr (pointer
);
951 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
953 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
954 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
960 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
962 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
963 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
964 gfc_current_intrinsic
, &pointer
->where
);
968 /* Target argument is optional. */
972 where
= &target
->where
;
973 if (target
->expr_type
== EXPR_NULL
)
976 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
977 attr2
= gfc_expr_attr (target
);
980 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
981 "or target VARIABLE or FUNCTION",
982 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
987 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
989 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
990 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
991 gfc_current_intrinsic
, &target
->where
);
996 if (attr1
.pointer
&& gfc_is_coindexed (target
))
998 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
999 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1000 gfc_current_intrinsic
, &target
->where
);
1005 if (!same_type_check (pointer
, 0, target
, 1))
1007 if (!rank_check (target
, 0, pointer
->rank
))
1009 if (target
->rank
> 0)
1011 for (i
= 0; i
< target
->rank
; i
++)
1012 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1014 gfc_error ("Array section with a vector subscript at %L shall not "
1015 "be the target of a pointer",
1025 gfc_error ("NULL pointer at %L is not permitted as actual argument "
1026 "of %qs intrinsic function", where
, gfc_current_intrinsic
);
1033 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1035 /* gfc_notify_std would be a waste of time as the return value
1036 is seemingly used only for the generic resolution. The error
1037 will be: Too many arguments. */
1038 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1041 return gfc_check_atan2 (y
, x
);
1046 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1048 if (!type_check (y
, 0, BT_REAL
))
1050 if (!same_type_check (y
, 0, x
, 1))
1058 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1059 gfc_expr
*stat
, int stat_no
)
1061 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1064 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1065 && !(atom
->ts
.type
== BT_LOGICAL
1066 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1068 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1069 "integer of ATOMIC_INT_KIND or a logical of "
1070 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1074 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1076 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1077 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1081 if (atom
->ts
.type
!= value
->ts
.type
)
1083 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1084 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1085 gfc_current_intrinsic
, &value
->where
,
1086 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1092 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1094 if (!scalar_check (stat
, stat_no
))
1096 if (!variable_check (stat
, stat_no
, false))
1098 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1101 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1102 gfc_current_intrinsic
, &stat
->where
))
1111 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1113 if (atom
->expr_type
== EXPR_FUNCTION
1114 && atom
->value
.function
.isym
1115 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1116 atom
= atom
->value
.function
.actual
->expr
;
1118 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1120 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1121 "definable", gfc_current_intrinsic
, &atom
->where
);
1125 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1130 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1132 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1134 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1135 "integer of ATOMIC_INT_KIND", &atom
->where
,
1136 gfc_current_intrinsic
);
1140 return gfc_check_atomic_def (atom
, value
, stat
);
1145 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1147 if (atom
->expr_type
== EXPR_FUNCTION
1148 && atom
->value
.function
.isym
1149 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1150 atom
= atom
->value
.function
.actual
->expr
;
1152 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1154 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1155 "definable", gfc_current_intrinsic
, &value
->where
);
1159 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1164 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1166 /* IMAGE has to be a positive, scalar integer. */
1167 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1168 || !positive_check (0, image
))
1173 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1174 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1183 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1187 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1188 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1197 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1198 || !positive_check (1, kind
))
1201 /* Get the kind, reporting error on non-constant or overflow. */
1202 gfc_current_locus
= kind
->where
;
1203 if (gfc_extract_int (kind
, &k
, 1))
1205 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1207 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1208 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1209 gfc_current_intrinsic
, &kind
->where
);
1218 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1219 gfc_expr
*new_val
, gfc_expr
*stat
)
1221 if (atom
->expr_type
== EXPR_FUNCTION
1222 && atom
->value
.function
.isym
1223 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1224 atom
= atom
->value
.function
.actual
->expr
;
1226 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1229 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1232 if (!same_type_check (atom
, 0, old
, 1))
1235 if (!same_type_check (atom
, 0, compare
, 2))
1238 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1240 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1241 "definable", gfc_current_intrinsic
, &atom
->where
);
1245 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1247 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1248 "definable", gfc_current_intrinsic
, &old
->where
);
1256 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1258 if (event
->ts
.type
!= BT_DERIVED
1259 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1260 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1262 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1263 "shall be of type EVENT_TYPE", &event
->where
);
1267 if (!scalar_check (event
, 0))
1270 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1272 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1273 "shall be definable", &count
->where
);
1277 if (!type_check (count
, 1, BT_INTEGER
))
1280 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1281 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1283 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1285 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1286 "shall have at least the range of the default integer",
1293 if (!type_check (stat
, 2, BT_INTEGER
))
1295 if (!scalar_check (stat
, 2))
1297 if (!variable_check (stat
, 2, false))
1300 if (!gfc_notify_std (GFC_STD_F2008_TS
, "STAT= argument to %s at %L",
1301 gfc_current_intrinsic
, &stat
->where
))
1310 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1313 if (atom
->expr_type
== EXPR_FUNCTION
1314 && atom
->value
.function
.isym
1315 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1316 atom
= atom
->value
.function
.actual
->expr
;
1318 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1320 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1321 "integer of ATOMIC_INT_KIND", &atom
->where
,
1322 gfc_current_intrinsic
);
1326 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1329 if (!scalar_check (old
, 2))
1332 if (!same_type_check (atom
, 0, old
, 2))
1335 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1337 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1338 "definable", gfc_current_intrinsic
, &atom
->where
);
1342 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1344 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1345 "definable", gfc_current_intrinsic
, &old
->where
);
1353 /* BESJN and BESYN functions. */
1356 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1358 if (!type_check (n
, 0, BT_INTEGER
))
1360 if (n
->expr_type
== EXPR_CONSTANT
)
1363 gfc_extract_int (n
, &i
);
1364 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1365 "N at %L", &n
->where
))
1369 if (!type_check (x
, 1, BT_REAL
))
1376 /* Transformational version of the Bessel JN and YN functions. */
1379 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1381 if (!type_check (n1
, 0, BT_INTEGER
))
1383 if (!scalar_check (n1
, 0))
1385 if (!nonnegative_check ("N1", n1
))
1388 if (!type_check (n2
, 1, BT_INTEGER
))
1390 if (!scalar_check (n2
, 1))
1392 if (!nonnegative_check ("N2", n2
))
1395 if (!type_check (x
, 2, BT_REAL
))
1397 if (!scalar_check (x
, 2))
1405 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1407 if (!type_check (i
, 0, BT_INTEGER
))
1410 if (!type_check (j
, 1, BT_INTEGER
))
1418 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1420 if (!type_check (i
, 0, BT_INTEGER
))
1423 if (!type_check (pos
, 1, BT_INTEGER
))
1426 if (!nonnegative_check ("pos", pos
))
1429 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1437 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1439 if (!type_check (i
, 0, BT_INTEGER
))
1441 if (!kind_check (kind
, 1, BT_CHARACTER
))
1449 gfc_check_chdir (gfc_expr
*dir
)
1451 if (!type_check (dir
, 0, BT_CHARACTER
))
1453 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1461 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1463 if (!type_check (dir
, 0, BT_CHARACTER
))
1465 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1471 if (!type_check (status
, 1, BT_INTEGER
))
1473 if (!scalar_check (status
, 1))
1481 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1483 if (!type_check (name
, 0, BT_CHARACTER
))
1485 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1488 if (!type_check (mode
, 1, BT_CHARACTER
))
1490 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1498 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1500 if (!type_check (name
, 0, BT_CHARACTER
))
1502 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1505 if (!type_check (mode
, 1, BT_CHARACTER
))
1507 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1513 if (!type_check (status
, 2, BT_INTEGER
))
1516 if (!scalar_check (status
, 2))
1524 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1526 if (!numeric_check (x
, 0))
1531 if (!numeric_check (y
, 1))
1534 if (x
->ts
.type
== BT_COMPLEX
)
1536 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1537 "present if %<x%> is COMPLEX",
1538 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1543 if (y
->ts
.type
== BT_COMPLEX
)
1545 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
1546 "of either REAL or INTEGER",
1547 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1554 if (!kind_check (kind
, 2, BT_COMPLEX
))
1557 if (!kind
&& warn_conversion
1558 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1559 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1560 "COMPLEX(%d) at %L might lose precision, consider using "
1561 "the KIND argument", gfc_typename (&x
->ts
),
1562 gfc_default_real_kind
, &x
->where
);
1563 else if (y
&& !kind
&& warn_conversion
1564 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1565 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
1566 "COMPLEX(%d) at %L might lose precision, consider using "
1567 "the KIND argument", gfc_typename (&y
->ts
),
1568 gfc_default_real_kind
, &y
->where
);
1574 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
1575 gfc_expr
*errmsg
, bool co_reduce
)
1577 if (!variable_check (a
, 0, false))
1580 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
1584 /* Fortran 2008, 12.5.2.4, paragraph 18. */
1585 if (gfc_has_vector_subscript (a
))
1587 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
1588 "subroutine %s shall not have a vector subscript",
1589 &a
->where
, gfc_current_intrinsic
);
1593 if (gfc_is_coindexed (a
))
1595 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1596 "coindexed", &a
->where
, gfc_current_intrinsic
);
1600 if (image_idx
!= NULL
)
1602 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
1604 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
1610 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
1612 if (!scalar_check (stat
, co_reduce
? 3 : 2))
1614 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
1616 if (stat
->ts
.kind
!= 4)
1618 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1619 "variable", &stat
->where
);
1626 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
1628 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
1630 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
1632 if (errmsg
->ts
.kind
!= 1)
1634 gfc_error ("The errmsg= argument at %L must be a default-kind "
1635 "character variable", &errmsg
->where
);
1640 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1642 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1652 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
1655 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
1657 gfc_error ("Support for the A argument at %L which is polymorphic A "
1658 "argument or has allocatable components is not yet "
1659 "implemented", &a
->where
);
1662 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
1667 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
1668 gfc_expr
*stat
, gfc_expr
*errmsg
)
1670 symbol_attribute attr
;
1671 gfc_formal_arglist
*formal
;
1674 if (a
->ts
.type
== BT_CLASS
)
1676 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
1681 if (gfc_expr_attr (a
).alloc_comp
)
1683 gfc_error ("Support for the A argument at %L with allocatable components"
1684 " is not yet implemented", &a
->where
);
1688 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
1691 if (!gfc_resolve_expr (op
))
1694 attr
= gfc_expr_attr (op
);
1695 if (!attr
.pure
|| !attr
.function
)
1697 gfc_error ("OPERATOR argument at %L must be a PURE function",
1704 /* None of the intrinsics fulfills the criteria of taking two arguments,
1705 returning the same type and kind as the arguments and being permitted
1706 as actual argument. */
1707 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
1708 op
->symtree
->n
.sym
->name
, &op
->where
);
1712 if (gfc_is_proc_ptr_comp (op
))
1714 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
1715 sym
= comp
->ts
.interface
;
1718 sym
= op
->symtree
->n
.sym
;
1720 formal
= sym
->formal
;
1722 if (!formal
|| !formal
->next
|| formal
->next
->next
)
1724 gfc_error ("The function passed as OPERATOR at %L shall have two "
1725 "arguments", &op
->where
);
1729 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
1730 gfc_set_default_type (sym
->result
, 0, NULL
);
1732 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
1734 gfc_error ("A argument at %L has type %s but the function passed as "
1735 "OPERATOR at %L returns %s",
1736 &a
->where
, gfc_typename (&a
->ts
), &op
->where
,
1737 gfc_typename (&sym
->result
->ts
));
1740 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
1741 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
1743 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
1744 "%s and %s but shall have type %s", &op
->where
,
1745 gfc_typename (&formal
->sym
->ts
),
1746 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (&a
->ts
));
1749 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
1750 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
1751 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
1752 || formal
->next
->sym
->attr
.pointer
)
1754 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
1755 "nonallocatable nonpointer arguments and return a "
1756 "nonallocatable nonpointer scalar", &op
->where
);
1760 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
1762 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
1763 "attribute either for none or both arguments", &op
->where
);
1767 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
1769 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
1770 "attribute either for none or both arguments", &op
->where
);
1774 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
1776 gfc_error ("The function passed as OPERATOR at %L shall have the "
1777 "ASYNCHRONOUS attribute either for none or both arguments",
1782 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
1784 gfc_error ("The function passed as OPERATOR at %L shall not have the "
1785 "OPTIONAL attribute for either of the arguments", &op
->where
);
1789 if (a
->ts
.type
== BT_CHARACTER
)
1792 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
1795 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1796 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1798 cl
= formal
->sym
->ts
.u
.cl
;
1799 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1800 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1802 cl
= formal
->next
->sym
->ts
.u
.cl
;
1803 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1804 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1807 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
1808 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
1811 && ((formal_size1
&& actual_size
!= formal_size1
)
1812 || (formal_size2
&& actual_size
!= formal_size2
)))
1814 gfc_error ("The character length of the A argument at %L and of the "
1815 "arguments of the OPERATOR at %L shall be the same",
1816 &a
->where
, &op
->where
);
1819 if (actual_size
&& result_size
&& actual_size
!= result_size
)
1821 gfc_error ("The character length of the A argument at %L and of the "
1822 "function result of the OPERATOR at %L shall be the same",
1823 &a
->where
, &op
->where
);
1833 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1836 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
1837 && a
->ts
.type
!= BT_CHARACTER
)
1839 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
1840 "integer, real or character",
1841 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1845 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1850 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
1853 if (!numeric_check (a
, 0))
1855 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
1860 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1862 if (!int_or_real_check (x
, 0))
1864 if (!scalar_check (x
, 0))
1867 if (!int_or_real_check (y
, 1))
1869 if (!scalar_check (y
, 1))
1877 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1879 if (!logical_array_check (mask
, 0))
1881 if (!dim_check (dim
, 1, false))
1883 if (!dim_rank_check (dim
, mask
, 0))
1885 if (!kind_check (kind
, 2, BT_INTEGER
))
1887 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
1888 "with KIND argument at %L",
1889 gfc_current_intrinsic
, &kind
->where
))
1897 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1899 if (!array_check (array
, 0))
1902 if (!type_check (shift
, 1, BT_INTEGER
))
1905 if (!dim_check (dim
, 2, true))
1908 if (!dim_rank_check (dim
, array
, false))
1911 if (array
->rank
== 1 || shift
->rank
== 0)
1913 if (!scalar_check (shift
, 1))
1916 else if (shift
->rank
== array
->rank
- 1)
1921 else if (dim
->expr_type
== EXPR_CONSTANT
)
1922 gfc_extract_int (dim
, &d
);
1929 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1932 if (!identical_dimen_shape (array
, i
, shift
, j
))
1934 gfc_error ("%qs argument of %qs intrinsic at %L has "
1935 "invalid shape in dimension %d (%ld/%ld)",
1936 gfc_current_intrinsic_arg
[1]->name
,
1937 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1938 mpz_get_si (array
->shape
[i
]),
1939 mpz_get_si (shift
->shape
[j
]));
1949 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
1950 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1951 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1960 gfc_check_ctime (gfc_expr
*time
)
1962 if (!scalar_check (time
, 0))
1965 if (!type_check (time
, 0, BT_INTEGER
))
1972 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1974 if (!double_check (y
, 0) || !double_check (x
, 1))
1981 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1983 if (!numeric_check (x
, 0))
1988 if (!numeric_check (y
, 1))
1991 if (x
->ts
.type
== BT_COMPLEX
)
1993 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
1994 "present if %<x%> is COMPLEX",
1995 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2000 if (y
->ts
.type
== BT_COMPLEX
)
2002 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2003 "of either REAL or INTEGER",
2004 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2015 gfc_check_dble (gfc_expr
*x
)
2017 if (!numeric_check (x
, 0))
2025 gfc_check_digits (gfc_expr
*x
)
2027 if (!int_or_real_check (x
, 0))
2035 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2037 switch (vector_a
->ts
.type
)
2040 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2047 if (!numeric_check (vector_b
, 1))
2052 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2053 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2054 gfc_current_intrinsic
, &vector_a
->where
);
2058 if (!rank_check (vector_a
, 0, 1))
2061 if (!rank_check (vector_b
, 1, 1))
2064 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2066 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2067 "intrinsic %<dot_product%>",
2068 gfc_current_intrinsic_arg
[0]->name
,
2069 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2078 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2080 if (!type_check (x
, 0, BT_REAL
)
2081 || !type_check (y
, 1, BT_REAL
))
2084 if (x
->ts
.kind
!= gfc_default_real_kind
)
2086 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2087 "real", gfc_current_intrinsic_arg
[0]->name
,
2088 gfc_current_intrinsic
, &x
->where
);
2092 if (y
->ts
.kind
!= gfc_default_real_kind
)
2094 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2095 "real", gfc_current_intrinsic_arg
[1]->name
,
2096 gfc_current_intrinsic
, &y
->where
);
2105 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2107 if (!type_check (i
, 0, BT_INTEGER
))
2110 if (!type_check (j
, 1, BT_INTEGER
))
2113 if (i
->is_boz
&& j
->is_boz
)
2115 gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
2116 "constants", &i
->where
, &j
->where
);
2120 if (!i
->is_boz
&& !j
->is_boz
&& !same_type_check (i
, 0, j
, 1))
2123 if (!type_check (shift
, 2, BT_INTEGER
))
2126 if (!nonnegative_check ("SHIFT", shift
))
2131 if (!less_than_bitsize1 ("J", j
, "SHIFT", shift
, true))
2133 i
->ts
.kind
= j
->ts
.kind
;
2137 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2139 j
->ts
.kind
= i
->ts
.kind
;
2147 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2150 if (!array_check (array
, 0))
2153 if (!type_check (shift
, 1, BT_INTEGER
))
2156 if (!dim_check (dim
, 3, true))
2159 if (!dim_rank_check (dim
, array
, false))
2162 if (array
->rank
== 1 || shift
->rank
== 0)
2164 if (!scalar_check (shift
, 1))
2167 else if (shift
->rank
== array
->rank
- 1)
2172 else if (dim
->expr_type
== EXPR_CONSTANT
)
2173 gfc_extract_int (dim
, &d
);
2180 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2183 if (!identical_dimen_shape (array
, i
, shift
, j
))
2185 gfc_error ("%qs argument of %qs intrinsic at %L has "
2186 "invalid shape in dimension %d (%ld/%ld)",
2187 gfc_current_intrinsic_arg
[1]->name
,
2188 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2189 mpz_get_si (array
->shape
[i
]),
2190 mpz_get_si (shift
->shape
[j
]));
2200 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2201 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2202 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2206 if (boundary
!= NULL
)
2208 if (!same_type_check (array
, 0, boundary
, 2))
2211 if (array
->rank
== 1 || boundary
->rank
== 0)
2213 if (!scalar_check (boundary
, 2))
2216 else if (boundary
->rank
== array
->rank
- 1)
2218 if (!gfc_check_conformance (shift
, boundary
,
2219 "arguments '%s' and '%s' for "
2221 gfc_current_intrinsic_arg
[1]->name
,
2222 gfc_current_intrinsic_arg
[2]->name
,
2223 gfc_current_intrinsic
))
2228 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2229 "rank %d or be a scalar",
2230 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2231 &shift
->where
, array
->rank
- 1);
2240 gfc_check_float (gfc_expr
*a
)
2242 if (!type_check (a
, 0, BT_INTEGER
))
2245 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2246 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2247 "kind argument to %s intrinsic at %L",
2248 gfc_current_intrinsic
, &a
->where
))
2254 /* A single complex argument. */
2257 gfc_check_fn_c (gfc_expr
*a
)
2259 if (!type_check (a
, 0, BT_COMPLEX
))
2266 /* A single real argument. */
2269 gfc_check_fn_r (gfc_expr
*a
)
2271 if (!type_check (a
, 0, BT_REAL
))
2277 /* A single double argument. */
2280 gfc_check_fn_d (gfc_expr
*a
)
2282 if (!double_check (a
, 0))
2288 /* A single real or complex argument. */
2291 gfc_check_fn_rc (gfc_expr
*a
)
2293 if (!real_or_complex_check (a
, 0))
2301 gfc_check_fn_rc2008 (gfc_expr
*a
)
2303 if (!real_or_complex_check (a
, 0))
2306 if (a
->ts
.type
== BT_COMPLEX
2307 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2308 "of %qs intrinsic at %L",
2309 gfc_current_intrinsic_arg
[0]->name
,
2310 gfc_current_intrinsic
, &a
->where
))
2318 gfc_check_fnum (gfc_expr
*unit
)
2320 if (!type_check (unit
, 0, BT_INTEGER
))
2323 if (!scalar_check (unit
, 0))
2331 gfc_check_huge (gfc_expr
*x
)
2333 if (!int_or_real_check (x
, 0))
2341 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
2343 if (!type_check (x
, 0, BT_REAL
))
2345 if (!same_type_check (x
, 0, y
, 1))
2352 /* Check that the single argument is an integer. */
2355 gfc_check_i (gfc_expr
*i
)
2357 if (!type_check (i
, 0, BT_INTEGER
))
2365 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
2367 if (!type_check (i
, 0, BT_INTEGER
))
2370 if (!type_check (j
, 1, BT_INTEGER
))
2373 if (i
->ts
.kind
!= j
->ts
.kind
)
2375 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2385 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
2387 if (!type_check (i
, 0, BT_INTEGER
))
2390 if (!type_check (pos
, 1, BT_INTEGER
))
2393 if (!type_check (len
, 2, BT_INTEGER
))
2396 if (!nonnegative_check ("pos", pos
))
2399 if (!nonnegative_check ("len", len
))
2402 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
2410 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
2414 if (!type_check (c
, 0, BT_CHARACTER
))
2417 if (!kind_check (kind
, 1, BT_INTEGER
))
2420 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2421 "with KIND argument at %L",
2422 gfc_current_intrinsic
, &kind
->where
))
2425 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
2431 /* Substring references don't have the charlength set. */
2433 while (ref
&& ref
->type
!= REF_SUBSTRING
)
2436 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
2440 /* Check that the argument is length one. Non-constant lengths
2441 can't be checked here, so assume they are ok. */
2442 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
2444 /* If we already have a length for this expression then use it. */
2445 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2447 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
2454 start
= ref
->u
.ss
.start
;
2455 end
= ref
->u
.ss
.end
;
2458 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2459 || start
->expr_type
!= EXPR_CONSTANT
)
2462 i
= mpz_get_si (end
->value
.integer
) + 1
2463 - mpz_get_si (start
->value
.integer
);
2471 gfc_error ("Argument of %s at %L must be of length one",
2472 gfc_current_intrinsic
, &c
->where
);
2481 gfc_check_idnint (gfc_expr
*a
)
2483 if (!double_check (a
, 0))
2491 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
2493 if (!type_check (i
, 0, BT_INTEGER
))
2496 if (!type_check (j
, 1, BT_INTEGER
))
2499 if (i
->ts
.kind
!= j
->ts
.kind
)
2501 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2511 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
2514 if (!type_check (string
, 0, BT_CHARACTER
)
2515 || !type_check (substring
, 1, BT_CHARACTER
))
2518 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
2521 if (!kind_check (kind
, 3, BT_INTEGER
))
2523 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2524 "with KIND argument at %L",
2525 gfc_current_intrinsic
, &kind
->where
))
2528 if (string
->ts
.kind
!= substring
->ts
.kind
)
2530 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2531 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
2532 gfc_current_intrinsic
, &substring
->where
,
2533 gfc_current_intrinsic_arg
[0]->name
);
2542 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
2544 if (!numeric_check (x
, 0))
2547 if (!kind_check (kind
, 1, BT_INTEGER
))
2555 gfc_check_intconv (gfc_expr
*x
)
2557 if (!numeric_check (x
, 0))
2565 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2567 if (!type_check (i
, 0, BT_INTEGER
))
2570 if (!type_check (j
, 1, BT_INTEGER
))
2573 if (i
->ts
.kind
!= j
->ts
.kind
)
2575 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2585 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2587 if (!type_check (i
, 0, BT_INTEGER
)
2588 || !type_check (shift
, 1, BT_INTEGER
))
2591 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2599 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2601 if (!type_check (i
, 0, BT_INTEGER
)
2602 || !type_check (shift
, 1, BT_INTEGER
))
2609 if (!type_check (size
, 2, BT_INTEGER
))
2612 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
2615 if (size
->expr_type
== EXPR_CONSTANT
)
2617 gfc_extract_int (size
, &i3
);
2620 gfc_error ("SIZE at %L must be positive", &size
->where
);
2624 if (shift
->expr_type
== EXPR_CONSTANT
)
2626 gfc_extract_int (shift
, &i2
);
2632 gfc_error ("The absolute value of SHIFT at %L must be less "
2633 "than or equal to SIZE at %L", &shift
->where
,
2640 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
2648 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2650 if (!type_check (pid
, 0, BT_INTEGER
))
2653 if (!type_check (sig
, 1, BT_INTEGER
))
2661 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2663 if (!type_check (pid
, 0, BT_INTEGER
))
2666 if (!scalar_check (pid
, 0))
2669 if (!type_check (sig
, 1, BT_INTEGER
))
2672 if (!scalar_check (sig
, 1))
2678 if (!type_check (status
, 2, BT_INTEGER
))
2681 if (!scalar_check (status
, 2))
2689 gfc_check_kind (gfc_expr
*x
)
2691 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
2693 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
2694 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
2695 gfc_current_intrinsic
, &x
->where
);
2698 if (x
->ts
.type
== BT_PROCEDURE
)
2700 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
2701 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2711 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2713 if (!array_check (array
, 0))
2716 if (!dim_check (dim
, 1, false))
2719 if (!dim_rank_check (dim
, array
, 1))
2722 if (!kind_check (kind
, 2, BT_INTEGER
))
2724 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2725 "with KIND argument at %L",
2726 gfc_current_intrinsic
, &kind
->where
))
2734 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2736 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2738 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2742 if (!coarray_check (coarray
, 0))
2747 if (!dim_check (dim
, 1, false))
2750 if (!dim_corank_check (dim
, coarray
))
2754 if (!kind_check (kind
, 2, BT_INTEGER
))
2762 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2764 if (!type_check (s
, 0, BT_CHARACTER
))
2767 if (!kind_check (kind
, 1, BT_INTEGER
))
2769 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2770 "with KIND argument at %L",
2771 gfc_current_intrinsic
, &kind
->where
))
2779 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2781 if (!type_check (a
, 0, BT_CHARACTER
))
2783 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
2786 if (!type_check (b
, 1, BT_CHARACTER
))
2788 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
2796 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2798 if (!type_check (path1
, 0, BT_CHARACTER
))
2800 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2803 if (!type_check (path2
, 1, BT_CHARACTER
))
2805 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2813 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2815 if (!type_check (path1
, 0, BT_CHARACTER
))
2817 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2820 if (!type_check (path2
, 1, BT_CHARACTER
))
2822 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
2828 if (!type_check (status
, 2, BT_INTEGER
))
2831 if (!scalar_check (status
, 2))
2839 gfc_check_loc (gfc_expr
*expr
)
2841 return variable_check (expr
, 0, true);
2846 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2848 if (!type_check (path1
, 0, BT_CHARACTER
))
2850 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2853 if (!type_check (path2
, 1, BT_CHARACTER
))
2855 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2863 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2865 if (!type_check (path1
, 0, BT_CHARACTER
))
2867 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
2870 if (!type_check (path2
, 1, BT_CHARACTER
))
2872 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
2878 if (!type_check (status
, 2, BT_INTEGER
))
2881 if (!scalar_check (status
, 2))
2889 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2891 if (!type_check (a
, 0, BT_LOGICAL
))
2893 if (!kind_check (kind
, 1, BT_LOGICAL
))
2900 /* Min/max family. */
2903 min_max_args (gfc_actual_arglist
*args
)
2905 gfc_actual_arglist
*arg
;
2906 int i
, j
, nargs
, *nlabels
, nlabelless
;
2907 bool a1
= false, a2
= false;
2909 if (args
== NULL
|| args
->next
== NULL
)
2911 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
2912 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2919 if (!args
->next
->name
)
2923 for (arg
= args
; arg
; arg
= arg
->next
)
2930 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2932 nlabels
= XALLOCAVEC (int, nargs
);
2933 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
2939 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
2941 n
= strtol (&arg
->name
[1], &endp
, 10);
2942 if (endp
[0] != '\0')
2946 if (n
<= nlabelless
)
2959 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
2960 !a1
? "a1" : "a2", gfc_current_intrinsic
,
2961 gfc_current_intrinsic_where
);
2965 /* Check for duplicates. */
2966 for (i
= 0; i
< nargs
; i
++)
2967 for (j
= i
+ 1; j
< nargs
; j
++)
2968 if (nlabels
[i
] == nlabels
[j
])
2974 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
2975 &arg
->expr
->where
, gfc_current_intrinsic
);
2979 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
2980 &arg
->expr
->where
, gfc_current_intrinsic
);
2986 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2988 gfc_actual_arglist
*arg
, *tmp
;
2992 if (!min_max_args (arglist
))
2995 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2998 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3000 if (x
->ts
.type
== type
)
3002 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3003 "kinds at %L", &x
->where
))
3008 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3009 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3010 gfc_basic_typename (type
), kind
);
3015 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3016 if (!gfc_check_conformance (tmp
->expr
, x
,
3017 "arguments 'a%d' and 'a%d' for "
3018 "intrinsic '%s'", m
, n
,
3019 gfc_current_intrinsic
))
3028 gfc_check_min_max (gfc_actual_arglist
*arg
)
3032 if (!min_max_args (arg
))
3037 if (x
->ts
.type
== BT_CHARACTER
)
3039 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3040 "with CHARACTER argument at %L",
3041 gfc_current_intrinsic
, &x
->where
))
3044 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3046 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3047 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3051 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3056 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3058 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3063 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3065 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3070 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3072 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3076 /* End of min/max family. */
3079 gfc_check_malloc (gfc_expr
*size
)
3081 if (!type_check (size
, 0, BT_INTEGER
))
3084 if (!scalar_check (size
, 0))
3092 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3094 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3096 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3097 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3098 gfc_current_intrinsic
, &matrix_a
->where
);
3102 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3104 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3105 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3106 gfc_current_intrinsic
, &matrix_b
->where
);
3110 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3111 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3113 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3114 gfc_current_intrinsic
, &matrix_a
->where
,
3115 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3119 switch (matrix_a
->rank
)
3122 if (!rank_check (matrix_b
, 1, 2))
3124 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3125 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3127 gfc_error ("Different shape on dimension 1 for arguments %qs "
3128 "and %qs at %L for intrinsic matmul",
3129 gfc_current_intrinsic_arg
[0]->name
,
3130 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3136 if (matrix_b
->rank
!= 2)
3138 if (!rank_check (matrix_b
, 1, 1))
3141 /* matrix_b has rank 1 or 2 here. Common check for the cases
3142 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3143 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3144 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3146 gfc_error ("Different shape on dimension 2 for argument %qs and "
3147 "dimension 1 for argument %qs at %L for intrinsic "
3148 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3149 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3155 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3156 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3157 gfc_current_intrinsic
, &matrix_a
->where
);
3165 /* Whoever came up with this interface was probably on something.
3166 The possibilities for the occupation of the second and third
3173 NULL MASK minloc(array, mask=m)
3176 I.e. in the case of minloc(array,mask), mask will be in the second
3177 position of the argument list and we'll have to fix that up. */
3180 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3182 gfc_expr
*a
, *m
, *d
;
3185 if (!int_or_real_check (a
, 0) || !array_check (a
, 0))
3189 m
= ap
->next
->next
->expr
;
3191 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3192 && ap
->next
->name
== NULL
)
3196 ap
->next
->expr
= NULL
;
3197 ap
->next
->next
->expr
= m
;
3200 if (!dim_check (d
, 1, false))
3203 if (!dim_rank_check (d
, a
, 0))
3206 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3210 && !gfc_check_conformance (a
, m
,
3211 "arguments '%s' and '%s' for intrinsic %s",
3212 gfc_current_intrinsic_arg
[0]->name
,
3213 gfc_current_intrinsic_arg
[2]->name
,
3214 gfc_current_intrinsic
))
3221 /* Similar to minloc/maxloc, the argument list might need to be
3222 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3223 difference is that MINLOC/MAXLOC take an additional KIND argument.
3224 The possibilities are:
3230 NULL MASK minval(array, mask=m)
3233 I.e. in the case of minval(array,mask), mask will be in the second
3234 position of the argument list and we'll have to fix that up. */
3237 check_reduction (gfc_actual_arglist
*ap
)
3239 gfc_expr
*a
, *m
, *d
;
3243 m
= ap
->next
->next
->expr
;
3245 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3246 && ap
->next
->name
== NULL
)
3250 ap
->next
->expr
= NULL
;
3251 ap
->next
->next
->expr
= m
;
3254 if (!dim_check (d
, 1, false))
3257 if (!dim_rank_check (d
, a
, 0))
3260 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3264 && !gfc_check_conformance (a
, m
,
3265 "arguments '%s' and '%s' for intrinsic %s",
3266 gfc_current_intrinsic_arg
[0]->name
,
3267 gfc_current_intrinsic_arg
[2]->name
,
3268 gfc_current_intrinsic
))
3276 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
3278 if (!int_or_real_check (ap
->expr
, 0)
3279 || !array_check (ap
->expr
, 0))
3282 return check_reduction (ap
);
3287 gfc_check_product_sum (gfc_actual_arglist
*ap
)
3289 if (!numeric_check (ap
->expr
, 0)
3290 || !array_check (ap
->expr
, 0))
3293 return check_reduction (ap
);
3297 /* For IANY, IALL and IPARITY. */
3300 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
3304 if (!type_check (i
, 0, BT_INTEGER
))
3307 if (!nonnegative_check ("I", i
))
3310 if (!kind_check (kind
, 1, BT_INTEGER
))
3314 gfc_extract_int (kind
, &k
);
3316 k
= gfc_default_integer_kind
;
3318 if (!less_than_bitsizekind ("I", i
, k
))
3326 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
3328 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
3330 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
3331 gfc_current_intrinsic_arg
[0]->name
,
3332 gfc_current_intrinsic
, &ap
->expr
->where
);
3336 if (!array_check (ap
->expr
, 0))
3339 return check_reduction (ap
);
3344 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
3346 if (!same_type_check (tsource
, 0, fsource
, 1))
3349 if (!type_check (mask
, 2, BT_LOGICAL
))
3352 if (tsource
->ts
.type
== BT_CHARACTER
)
3353 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
3360 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
3362 if (!type_check (i
, 0, BT_INTEGER
))
3365 if (!type_check (j
, 1, BT_INTEGER
))
3368 if (!type_check (mask
, 2, BT_INTEGER
))
3371 if (!same_type_check (i
, 0, j
, 1))
3374 if (!same_type_check (i
, 0, mask
, 2))
3382 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
3384 if (!variable_check (from
, 0, false))
3386 if (!allocatable_check (from
, 0))
3388 if (gfc_is_coindexed (from
))
3390 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3391 "coindexed", &from
->where
);
3395 if (!variable_check (to
, 1, false))
3397 if (!allocatable_check (to
, 1))
3399 if (gfc_is_coindexed (to
))
3401 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3402 "coindexed", &to
->where
);
3406 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
3408 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3409 "polymorphic if FROM is polymorphic",
3414 if (!same_type_check (to
, 1, from
, 0))
3417 if (to
->rank
!= from
->rank
)
3419 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3420 "must have the same rank %d/%d", &to
->where
, from
->rank
,
3425 /* IR F08/0040; cf. 12-006A. */
3426 if (gfc_get_corank (to
) != gfc_get_corank (from
))
3428 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3429 "must have the same corank %d/%d", &to
->where
,
3430 gfc_get_corank (from
), gfc_get_corank (to
));
3434 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3435 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3436 and cmp2 are allocatable. After the allocation is transferred,
3437 the 'to' chain is broken by the nullification of the 'from'. A bit
3438 of reflection reveals that this can only occur for derived types
3439 with recursive allocatable components. */
3440 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
3441 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
3443 gfc_ref
*to_ref
, *from_ref
;
3445 from_ref
= from
->ref
;
3446 bool aliasing
= true;
3448 for (; from_ref
&& to_ref
;
3449 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
3451 if (to_ref
->type
!= from
->ref
->type
)
3453 else if (to_ref
->type
== REF_ARRAY
3454 && to_ref
->u
.ar
.type
!= AR_FULL
3455 && from_ref
->u
.ar
.type
!= AR_FULL
)
3456 /* Play safe; assume sections and elements are different. */
3458 else if (to_ref
->type
== REF_COMPONENT
3459 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
3468 gfc_error ("The FROM and TO arguments at %L violate aliasing "
3469 "restrictions (F2003 12.4.1.7)", &to
->where
);
3474 /* CLASS arguments: Make sure the vtab of from is present. */
3475 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
3476 gfc_find_vtab (&from
->ts
);
3483 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
3485 if (!type_check (x
, 0, BT_REAL
))
3488 if (!type_check (s
, 1, BT_REAL
))
3491 if (s
->expr_type
== EXPR_CONSTANT
)
3493 if (mpfr_sgn (s
->value
.real
) == 0)
3495 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
3506 gfc_check_new_line (gfc_expr
*a
)
3508 if (!type_check (a
, 0, BT_CHARACTER
))
3516 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
3518 if (!type_check (array
, 0, BT_REAL
))
3521 if (!array_check (array
, 0))
3524 if (!dim_rank_check (dim
, array
, false))
3531 gfc_check_null (gfc_expr
*mold
)
3533 symbol_attribute attr
;
3538 if (!variable_check (mold
, 0, true))
3541 attr
= gfc_variable_attr (mold
, NULL
);
3543 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
3545 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
3546 "ALLOCATABLE or procedure pointer",
3547 gfc_current_intrinsic_arg
[0]->name
,
3548 gfc_current_intrinsic
, &mold
->where
);
3552 if (attr
.allocatable
3553 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
3554 "allocatable MOLD at %L", &mold
->where
))
3558 if (gfc_is_coindexed (mold
))
3560 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
3561 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
3562 gfc_current_intrinsic
, &mold
->where
);
3571 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
3573 if (!array_check (array
, 0))
3576 if (!type_check (mask
, 1, BT_LOGICAL
))
3579 if (!gfc_check_conformance (array
, mask
,
3580 "arguments '%s' and '%s' for intrinsic '%s'",
3581 gfc_current_intrinsic_arg
[0]->name
,
3582 gfc_current_intrinsic_arg
[1]->name
,
3583 gfc_current_intrinsic
))
3588 mpz_t array_size
, vector_size
;
3589 bool have_array_size
, have_vector_size
;
3591 if (!same_type_check (array
, 0, vector
, 2))
3594 if (!rank_check (vector
, 2, 1))
3597 /* VECTOR requires at least as many elements as MASK
3598 has .TRUE. values. */
3599 have_array_size
= gfc_array_size(array
, &array_size
);
3600 have_vector_size
= gfc_array_size(vector
, &vector_size
);
3602 if (have_vector_size
3603 && (mask
->expr_type
== EXPR_ARRAY
3604 || (mask
->expr_type
== EXPR_CONSTANT
3605 && have_array_size
)))
3607 int mask_true_values
= 0;
3609 if (mask
->expr_type
== EXPR_ARRAY
)
3611 gfc_constructor
*mask_ctor
;
3612 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
3615 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
3617 mask_true_values
= 0;
3621 if (mask_ctor
->expr
->value
.logical
)
3624 mask_ctor
= gfc_constructor_next (mask_ctor
);
3627 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
3628 mask_true_values
= mpz_get_si (array_size
);
3630 if (mpz_get_si (vector_size
) < mask_true_values
)
3632 gfc_error ("%qs argument of %qs intrinsic at %L must "
3633 "provide at least as many elements as there "
3634 "are .TRUE. values in %qs (%ld/%d)",
3635 gfc_current_intrinsic_arg
[2]->name
,
3636 gfc_current_intrinsic
, &vector
->where
,
3637 gfc_current_intrinsic_arg
[1]->name
,
3638 mpz_get_si (vector_size
), mask_true_values
);
3643 if (have_array_size
)
3644 mpz_clear (array_size
);
3645 if (have_vector_size
)
3646 mpz_clear (vector_size
);
3654 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
3656 if (!type_check (mask
, 0, BT_LOGICAL
))
3659 if (!array_check (mask
, 0))
3662 if (!dim_rank_check (dim
, mask
, false))
3670 gfc_check_precision (gfc_expr
*x
)
3672 if (!real_or_complex_check (x
, 0))
3680 gfc_check_present (gfc_expr
*a
)
3684 if (!variable_check (a
, 0, true))
3687 sym
= a
->symtree
->n
.sym
;
3688 if (!sym
->attr
.dummy
)
3690 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
3691 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3692 gfc_current_intrinsic
, &a
->where
);
3696 if (!sym
->attr
.optional
)
3698 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3699 "an OPTIONAL dummy variable",
3700 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3705 /* 13.14.82 PRESENT(A)
3707 Argument. A shall be the name of an optional dummy argument that is
3708 accessible in the subprogram in which the PRESENT function reference
3712 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3713 && (a
->ref
->u
.ar
.type
== AR_FULL
3714 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3715 && a
->ref
->u
.ar
.as
->rank
== 0))))
3717 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
3718 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
3719 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3728 gfc_check_radix (gfc_expr
*x
)
3730 if (!int_or_real_check (x
, 0))
3738 gfc_check_range (gfc_expr
*x
)
3740 if (!numeric_check (x
, 0))
3748 gfc_check_rank (gfc_expr
*a
)
3750 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3751 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3753 bool is_variable
= true;
3755 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3756 if (a
->expr_type
== EXPR_FUNCTION
)
3757 is_variable
= a
->value
.function
.esym
3758 ? a
->value
.function
.esym
->result
->attr
.pointer
3759 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3761 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3762 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3765 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3766 "object", &a
->where
);
3774 /* real, float, sngl. */
3776 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3778 if (!numeric_check (a
, 0))
3781 if (!kind_check (kind
, 1, BT_REAL
))
3789 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3791 if (!type_check (path1
, 0, BT_CHARACTER
))
3793 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3796 if (!type_check (path2
, 1, BT_CHARACTER
))
3798 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3806 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3808 if (!type_check (path1
, 0, BT_CHARACTER
))
3810 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3813 if (!type_check (path2
, 1, BT_CHARACTER
))
3815 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3821 if (!type_check (status
, 2, BT_INTEGER
))
3824 if (!scalar_check (status
, 2))
3832 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3834 if (!type_check (x
, 0, BT_CHARACTER
))
3837 if (!scalar_check (x
, 0))
3840 if (!type_check (y
, 0, BT_INTEGER
))
3843 if (!scalar_check (y
, 1))
3851 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3852 gfc_expr
*pad
, gfc_expr
*order
)
3858 if (!array_check (source
, 0))
3861 if (!rank_check (shape
, 1, 1))
3864 if (!type_check (shape
, 1, BT_INTEGER
))
3867 if (!gfc_array_size (shape
, &size
))
3869 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
3870 "array of constant size", &shape
->where
);
3874 shape_size
= mpz_get_ui (size
);
3877 if (shape_size
<= 0)
3879 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
3880 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3884 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3886 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
3887 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3890 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
3894 for (i
= 0; i
< shape_size
; ++i
)
3896 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3897 if (e
->expr_type
!= EXPR_CONSTANT
)
3900 gfc_extract_int (e
, &extent
);
3903 gfc_error ("%qs argument of %qs intrinsic at %L has "
3904 "negative element (%d)",
3905 gfc_current_intrinsic_arg
[1]->name
,
3906 gfc_current_intrinsic
, &e
->where
, extent
);
3911 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
3912 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
3913 && shape
->ref
->u
.ar
.as
3914 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
3915 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
3916 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
3917 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
3918 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
3923 v
= shape
->symtree
->n
.sym
->value
;
3925 for (i
= 0; i
< shape_size
; i
++)
3927 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
3931 gfc_extract_int (e
, &extent
);
3935 gfc_error ("Element %d of actual argument of RESHAPE at %L "
3936 "cannot be negative", i
+ 1, &shape
->where
);
3944 if (!same_type_check (source
, 0, pad
, 2))
3947 if (!array_check (pad
, 2))
3953 if (!array_check (order
, 3))
3956 if (!type_check (order
, 3, BT_INTEGER
))
3959 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
3961 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3964 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3967 gfc_array_size (order
, &size
);
3968 order_size
= mpz_get_ui (size
);
3971 if (order_size
!= shape_size
)
3973 gfc_error ("%qs argument of %qs intrinsic at %L "
3974 "has wrong number of elements (%d/%d)",
3975 gfc_current_intrinsic_arg
[3]->name
,
3976 gfc_current_intrinsic
, &order
->where
,
3977 order_size
, shape_size
);
3981 for (i
= 1; i
<= order_size
; ++i
)
3983 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3984 if (e
->expr_type
!= EXPR_CONSTANT
)
3987 gfc_extract_int (e
, &dim
);
3989 if (dim
< 1 || dim
> order_size
)
3991 gfc_error ("%qs argument of %qs intrinsic at %L "
3992 "has out-of-range dimension (%d)",
3993 gfc_current_intrinsic_arg
[3]->name
,
3994 gfc_current_intrinsic
, &e
->where
, dim
);
3998 if (perm
[dim
-1] != 0)
4000 gfc_error ("%qs argument of %qs intrinsic at %L has "
4001 "invalid permutation of dimensions (dimension "
4003 gfc_current_intrinsic_arg
[3]->name
,
4004 gfc_current_intrinsic
, &e
->where
, dim
);
4013 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4014 && gfc_is_constant_expr (shape
)
4015 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4016 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4018 /* Check the match in size between source and destination. */
4019 if (gfc_array_size (source
, &nelems
))
4025 mpz_init_set_ui (size
, 1);
4026 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4027 c
; c
= gfc_constructor_next (c
))
4028 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4030 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4036 gfc_error ("Without padding, there are not enough elements "
4037 "in the intrinsic RESHAPE source at %L to match "
4038 "the shape", &source
->where
);
4049 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4051 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4053 gfc_error ("%qs argument of %qs intrinsic at %L "
4054 "cannot be of type %s",
4055 gfc_current_intrinsic_arg
[0]->name
,
4056 gfc_current_intrinsic
,
4057 &a
->where
, gfc_typename (&a
->ts
));
4061 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4063 gfc_error ("%qs argument of %qs intrinsic at %L "
4064 "must be of an extensible type",
4065 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4070 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4072 gfc_error ("%qs argument of %qs intrinsic at %L "
4073 "cannot be of type %s",
4074 gfc_current_intrinsic_arg
[0]->name
,
4075 gfc_current_intrinsic
,
4076 &b
->where
, gfc_typename (&b
->ts
));
4080 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4082 gfc_error ("%qs argument of %qs intrinsic at %L "
4083 "must be of an extensible type",
4084 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4094 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4096 if (!type_check (x
, 0, BT_REAL
))
4099 if (!type_check (i
, 1, BT_INTEGER
))
4107 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4109 if (!type_check (x
, 0, BT_CHARACTER
))
4112 if (!type_check (y
, 1, BT_CHARACTER
))
4115 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4118 if (!kind_check (kind
, 3, BT_INTEGER
))
4120 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4121 "with KIND argument at %L",
4122 gfc_current_intrinsic
, &kind
->where
))
4125 if (!same_type_check (x
, 0, y
, 1))
4133 gfc_check_secnds (gfc_expr
*r
)
4135 if (!type_check (r
, 0, BT_REAL
))
4138 if (!kind_value_check (r
, 0, 4))
4141 if (!scalar_check (r
, 0))
4149 gfc_check_selected_char_kind (gfc_expr
*name
)
4151 if (!type_check (name
, 0, BT_CHARACTER
))
4154 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4157 if (!scalar_check (name
, 0))
4165 gfc_check_selected_int_kind (gfc_expr
*r
)
4167 if (!type_check (r
, 0, BT_INTEGER
))
4170 if (!scalar_check (r
, 0))
4178 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4180 if (p
== NULL
&& r
== NULL
4181 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4182 " neither %<P%> nor %<R%> argument at %L",
4183 gfc_current_intrinsic_where
))
4188 if (!type_check (p
, 0, BT_INTEGER
))
4191 if (!scalar_check (p
, 0))
4197 if (!type_check (r
, 1, BT_INTEGER
))
4200 if (!scalar_check (r
, 1))
4206 if (!type_check (radix
, 1, BT_INTEGER
))
4209 if (!scalar_check (radix
, 1))
4212 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
4213 "RADIX argument at %L", gfc_current_intrinsic
,
4223 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
4225 if (!type_check (x
, 0, BT_REAL
))
4228 if (!type_check (i
, 1, BT_INTEGER
))
4236 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
4240 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
4243 ar
= gfc_find_array_ref (source
);
4245 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
4247 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
4248 "an assumed size array", &source
->where
);
4252 if (!kind_check (kind
, 1, BT_INTEGER
))
4254 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4255 "with KIND argument at %L",
4256 gfc_current_intrinsic
, &kind
->where
))
4264 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
4266 if (!type_check (i
, 0, BT_INTEGER
))
4269 if (!type_check (shift
, 0, BT_INTEGER
))
4272 if (!nonnegative_check ("SHIFT", shift
))
4275 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
4283 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
4285 if (!int_or_real_check (a
, 0))
4288 if (!same_type_check (a
, 0, b
, 1))
4296 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4298 if (!array_check (array
, 0))
4301 if (!dim_check (dim
, 1, true))
4304 if (!dim_rank_check (dim
, array
, 0))
4307 if (!kind_check (kind
, 2, BT_INTEGER
))
4309 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4310 "with KIND argument at %L",
4311 gfc_current_intrinsic
, &kind
->where
))
4320 gfc_check_sizeof (gfc_expr
*arg
)
4322 if (arg
->ts
.type
== BT_PROCEDURE
)
4324 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
4325 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4330 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4331 if (arg
->ts
.type
== BT_ASSUMED
4332 && (arg
->symtree
->n
.sym
->as
== NULL
4333 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
4334 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
4335 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
4337 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
4338 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4343 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4344 && arg
->symtree
->n
.sym
->as
!= NULL
4345 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4346 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4348 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4349 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4350 gfc_current_intrinsic
, &arg
->where
);
4358 /* Check whether an expression is interoperable. When returning false,
4359 msg is set to a string telling why the expression is not interoperable,
4360 otherwise, it is set to NULL. The msg string can be used in diagnostics.
4361 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4362 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
4363 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
4367 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
4371 if (expr
->ts
.type
== BT_CLASS
)
4373 *msg
= "Expression is polymorphic";
4377 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
4378 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
4380 *msg
= "Expression is a noninteroperable derived type";
4384 if (expr
->ts
.type
== BT_PROCEDURE
)
4386 *msg
= "Procedure unexpected as argument";
4390 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
4393 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
4394 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
4396 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
4400 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
4401 && expr
->ts
.kind
!= 1)
4403 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
4407 if (expr
->ts
.type
== BT_CHARACTER
) {
4408 if (expr
->ts
.deferred
)
4410 /* TS 29113 allows deferred-length strings as dummy arguments,
4411 but it is not an interoperable type. */
4412 *msg
= "Expression shall not be a deferred-length string";
4416 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
4417 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
4418 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4420 if (!c_loc
&& expr
->ts
.u
.cl
4421 && (!expr
->ts
.u
.cl
->length
4422 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4423 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
4425 *msg
= "Type shall have a character length of 1";
4430 /* Note: The following checks are about interoperatable variables, Fortran
4431 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4432 is allowed, e.g. assumed-shape arrays with TS 29113. */
4434 if (gfc_is_coarray (expr
))
4436 *msg
= "Coarrays are not interoperable";
4440 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
4442 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
4443 if (ar
->type
!= AR_FULL
)
4445 *msg
= "Only whole-arrays are interoperable";
4448 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
4449 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
4451 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
4461 gfc_check_c_sizeof (gfc_expr
*arg
)
4465 if (!is_c_interoperable (arg
, &msg
, false, false))
4467 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
4468 "interoperable data entity: %s",
4469 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4474 if (arg
->ts
.type
== BT_ASSUMED
)
4476 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4478 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4483 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
4484 && arg
->symtree
->n
.sym
->as
!= NULL
4485 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
4486 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
4488 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
4489 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
4490 gfc_current_intrinsic
, &arg
->where
);
4499 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
4501 if (c_ptr_1
->ts
.type
!= BT_DERIVED
4502 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4503 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
4504 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
4506 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
4507 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
4511 if (!scalar_check (c_ptr_1
, 0))
4515 && (c_ptr_2
->ts
.type
!= BT_DERIVED
4516 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4517 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
4518 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
4520 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
4521 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
4522 gfc_typename (&c_ptr_1
->ts
),
4523 gfc_typename (&c_ptr_2
->ts
));
4527 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
4535 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
4537 symbol_attribute attr
;
4540 if (cptr
->ts
.type
!= BT_DERIVED
4541 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4542 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
4544 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
4545 "type TYPE(C_PTR)", &cptr
->where
);
4549 if (!scalar_check (cptr
, 0))
4552 attr
= gfc_expr_attr (fptr
);
4556 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
4561 if (fptr
->ts
.type
== BT_CLASS
)
4563 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
4568 if (gfc_is_coindexed (fptr
))
4570 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
4571 "coindexed", &fptr
->where
);
4575 if (fptr
->rank
== 0 && shape
)
4577 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
4578 "FPTR", &fptr
->where
);
4581 else if (fptr
->rank
&& !shape
)
4583 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
4584 "FPTR at %L", &fptr
->where
);
4588 if (shape
&& !rank_check (shape
, 2, 1))
4591 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
4597 if (gfc_array_size (shape
, &size
))
4599 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
4602 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
4603 "size as the RANK of FPTR", &shape
->where
);
4610 if (fptr
->ts
.type
== BT_CLASS
)
4612 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
4616 if (!is_c_interoperable (fptr
, &msg
, false, true))
4617 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable array FPTR "
4618 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
4625 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
4627 symbol_attribute attr
;
4629 if (cptr
->ts
.type
!= BT_DERIVED
4630 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
4631 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
4633 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
4634 "type TYPE(C_FUNPTR)", &cptr
->where
);
4638 if (!scalar_check (cptr
, 0))
4641 attr
= gfc_expr_attr (fptr
);
4643 if (!attr
.proc_pointer
)
4645 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4646 "pointer", &fptr
->where
);
4650 if (gfc_is_coindexed (fptr
))
4652 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4653 "coindexed", &fptr
->where
);
4657 if (!attr
.is_bind_c
)
4658 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4659 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
4666 gfc_check_c_funloc (gfc_expr
*x
)
4668 symbol_attribute attr
;
4670 if (gfc_is_coindexed (x
))
4672 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4673 "coindexed", &x
->where
);
4677 attr
= gfc_expr_attr (x
);
4679 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
4680 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
4682 gfc_namespace
*ns
= gfc_current_ns
;
4684 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4685 if (x
->symtree
->n
.sym
== ns
->proc_name
)
4687 gfc_error ("Function result %qs at %L is invalid as X argument "
4688 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
4693 if (attr
.flavor
!= FL_PROCEDURE
)
4695 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4696 "or a procedure pointer", &x
->where
);
4700 if (!attr
.is_bind_c
)
4701 return gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable procedure "
4702 "at %L to C_FUNLOC", &x
->where
);
4708 gfc_check_c_loc (gfc_expr
*x
)
4710 symbol_attribute attr
;
4713 if (gfc_is_coindexed (x
))
4715 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
4719 if (x
->ts
.type
== BT_CLASS
)
4721 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4726 attr
= gfc_expr_attr (x
);
4729 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
4730 || attr
.flavor
== FL_PARAMETER
))
4732 gfc_error ("Argument X at %L to C_LOC shall have either "
4733 "the POINTER or the TARGET attribute", &x
->where
);
4737 if (x
->ts
.type
== BT_CHARACTER
4738 && gfc_var_strlen (x
) == 0)
4740 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4741 "string", &x
->where
);
4745 if (!is_c_interoperable (x
, &msg
, true, false))
4747 if (x
->ts
.type
== BT_CLASS
)
4749 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4755 && !gfc_notify_std (GFC_STD_F2008_TS
,
4756 "Noninteroperable array at %L as"
4757 " argument to C_LOC: %s", &x
->where
, msg
))
4760 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
4762 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
4764 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
4765 && !attr
.allocatable
4766 && !gfc_notify_std (GFC_STD_F2008
,
4767 "Array of interoperable type at %L "
4768 "to C_LOC which is nonallocatable and neither "
4769 "assumed size nor explicit size", &x
->where
))
4771 else if (ar
->type
!= AR_FULL
4772 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
4773 "to C_LOC", &x
->where
))
4782 gfc_check_sleep_sub (gfc_expr
*seconds
)
4784 if (!type_check (seconds
, 0, BT_INTEGER
))
4787 if (!scalar_check (seconds
, 0))
4794 gfc_check_sngl (gfc_expr
*a
)
4796 if (!type_check (a
, 0, BT_REAL
))
4799 if ((a
->ts
.kind
!= gfc_default_double_kind
)
4800 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
4801 "REAL argument to %s intrinsic at %L",
4802 gfc_current_intrinsic
, &a
->where
))
4809 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
4811 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
4813 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
4814 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
4815 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
4823 if (!dim_check (dim
, 1, false))
4826 /* dim_rank_check() does not apply here. */
4828 && dim
->expr_type
== EXPR_CONSTANT
4829 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
4830 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
4832 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
4833 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
4834 gfc_current_intrinsic
, &dim
->where
);
4838 if (!type_check (ncopies
, 2, BT_INTEGER
))
4841 if (!scalar_check (ncopies
, 2))
4848 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4852 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
4854 if (!type_check (unit
, 0, BT_INTEGER
))
4857 if (!scalar_check (unit
, 0))
4860 if (!type_check (c
, 1, BT_CHARACTER
))
4862 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
4868 if (!type_check (status
, 2, BT_INTEGER
)
4869 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
4870 || !scalar_check (status
, 2))
4878 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
4880 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
4885 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
4887 if (!type_check (c
, 0, BT_CHARACTER
))
4889 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
4895 if (!type_check (status
, 1, BT_INTEGER
)
4896 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
4897 || !scalar_check (status
, 1))
4905 gfc_check_fgetput (gfc_expr
*c
)
4907 return gfc_check_fgetput_sub (c
, NULL
);
4912 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
4914 if (!type_check (unit
, 0, BT_INTEGER
))
4917 if (!scalar_check (unit
, 0))
4920 if (!type_check (offset
, 1, BT_INTEGER
))
4923 if (!scalar_check (offset
, 1))
4926 if (!type_check (whence
, 2, BT_INTEGER
))
4929 if (!scalar_check (whence
, 2))
4935 if (!type_check (status
, 3, BT_INTEGER
))
4938 if (!kind_value_check (status
, 3, 4))
4941 if (!scalar_check (status
, 3))
4950 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
4952 if (!type_check (unit
, 0, BT_INTEGER
))
4955 if (!scalar_check (unit
, 0))
4958 if (!type_check (array
, 1, BT_INTEGER
)
4959 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
4962 if (!array_check (array
, 1))
4970 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
4972 if (!type_check (unit
, 0, BT_INTEGER
))
4975 if (!scalar_check (unit
, 0))
4978 if (!type_check (array
, 1, BT_INTEGER
)
4979 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
4982 if (!array_check (array
, 1))
4988 if (!type_check (status
, 2, BT_INTEGER
)
4989 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
4992 if (!scalar_check (status
, 2))
5000 gfc_check_ftell (gfc_expr
*unit
)
5002 if (!type_check (unit
, 0, BT_INTEGER
))
5005 if (!scalar_check (unit
, 0))
5013 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5015 if (!type_check (unit
, 0, BT_INTEGER
))
5018 if (!scalar_check (unit
, 0))
5021 if (!type_check (offset
, 1, BT_INTEGER
))
5024 if (!scalar_check (offset
, 1))
5032 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5034 if (!type_check (name
, 0, BT_CHARACTER
))
5036 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5039 if (!type_check (array
, 1, BT_INTEGER
)
5040 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5043 if (!array_check (array
, 1))
5051 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5053 if (!type_check (name
, 0, BT_CHARACTER
))
5055 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5058 if (!type_check (array
, 1, BT_INTEGER
)
5059 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5062 if (!array_check (array
, 1))
5068 if (!type_check (status
, 2, BT_INTEGER
)
5069 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5072 if (!scalar_check (status
, 2))
5080 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5084 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5086 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5090 if (!coarray_check (coarray
, 0))
5095 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5096 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5100 if (gfc_array_size (sub
, &nelems
))
5102 int corank
= gfc_get_corank (coarray
);
5104 if (mpz_cmp_ui (nelems
, corank
) != 0)
5106 gfc_error ("The number of array elements of the SUB argument to "
5107 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5108 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5120 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5122 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5124 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5130 if (!type_check (distance
, 0, BT_INTEGER
))
5133 if (!nonnegative_check ("DISTANCE", distance
))
5136 if (!scalar_check (distance
, 0))
5139 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5140 "NUM_IMAGES at %L", &distance
->where
))
5146 if (!type_check (failed
, 1, BT_LOGICAL
))
5149 if (!scalar_check (failed
, 1))
5152 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAILED= argument to "
5153 "NUM_IMAGES at %L", &failed
->where
))
5162 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5164 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5166 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5170 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
5173 if (dim
!= NULL
&& coarray
== NULL
)
5175 gfc_error ("DIM argument without COARRAY argument not allowed for "
5176 "THIS_IMAGE intrinsic at %L", &dim
->where
);
5180 if (distance
&& (coarray
|| dim
))
5182 gfc_error ("The DISTANCE argument may not be specified together with the "
5183 "COARRAY or DIM argument in intrinsic at %L",
5188 /* Assume that we have "this_image (distance)". */
5189 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
5193 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5202 if (!type_check (distance
, 2, BT_INTEGER
))
5205 if (!nonnegative_check ("DISTANCE", distance
))
5208 if (!scalar_check (distance
, 2))
5211 if (!gfc_notify_std (GFC_STD_F2008_TS
, "DISTANCE= argument to "
5212 "THIS_IMAGE at %L", &distance
->where
))
5218 if (!coarray_check (coarray
, 0))
5223 if (!dim_check (dim
, 1, false))
5226 if (!dim_corank_check (dim
, coarray
))
5233 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
5234 by gfc_simplify_transfer. Return false if we cannot do so. */
5237 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
5238 size_t *source_size
, size_t *result_size
,
5239 size_t *result_length_p
)
5241 size_t result_elt_size
;
5243 if (source
->expr_type
== EXPR_FUNCTION
)
5246 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
5249 /* Calculate the size of the source. */
5250 *source_size
= gfc_target_expr_size (source
);
5251 if (*source_size
== 0)
5254 /* Determine the size of the element. */
5255 result_elt_size
= gfc_element_size (mold
);
5256 if (result_elt_size
== 0)
5259 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
5264 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
5267 result_length
= *source_size
/ result_elt_size
;
5268 if (result_length
* result_elt_size
< *source_size
)
5272 *result_size
= result_length
* result_elt_size
;
5273 if (result_length_p
)
5274 *result_length_p
= result_length
;
5277 *result_size
= result_elt_size
;
5284 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
5289 if (mold
->ts
.type
== BT_HOLLERITH
)
5291 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5292 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
5298 if (!type_check (size
, 2, BT_INTEGER
))
5301 if (!scalar_check (size
, 2))
5304 if (!nonoptional_check (size
, 2))
5308 if (!warn_surprising
)
5311 /* If we can't calculate the sizes, we cannot check any more.
5312 Return true for that case. */
5314 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
5315 &result_size
, NULL
))
5318 if (source_size
< result_size
)
5319 gfc_warning (OPT_Wsurprising
,
5320 "Intrinsic TRANSFER at %L has partly undefined result: "
5321 "source size %ld < result size %ld", &source
->where
,
5322 (long) source_size
, (long) result_size
);
5329 gfc_check_transpose (gfc_expr
*matrix
)
5331 if (!rank_check (matrix
, 0, 2))
5339 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5341 if (!array_check (array
, 0))
5344 if (!dim_check (dim
, 1, false))
5347 if (!dim_rank_check (dim
, array
, 0))
5350 if (!kind_check (kind
, 2, BT_INTEGER
))
5352 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5353 "with KIND argument at %L",
5354 gfc_current_intrinsic
, &kind
->where
))
5362 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
5364 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5366 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5370 if (!coarray_check (coarray
, 0))
5375 if (!dim_check (dim
, 1, false))
5378 if (!dim_corank_check (dim
, coarray
))
5382 if (!kind_check (kind
, 2, BT_INTEGER
))
5390 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
5394 if (!rank_check (vector
, 0, 1))
5397 if (!array_check (mask
, 1))
5400 if (!type_check (mask
, 1, BT_LOGICAL
))
5403 if (!same_type_check (vector
, 0, field
, 2))
5406 if (mask
->expr_type
== EXPR_ARRAY
5407 && gfc_array_size (vector
, &vector_size
))
5409 int mask_true_count
= 0;
5410 gfc_constructor
*mask_ctor
;
5411 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5414 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
5416 mask_true_count
= 0;
5420 if (mask_ctor
->expr
->value
.logical
)
5423 mask_ctor
= gfc_constructor_next (mask_ctor
);
5426 if (mpz_get_si (vector_size
) < mask_true_count
)
5428 gfc_error ("%qs argument of %qs intrinsic at %L must "
5429 "provide at least as many elements as there "
5430 "are .TRUE. values in %qs (%ld/%d)",
5431 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5432 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
5433 mpz_get_si (vector_size
), mask_true_count
);
5437 mpz_clear (vector_size
);
5440 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
5442 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5443 "the same rank as %qs or be a scalar",
5444 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5445 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
5449 if (mask
->rank
== field
->rank
)
5452 for (i
= 0; i
< field
->rank
; i
++)
5453 if (! identical_dimen_shape (mask
, i
, field
, i
))
5455 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
5456 "must have identical shape.",
5457 gfc_current_intrinsic_arg
[2]->name
,
5458 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5468 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
5470 if (!type_check (x
, 0, BT_CHARACTER
))
5473 if (!same_type_check (x
, 0, y
, 1))
5476 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
5479 if (!kind_check (kind
, 3, BT_INTEGER
))
5481 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5482 "with KIND argument at %L",
5483 gfc_current_intrinsic
, &kind
->where
))
5491 gfc_check_trim (gfc_expr
*x
)
5493 if (!type_check (x
, 0, BT_CHARACTER
))
5496 if (!scalar_check (x
, 0))
5504 gfc_check_ttynam (gfc_expr
*unit
)
5506 if (!scalar_check (unit
, 0))
5509 if (!type_check (unit
, 0, BT_INTEGER
))
5516 /************* Check functions for intrinsic subroutines *************/
5519 gfc_check_cpu_time (gfc_expr
*time
)
5521 if (!scalar_check (time
, 0))
5524 if (!type_check (time
, 0, BT_REAL
))
5527 if (!variable_check (time
, 0, false))
5535 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
5536 gfc_expr
*zone
, gfc_expr
*values
)
5540 if (!type_check (date
, 0, BT_CHARACTER
))
5542 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
5544 if (!scalar_check (date
, 0))
5546 if (!variable_check (date
, 0, false))
5552 if (!type_check (time
, 1, BT_CHARACTER
))
5554 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
5556 if (!scalar_check (time
, 1))
5558 if (!variable_check (time
, 1, false))
5564 if (!type_check (zone
, 2, BT_CHARACTER
))
5566 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
5568 if (!scalar_check (zone
, 2))
5570 if (!variable_check (zone
, 2, false))
5576 if (!type_check (values
, 3, BT_INTEGER
))
5578 if (!array_check (values
, 3))
5580 if (!rank_check (values
, 3, 1))
5582 if (!variable_check (values
, 3, false))
5591 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
5592 gfc_expr
*to
, gfc_expr
*topos
)
5594 if (!type_check (from
, 0, BT_INTEGER
))
5597 if (!type_check (frompos
, 1, BT_INTEGER
))
5600 if (!type_check (len
, 2, BT_INTEGER
))
5603 if (!same_type_check (from
, 0, to
, 3))
5606 if (!variable_check (to
, 3, false))
5609 if (!type_check (topos
, 4, BT_INTEGER
))
5612 if (!nonnegative_check ("frompos", frompos
))
5615 if (!nonnegative_check ("topos", topos
))
5618 if (!nonnegative_check ("len", len
))
5621 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
5624 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
5632 gfc_check_random_number (gfc_expr
*harvest
)
5634 if (!type_check (harvest
, 0, BT_REAL
))
5637 if (!variable_check (harvest
, 0, false))
5645 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
5647 unsigned int nargs
= 0, seed_size
;
5648 locus
*where
= NULL
;
5649 mpz_t put_size
, get_size
;
5651 /* Keep the number of bytes in sync with master_state in
5652 libgfortran/intrinsics/random.c. +1 due to the integer p which is
5653 part of the state too. */
5654 seed_size
= 128 / gfc_default_integer_kind
+ 1;
5658 if (size
->expr_type
!= EXPR_VARIABLE
5659 || !size
->symtree
->n
.sym
->attr
.optional
)
5662 if (!scalar_check (size
, 0))
5665 if (!type_check (size
, 0, BT_INTEGER
))
5668 if (!variable_check (size
, 0, false))
5671 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
5677 if (put
->expr_type
!= EXPR_VARIABLE
5678 || !put
->symtree
->n
.sym
->attr
.optional
)
5681 where
= &put
->where
;
5684 if (!array_check (put
, 1))
5687 if (!rank_check (put
, 1, 1))
5690 if (!type_check (put
, 1, BT_INTEGER
))
5693 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
5696 if (gfc_array_size (put
, &put_size
)
5697 && mpz_get_ui (put_size
) < seed_size
)
5698 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5699 "too small (%i/%i)",
5700 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5701 where
, (int) mpz_get_ui (put_size
), seed_size
);
5706 if (get
->expr_type
!= EXPR_VARIABLE
5707 || !get
->symtree
->n
.sym
->attr
.optional
)
5710 where
= &get
->where
;
5713 if (!array_check (get
, 2))
5716 if (!rank_check (get
, 2, 1))
5719 if (!type_check (get
, 2, BT_INTEGER
))
5722 if (!variable_check (get
, 2, false))
5725 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
5728 if (gfc_array_size (get
, &get_size
)
5729 && mpz_get_ui (get_size
) < seed_size
)
5730 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
5731 "too small (%i/%i)",
5732 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
5733 where
, (int) mpz_get_ui (get_size
), seed_size
);
5736 /* RANDOM_SEED may not have more than one non-optional argument. */
5738 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
5744 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
5748 int num_percent
, nargs
;
5751 if (e
->expr_type
!= EXPR_CONSTANT
)
5754 len
= e
->value
.character
.length
;
5755 if (e
->value
.character
.string
[len
-1] != '\0')
5756 gfc_internal_error ("fe_runtime_error string must be null terminated");
5759 for (i
=0; i
<len
-1; i
++)
5760 if (e
->value
.character
.string
[i
] == '%')
5764 for (; a
; a
= a
->next
)
5767 if (nargs
-1 != num_percent
)
5768 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
5769 nargs
, num_percent
++);
5775 gfc_check_second_sub (gfc_expr
*time
)
5777 if (!scalar_check (time
, 0))
5780 if (!type_check (time
, 0, BT_REAL
))
5783 if (!kind_value_check (time
, 0, 4))
5790 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
5791 variables in Fortran 95. In Fortran 2003 and later, they can be of any
5792 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
5793 count_max are all optional arguments */
5796 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
5797 gfc_expr
*count_max
)
5801 if (!scalar_check (count
, 0))
5804 if (!type_check (count
, 0, BT_INTEGER
))
5807 if (count
->ts
.kind
!= gfc_default_integer_kind
5808 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
5809 "SYSTEM_CLOCK at %L has non-default kind",
5813 if (!variable_check (count
, 0, false))
5817 if (count_rate
!= NULL
)
5819 if (!scalar_check (count_rate
, 1))
5822 if (!variable_check (count_rate
, 1, false))
5825 if (count_rate
->ts
.type
== BT_REAL
)
5827 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
5828 "SYSTEM_CLOCK at %L", &count_rate
->where
))
5833 if (!type_check (count_rate
, 1, BT_INTEGER
))
5836 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
5837 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
5838 "SYSTEM_CLOCK at %L has non-default kind",
5839 &count_rate
->where
))
5845 if (count_max
!= NULL
)
5847 if (!scalar_check (count_max
, 2))
5850 if (!type_check (count_max
, 2, BT_INTEGER
))
5853 if (count_max
->ts
.kind
!= gfc_default_integer_kind
5854 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
5855 "SYSTEM_CLOCK at %L has non-default kind",
5859 if (!variable_check (count_max
, 2, false))
5868 gfc_check_irand (gfc_expr
*x
)
5873 if (!scalar_check (x
, 0))
5876 if (!type_check (x
, 0, BT_INTEGER
))
5879 if (!kind_value_check (x
, 0, 4))
5887 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
5889 if (!scalar_check (seconds
, 0))
5891 if (!type_check (seconds
, 0, BT_INTEGER
))
5894 if (!int_or_proc_check (handler
, 1))
5896 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
5902 if (!scalar_check (status
, 2))
5904 if (!type_check (status
, 2, BT_INTEGER
))
5906 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
5914 gfc_check_rand (gfc_expr
*x
)
5919 if (!scalar_check (x
, 0))
5922 if (!type_check (x
, 0, BT_INTEGER
))
5925 if (!kind_value_check (x
, 0, 4))
5933 gfc_check_srand (gfc_expr
*x
)
5935 if (!scalar_check (x
, 0))
5938 if (!type_check (x
, 0, BT_INTEGER
))
5941 if (!kind_value_check (x
, 0, 4))
5949 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
5951 if (!scalar_check (time
, 0))
5953 if (!type_check (time
, 0, BT_INTEGER
))
5956 if (!type_check (result
, 1, BT_CHARACTER
))
5958 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
5966 gfc_check_dtime_etime (gfc_expr
*x
)
5968 if (!array_check (x
, 0))
5971 if (!rank_check (x
, 0, 1))
5974 if (!variable_check (x
, 0, false))
5977 if (!type_check (x
, 0, BT_REAL
))
5980 if (!kind_value_check (x
, 0, 4))
5988 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
5990 if (!array_check (values
, 0))
5993 if (!rank_check (values
, 0, 1))
5996 if (!variable_check (values
, 0, false))
5999 if (!type_check (values
, 0, BT_REAL
))
6002 if (!kind_value_check (values
, 0, 4))
6005 if (!scalar_check (time
, 1))
6008 if (!type_check (time
, 1, BT_REAL
))
6011 if (!kind_value_check (time
, 1, 4))
6019 gfc_check_fdate_sub (gfc_expr
*date
)
6021 if (!type_check (date
, 0, BT_CHARACTER
))
6023 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6031 gfc_check_gerror (gfc_expr
*msg
)
6033 if (!type_check (msg
, 0, BT_CHARACTER
))
6035 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6043 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6045 if (!type_check (cwd
, 0, BT_CHARACTER
))
6047 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6053 if (!scalar_check (status
, 1))
6056 if (!type_check (status
, 1, BT_INTEGER
))
6064 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6066 if (!type_check (pos
, 0, BT_INTEGER
))
6069 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6071 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6072 "not wider than the default kind (%d)",
6073 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6074 &pos
->where
, gfc_default_integer_kind
);
6078 if (!type_check (value
, 1, BT_CHARACTER
))
6080 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6088 gfc_check_getlog (gfc_expr
*msg
)
6090 if (!type_check (msg
, 0, BT_CHARACTER
))
6092 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6100 gfc_check_exit (gfc_expr
*status
)
6105 if (!type_check (status
, 0, BT_INTEGER
))
6108 if (!scalar_check (status
, 0))
6116 gfc_check_flush (gfc_expr
*unit
)
6121 if (!type_check (unit
, 0, BT_INTEGER
))
6124 if (!scalar_check (unit
, 0))
6132 gfc_check_free (gfc_expr
*i
)
6134 if (!type_check (i
, 0, BT_INTEGER
))
6137 if (!scalar_check (i
, 0))
6145 gfc_check_hostnm (gfc_expr
*name
)
6147 if (!type_check (name
, 0, BT_CHARACTER
))
6149 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6157 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
6159 if (!type_check (name
, 0, BT_CHARACTER
))
6161 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6167 if (!scalar_check (status
, 1))
6170 if (!type_check (status
, 1, BT_INTEGER
))
6178 gfc_check_itime_idate (gfc_expr
*values
)
6180 if (!array_check (values
, 0))
6183 if (!rank_check (values
, 0, 1))
6186 if (!variable_check (values
, 0, false))
6189 if (!type_check (values
, 0, BT_INTEGER
))
6192 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
6200 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
6202 if (!type_check (time
, 0, BT_INTEGER
))
6205 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
6208 if (!scalar_check (time
, 0))
6211 if (!array_check (values
, 1))
6214 if (!rank_check (values
, 1, 1))
6217 if (!variable_check (values
, 1, false))
6220 if (!type_check (values
, 1, BT_INTEGER
))
6223 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
6231 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
6233 if (!scalar_check (unit
, 0))
6236 if (!type_check (unit
, 0, BT_INTEGER
))
6239 if (!type_check (name
, 1, BT_CHARACTER
))
6241 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
6249 gfc_check_isatty (gfc_expr
*unit
)
6254 if (!type_check (unit
, 0, BT_INTEGER
))
6257 if (!scalar_check (unit
, 0))
6265 gfc_check_isnan (gfc_expr
*x
)
6267 if (!type_check (x
, 0, BT_REAL
))
6275 gfc_check_perror (gfc_expr
*string
)
6277 if (!type_check (string
, 0, BT_CHARACTER
))
6279 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
6287 gfc_check_umask (gfc_expr
*mask
)
6289 if (!type_check (mask
, 0, BT_INTEGER
))
6292 if (!scalar_check (mask
, 0))
6300 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
6302 if (!type_check (mask
, 0, BT_INTEGER
))
6305 if (!scalar_check (mask
, 0))
6311 if (!scalar_check (old
, 1))
6314 if (!type_check (old
, 1, BT_INTEGER
))
6322 gfc_check_unlink (gfc_expr
*name
)
6324 if (!type_check (name
, 0, BT_CHARACTER
))
6326 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6334 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
6336 if (!type_check (name
, 0, BT_CHARACTER
))
6338 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
6344 if (!scalar_check (status
, 1))
6347 if (!type_check (status
, 1, BT_INTEGER
))
6355 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
6357 if (!scalar_check (number
, 0))
6359 if (!type_check (number
, 0, BT_INTEGER
))
6362 if (!int_or_proc_check (handler
, 1))
6364 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6372 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
6374 if (!scalar_check (number
, 0))
6376 if (!type_check (number
, 0, BT_INTEGER
))
6379 if (!int_or_proc_check (handler
, 1))
6381 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6387 if (!type_check (status
, 2, BT_INTEGER
))
6389 if (!scalar_check (status
, 2))
6397 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
6399 if (!type_check (cmd
, 0, BT_CHARACTER
))
6401 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
6404 if (!scalar_check (status
, 1))
6407 if (!type_check (status
, 1, BT_INTEGER
))
6410 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
6417 /* This is used for the GNU intrinsics AND, OR and XOR. */
6419 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
6421 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
6423 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6424 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
6425 gfc_current_intrinsic
, &i
->where
);
6429 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
6431 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
6432 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
6433 gfc_current_intrinsic
, &j
->where
);
6437 if (i
->ts
.type
!= j
->ts
.type
)
6439 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
6440 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
6441 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6446 if (!scalar_check (i
, 0))
6449 if (!scalar_check (j
, 1))
6457 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
6460 if (a
->expr_type
== EXPR_NULL
)
6462 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
6463 "argument to STORAGE_SIZE, because it returns a "
6464 "disassociated pointer", &a
->where
);
6468 if (a
->ts
.type
== BT_ASSUMED
)
6470 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
6471 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6476 if (a
->ts
.type
== BT_PROCEDURE
)
6478 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
6479 "procedure", gfc_current_intrinsic_arg
[0]->name
,
6480 gfc_current_intrinsic
, &a
->where
);
6487 if (!type_check (kind
, 1, BT_INTEGER
))
6490 if (!scalar_check (kind
, 1))
6493 if (kind
->expr_type
!= EXPR_CONSTANT
)
6495 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
6496 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,