2 Copyright (C) 2002-2024 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 /* Reset a BOZ to a zero value. This is used to prevent run-on errors
39 from resolve.cc(resolve_function). */
42 reset_boz (gfc_expr
*x
)
49 x
->ts
.type
= BT_INTEGER
;
50 x
->ts
.kind
= gfc_default_integer_kind
;
51 mpz_init (x
->value
.integer
);
52 mpz_set_ui (x
->value
.integer
, 0);
55 /* A BOZ literal constant can appear in a limited number of contexts.
56 gfc_invalid_boz() is a helper function to simplify error/warning
57 generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran
58 allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz
59 is used, then issue a warning; otherwise issue an error. */
62 gfc_invalid_boz (const char *msg
, locus
*loc
)
64 if (flag_allow_invalid_boz
)
66 gfc_warning (0, msg
, loc
);
70 const char *hint
= _(" [see %<-fno-allow-invalid-boz%>]");
71 size_t len
= strlen (msg
) + strlen (hint
) + 1;
72 char *msg2
= (char *) alloca (len
);
75 gfc_error (msg2
, loc
);
80 /* Issue an error for an illegal BOZ argument. */
83 illegal_boz_arg (gfc_expr
*x
)
85 if (x
->ts
.type
== BT_BOZ
)
87 gfc_error ("BOZ literal constant at %L cannot be an actual argument "
88 "to %qs", &x
->where
, gfc_current_intrinsic
);
96 /* Some procedures take two arguments such that both cannot be BOZ. */
99 boz_args_check(gfc_expr
*i
, gfc_expr
*j
)
101 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_BOZ
)
103 gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
104 "literal constants", gfc_current_intrinsic
, &i
->where
,
116 /* Check that a BOZ is a constant. */
119 is_boz_constant (gfc_expr
*a
)
121 if (a
->expr_type
!= EXPR_CONSTANT
)
123 gfc_error ("Invalid use of BOZ literal constant at %L", &a
->where
);
131 /* Convert a octal string into a binary string. This is used in the
132 fallback conversion of an octal string to a REAL. */
135 oct2bin(int nbits
, char *oct
)
137 const char bits
[8][5] = {
138 "000", "001", "010", "011", "100", "101", "110", "111"};
144 if (nbits
== 64) j
++;
146 bufp
= buf
= XCNEWVEC (char, j
+ 1);
147 memset (bufp
, 0, j
+ 1);
150 for (i
= 0; i
< n
; i
++, oct
++)
153 strcpy (bufp
, &bits
[j
][0]);
157 bufp
= XCNEWVEC (char, nbits
+ 1);
159 strcpy (bufp
, buf
+ 2);
161 strcpy (bufp
, buf
+ 1);
169 /* Convert a hexidecimal string into a binary string. This is used in the
170 fallback conversion of a hexidecimal string to a REAL. */
173 hex2bin(int nbits
, char *hex
)
175 const char bits
[16][5] = {
176 "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111",
177 "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"};
182 bufp
= buf
= XCNEWVEC (char, nbits
+ 1);
183 memset (bufp
, 0, nbits
+ 1);
186 for (i
= 0; i
< n
; i
++, hex
++)
189 if (j
> 47 && j
< 58)
191 else if (j
> 64 && j
< 71)
193 else if (j
> 96 && j
< 103)
198 strcpy (bufp
, &bits
[j
][0]);
206 /* Fallback conversion of a BOZ string to REAL. */
209 bin2real (gfc_expr
*x
, int kind
)
216 i
= gfc_validate_kind (BT_REAL
, kind
, false);
217 t
= gfc_real_kinds
[i
].digits
- 1;
219 /* Number of bits in the exponent. */
220 if (gfc_real_kinds
[i
].max_exponent
== 16384)
222 else if (gfc_real_kinds
[i
].max_exponent
== 1024)
227 if (x
->boz
.rdx
== 16)
228 sp
= hex2bin (gfc_real_kinds
[i
].mode_precision
, x
->boz
.str
);
229 else if (x
->boz
.rdx
== 8)
230 sp
= oct2bin (gfc_real_kinds
[i
].mode_precision
, x
->boz
.str
);
234 /* Extract sign bit. */
237 /* Extract biased exponent. */
238 memset (buf
, 0, 114);
239 strncpy (buf
, ++sp
, w
);
241 mpz_set_str (em
, buf
, 2);
242 ie
= mpz_get_si (em
);
244 mpfr_init2 (x
->value
.real
, t
+ 1);
245 x
->ts
.type
= BT_REAL
;
248 sp
+= w
; /* Set to first digit in significand. */
250 if ((i
== 0 && ie
== b
) || (i
== 1 && ie
== b
)
251 || ((i
== 2 || i
== 3) && ie
== b
))
265 mpfr_set_inf (x
->value
.real
, 1);
267 mpfr_set_nan (x
->value
.real
);
272 strncpy (buf
, sp
, t
+ 1);
275 /* Significand with hidden bit. */
277 strncpy (&buf
[1], sp
, t
);
280 /* Convert to significand to integer. */
281 mpz_set_str (em
, buf
, 2);
282 ie
-= ((1 << (w
- 1)) - 1); /* Unbiased exponent. */
283 mpfr_set_z_2exp (x
->value
.real
, em
, ie
- t
, GFC_RND_MODE
);
286 if (sgn
) mpfr_neg (x
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
292 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
293 converts the string into a REAL of the appropriate kind. The treatment
294 of the sign bit is processor dependent. */
297 gfc_boz2real (gfc_expr
*x
, int kind
)
299 extern int gfc_max_integer_kind
;
304 if (!is_boz_constant (x
))
307 /* Determine the length of the required string. */
309 if (x
->boz
.rdx
== 16) len
/= 4;
310 if (x
->boz
.rdx
== 8) len
= len
/ 3 + 1;
311 buf
= (char *) alloca (len
+ 1); /* +1 for NULL terminator. */
313 if (x
->boz
.len
>= len
) /* Truncate if necessary. */
315 str
= x
->boz
.str
+ (x
->boz
.len
- len
);
318 else /* Copy and pad. */
320 memset (buf
, 48, len
);
321 str
= buf
+ (len
- x
->boz
.len
);
322 strcpy (str
, x
->boz
.str
);
325 /* Need to adjust leading bits in an octal string. */
328 /* Clear first bit. */
329 if (kind
== 4 || kind
== 10 || kind
== 16)
333 else if (buf
[0] == '5')
335 else if (buf
[0] == '6')
337 else if (buf
[0] == '7')
340 /* Clear first two bits. */
343 if (buf
[0] == '2' || buf
[0] == '4' || buf
[0] == '6')
345 else if (buf
[0] == '3' || buf
[0] == '5' || buf
[0] == '7')
350 /* Reset BOZ string to the truncated or padded version. */
353 x
->boz
.str
= XCNEWVEC (char, len
+ 1);
354 strncpy (x
->boz
.str
, buf
, len
);
356 /* For some targets, the largest INTEGER in terms of bits is smaller than
357 the bits needed to hold the REAL. Fortunately, the kind type parameter
358 indicates the number of bytes required to an INTEGER and a REAL. */
359 if (gfc_max_integer_kind
< kind
)
365 /* Convert to widest possible integer. */
366 gfc_boz2int (x
, gfc_max_integer_kind
);
369 if (!gfc_convert_boz (x
, &ts
))
371 gfc_error ("Failure in conversion of BOZ to REAL at %L", &x
->where
);
380 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int ()
381 converts the string into an INTEGER of the appropriate kind. The
382 treatment of the sign bit is processor dependent. If the converted
383 value exceeds the range of the type, then wrap-around semantics are
387 gfc_boz2int (gfc_expr
*x
, int kind
)
393 if (!is_boz_constant (x
))
396 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
397 len
= gfc_integer_kinds
[i
].bit_size
;
398 if (x
->boz
.rdx
== 16) len
/= 4;
399 if (x
->boz
.rdx
== 8) len
= len
/ 3 + 1;
400 buf
= (char *) alloca (len
+ 1); /* +1 for NULL terminator. */
402 if (x
->boz
.len
>= len
) /* Truncate if necessary. */
404 str
= x
->boz
.str
+ (x
->boz
.len
- len
);
407 else /* Copy and pad. */
409 memset (buf
, 48, len
);
410 str
= buf
+ (len
- x
->boz
.len
);
411 strcpy (str
, x
->boz
.str
);
414 /* Need to adjust leading bits in an octal string. */
417 /* Clear first bit. */
418 if (kind
== 1 || kind
== 4 || kind
== 16)
422 else if (buf
[0] == '5')
424 else if (buf
[0] == '6')
426 else if (buf
[0] == '7')
429 /* Clear first two bits. */
432 if (buf
[0] == '2' || buf
[0] == '4' || buf
[0] == '6')
434 else if (buf
[0] == '3' || buf
[0] == '5' || buf
[0] == '7')
439 /* Convert as-if unsigned integer. */
441 mpz_set_str (tmp1
, buf
, x
->boz
.rdx
);
443 /* Check for wrap-around. */
444 if (mpz_cmp (tmp1
, gfc_integer_kinds
[i
].huge
) > 0)
448 mpz_add_ui (tmp2
, gfc_integer_kinds
[i
].huge
, 1);
449 mpz_mod (tmp1
, tmp1
, tmp2
);
450 mpz_sub (tmp1
, tmp1
, tmp2
);
454 /* Clear boz info. */
459 mpz_init (x
->value
.integer
);
460 mpz_set (x
->value
.integer
, tmp1
);
461 x
->ts
.type
= BT_INTEGER
;
469 /* Make sure an expression is a scalar. */
472 scalar_check (gfc_expr
*e
, int n
)
477 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
478 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
485 /* Check the type of an expression. */
488 type_check (gfc_expr
*e
, int n
, bt type
)
490 if (e
->ts
.type
== type
)
493 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
494 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
495 &e
->where
, gfc_basic_typename (type
));
501 /* Check that the expression is a numeric type. */
504 numeric_check (gfc_expr
*e
, int n
)
506 /* Users sometime use a subroutine designator as an actual argument to
507 an intrinsic subprogram that expects an argument with a numeric type. */
508 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
511 if (gfc_numeric_ts (&e
->ts
))
514 /* If the expression has not got a type, check if its namespace can
515 offer a default type. */
516 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
517 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
518 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
519 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
521 e
->ts
= e
->symtree
->n
.sym
->ts
;
527 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
528 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
535 /* Check that an expression is integer or real. */
538 int_or_real_check (gfc_expr
*e
, int n
)
540 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
542 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
543 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
544 gfc_current_intrinsic
, &e
->where
);
551 /* Check that an expression is integer or real; allow character for
555 int_or_real_or_char_check_f2003 (gfc_expr
*e
, int n
)
557 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
559 if (e
->ts
.type
== BT_CHARACTER
)
560 return gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Character for "
561 "%qs argument of %qs intrinsic at %L",
562 gfc_current_intrinsic_arg
[n
]->name
,
563 gfc_current_intrinsic
, &e
->where
);
566 if (gfc_option
.allow_std
& GFC_STD_F2003
)
567 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
568 "or REAL or CHARACTER",
569 gfc_current_intrinsic_arg
[n
]->name
,
570 gfc_current_intrinsic
, &e
->where
);
572 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
573 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
574 gfc_current_intrinsic
, &e
->where
);
582 /* Check that an expression is an intrinsic type. */
584 intrinsic_type_check (gfc_expr
*e
, int n
)
586 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
587 && e
->ts
.type
!= BT_COMPLEX
&& e
->ts
.type
!= BT_CHARACTER
588 && e
->ts
.type
!= BT_LOGICAL
)
590 gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
591 gfc_current_intrinsic_arg
[n
]->name
,
592 gfc_current_intrinsic
, &e
->where
);
598 /* Check that an expression is real or complex. */
601 real_or_complex_check (gfc_expr
*e
, int n
)
603 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
605 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
606 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
607 gfc_current_intrinsic
, &e
->where
);
615 /* Check that an expression is INTEGER or PROCEDURE. */
618 int_or_proc_check (gfc_expr
*e
, int n
)
620 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
622 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
623 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
624 gfc_current_intrinsic
, &e
->where
);
632 /* Check that the expression is an optional constant integer
633 and that it specifies a valid kind for that type. */
636 kind_check (gfc_expr
*k
, int n
, bt type
)
643 if (!type_check (k
, n
, BT_INTEGER
))
646 if (!scalar_check (k
, n
))
649 if (!gfc_check_init_expr (k
))
651 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
652 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
657 if (gfc_extract_int (k
, &kind
)
658 || gfc_validate_kind (type
, kind
, true) < 0)
660 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
669 /* Make sure the expression is a double precision real. */
672 double_check (gfc_expr
*d
, int n
)
674 if (!type_check (d
, n
, BT_REAL
))
677 if (d
->ts
.kind
!= gfc_default_double_kind
)
679 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
680 "precision", gfc_current_intrinsic_arg
[n
]->name
,
681 gfc_current_intrinsic
, &d
->where
);
690 coarray_check (gfc_expr
*e
, int n
)
692 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
693 && CLASS_DATA (e
)->attr
.codimension
694 && CLASS_DATA (e
)->as
->corank
)
696 gfc_add_class_array_ref (e
);
700 if (!gfc_is_coarray (e
))
702 gfc_error ("Expected coarray variable as %qs argument to the %s "
703 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
704 gfc_current_intrinsic
, &e
->where
);
712 /* Make sure the expression is a logical array. */
715 logical_array_check (gfc_expr
*array
, int n
)
717 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
719 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
720 "array", gfc_current_intrinsic_arg
[n
]->name
,
721 gfc_current_intrinsic
, &array
->where
);
729 /* Make sure an expression is an array. */
732 array_check (gfc_expr
*e
, int n
)
734 if (e
->rank
!= 0 && e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
735 && CLASS_DATA (e
)->attr
.dimension
736 && CLASS_DATA (e
)->as
->rank
)
738 gfc_add_class_array_ref (e
);
741 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
744 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
745 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
752 /* If expr is a constant, then check to ensure that it is greater than
756 nonnegative_check (const char *arg
, gfc_expr
*expr
)
760 if (expr
->expr_type
== EXPR_CONSTANT
)
762 gfc_extract_int (expr
, &i
);
765 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
774 /* If expr is a constant, then check to ensure that it is greater than zero. */
777 positive_check (int n
, gfc_expr
*expr
)
781 if (expr
->expr_type
== EXPR_CONSTANT
)
783 gfc_extract_int (expr
, &i
);
786 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
787 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
797 /* If expr2 is constant, then check that the value is less than
798 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
801 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
802 gfc_expr
*expr2
, bool or_equal
)
806 if (expr2
->expr_type
== EXPR_CONSTANT
)
808 gfc_extract_int (expr2
, &i2
);
809 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
811 /* For ISHFT[C], check that |shift| <= bit_size(i). */
817 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
819 gfc_error ("The absolute value of SHIFT at %L must be less "
820 "than or equal to BIT_SIZE(%qs)",
821 &expr2
->where
, arg1
);
828 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
830 gfc_error ("%qs at %L must be less than "
831 "or equal to BIT_SIZE(%qs)",
832 arg2
, &expr2
->where
, arg1
);
838 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
840 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
841 arg2
, &expr2
->where
, arg1
);
851 /* If expr is constant, then check that the value is less than or equal
852 to the bit_size of the kind k. */
855 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
859 if (expr
->expr_type
!= EXPR_CONSTANT
)
862 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
863 gfc_extract_int (expr
, &val
);
865 if (val
> gfc_integer_kinds
[i
].bit_size
)
867 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
868 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
876 /* If expr2 and expr3 are constants, then check that the value is less than
877 or equal to bit_size(expr1). */
880 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
881 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
885 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
887 gfc_extract_int (expr2
, &i2
);
888 gfc_extract_int (expr3
, &i3
);
890 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
891 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
893 gfc_error ("%<%s + %s%> at %L must be less than or equal "
895 arg2
, arg3
, &expr2
->where
, arg1
);
903 /* Make sure two expressions have the same type. */
906 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
, bool assoc
= false)
908 gfc_typespec
*ets
= &e
->ts
;
909 gfc_typespec
*fts
= &f
->ts
;
913 /* Procedure pointer component expressions have the type of the interface
914 procedure. If they are being tested for association with a procedure
915 pointer (ie. not a component), the type of the procedure must be
917 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
918 ets
= &e
->symtree
->n
.sym
->ts
;
919 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
920 fts
= &f
->symtree
->n
.sym
->ts
;
923 if (gfc_compare_types (ets
, fts
))
926 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
927 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
928 gfc_current_intrinsic
, &f
->where
,
929 gfc_current_intrinsic_arg
[n
]->name
);
935 /* Make sure that an expression has a certain (nonzero) rank. */
938 rank_check (gfc_expr
*e
, int n
, int rank
)
943 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
944 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
951 /* Make sure a variable expression is not an optional dummy argument. */
954 nonoptional_check (gfc_expr
*e
, int n
)
956 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
958 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
959 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
963 /* TODO: Recursive check on nonoptional variables? */
969 /* Check for ALLOCATABLE attribute. */
972 allocatable_check (gfc_expr
*e
, int n
)
974 symbol_attribute attr
;
976 attr
= gfc_variable_attr (e
, NULL
);
977 if (!attr
.allocatable
978 || (attr
.associate_var
&& !attr
.select_rank_temporary
))
980 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
981 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
990 /* Check that an expression has a particular kind. */
993 kind_value_check (gfc_expr
*e
, int n
, int k
)
998 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
999 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
1006 /* Make sure an expression is a variable. */
1009 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
1011 if (e
->expr_type
== EXPR_VARIABLE
1012 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
1013 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
1014 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
)
1015 && !gfc_check_vardef_context (e
, false, true, false, NULL
))
1017 gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
1018 gfc_current_intrinsic_arg
[n
]->name
,
1019 gfc_current_intrinsic
, &e
->where
);
1023 if (e
->expr_type
== EXPR_VARIABLE
1024 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
1025 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
1028 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
1029 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
1032 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1033 if (ns
->proc_name
== e
->symtree
->n
.sym
)
1037 /* F2018:R902: function reference having a data pointer result. */
1038 if (e
->expr_type
== EXPR_FUNCTION
1039 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1040 && e
->symtree
->n
.sym
->attr
.function
1041 && e
->symtree
->n
.sym
->attr
.pointer
)
1044 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
1045 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
1051 /* Check the common DIM parameter for correctness. */
1054 dim_check (gfc_expr
*dim
, int n
, bool optional
)
1059 if (!type_check (dim
, n
, BT_INTEGER
))
1062 if (!scalar_check (dim
, n
))
1065 if (!optional
&& !nonoptional_check (dim
, n
))
1072 /* If a coarray DIM parameter is a constant, make sure that it is greater than
1073 zero and less than or equal to the corank of the given array. */
1076 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
1080 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
1082 if (dim
->expr_type
!= EXPR_CONSTANT
)
1085 if (array
->ts
.type
== BT_CLASS
)
1088 corank
= gfc_get_corank (array
);
1090 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1091 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
1093 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1094 "codimension index", gfc_current_intrinsic
, &dim
->where
);
1103 /* If a DIM parameter is a constant, make sure that it is greater than
1104 zero and less than or equal to the rank of the given array. If
1105 allow_assumed is zero then dim must be less than the rank of the array
1106 for assumed size arrays. */
1109 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
1117 if (dim
->expr_type
!= EXPR_CONSTANT
)
1120 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
1121 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
1122 rank
= array
->rank
+ 1;
1126 /* Assumed-rank array. */
1128 rank
= GFC_MAX_DIMENSIONS
;
1130 if (array
->expr_type
== EXPR_VARIABLE
)
1132 ar
= gfc_find_array_ref (array
, true);
1135 if (ar
->as
->type
== AS_ASSUMED_SIZE
1137 && ar
->type
!= AR_ELEMENT
1138 && ar
->type
!= AR_SECTION
)
1142 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1143 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
1145 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1146 "dimension index", gfc_current_intrinsic
, &dim
->where
);
1155 /* Compare the size of a along dimension ai with the size of b along
1156 dimension bi, returning 0 if they are known not to be identical,
1157 and 1 if they are identical, or if this cannot be determined. */
1160 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
1162 mpz_t a_size
, b_size
;
1165 gcc_assert (a
->rank
> ai
);
1166 gcc_assert (b
->rank
> bi
);
1170 if (gfc_array_dimen_size (a
, ai
, &a_size
))
1172 if (gfc_array_dimen_size (b
, bi
, &b_size
))
1174 if (mpz_cmp (a_size
, b_size
) != 0)
1184 /* Calculate the length of a character variable, including substrings.
1185 Strip away parentheses if necessary. Return -1 if no length could
1189 gfc_var_strlen (const gfc_expr
*a
)
1193 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
1194 a
= a
->value
.op
.op1
;
1196 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
1201 long start_a
, end_a
;
1206 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1207 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1209 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
1211 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
1212 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
1214 else if (ra
->u
.ss
.start
1215 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
1221 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
1222 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1223 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
1224 else if (a
->expr_type
== EXPR_CONSTANT
1225 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
1226 return a
->value
.character
.length
;
1232 /* Check whether two character expressions have the same length;
1233 returns true if they have or if the length cannot be determined,
1234 otherwise return false and raise a gfc_error. */
1237 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
1241 len_a
= gfc_var_strlen(a
);
1242 len_b
= gfc_var_strlen(b
);
1244 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
1248 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
1249 len_a
, len_b
, name
, &a
->where
);
1254 /* Check size of an array argument against a required size.
1255 Returns true if the requirement is satisfied or if the size cannot be
1256 determined, otherwise return false and raise a gfc_error */
1259 array_size_check (gfc_expr
*a
, int n
, long size_min
)
1264 if (gfc_array_size (a
, &size
))
1266 HOST_WIDE_INT sz
= gfc_mpz_get_hwi (size
);
1267 if (size_min
>= 0 && sz
< size_min
)
1269 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
1270 "too small (%wd/%ld)",
1271 gfc_current_intrinsic_arg
[n
]->name
,
1272 gfc_current_intrinsic
, &a
->where
, sz
, size_min
);
1282 /***** Check functions *****/
1284 /* Check subroutine suitable for intrinsics taking a real argument and
1285 a kind argument for the result. */
1288 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
1290 if (!type_check (a
, 0, BT_REAL
))
1292 if (!kind_check (kind
, 1, type
))
1299 /* Check subroutine suitable for ceiling, floor and nint. */
1302 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
1304 return check_a_kind (a
, kind
, BT_INTEGER
);
1308 /* Check subroutine suitable for aint, anint. */
1311 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
1313 return check_a_kind (a
, kind
, BT_REAL
);
1318 gfc_check_abs (gfc_expr
*a
)
1320 if (!numeric_check (a
, 0))
1328 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
1330 if (a
->ts
.type
== BT_BOZ
)
1332 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1333 "ACHAR intrinsic subprogram"), &a
->where
))
1336 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
1340 if (!type_check (a
, 0, BT_INTEGER
))
1343 if (!kind_check (kind
, 1, BT_CHARACTER
))
1351 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
1353 if (!type_check (name
, 0, BT_CHARACTER
)
1354 || !scalar_check (name
, 0))
1356 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1359 if (!type_check (mode
, 1, BT_CHARACTER
)
1360 || !scalar_check (mode
, 1))
1362 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1370 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
1372 if (!logical_array_check (mask
, 0))
1375 if (!dim_check (dim
, 1, false))
1378 if (!dim_rank_check (dim
, mask
, 0))
1385 /* Limited checking for ALLOCATED intrinsic. Additional checking
1386 is performed in intrinsic.cc(sort_actual), because ALLOCATED
1387 has two mutually exclusive non-optional arguments. */
1390 gfc_check_allocated (gfc_expr
*array
)
1392 /* Tests on allocated components of coarrays need to detour the check to
1393 argument of the _caf_get. */
1394 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
1395 && array
->value
.function
.isym
1396 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1398 array
= array
->value
.function
.actual
->expr
;
1403 if (!variable_check (array
, 0, false))
1405 if (!allocatable_check (array
, 0))
1412 /* Common check function where the first argument must be real or
1413 integer and the second argument must be the same as the first. */
1416 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
1418 if (!int_or_real_check (a
, 0))
1421 if (a
->ts
.type
!= p
->ts
.type
)
1423 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
1424 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
1425 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1430 if (a
->ts
.kind
!= p
->ts
.kind
)
1432 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1442 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
1444 if (!double_check (x
, 0) || !double_check (y
, 1))
1451 gfc_invalid_null_arg (gfc_expr
*x
)
1453 if (x
->expr_type
== EXPR_NULL
)
1455 gfc_error ("NULL at %L is not permitted as actual argument "
1456 "to %qs intrinsic function", &x
->where
,
1457 gfc_current_intrinsic
);
1464 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
1466 symbol_attribute attr1
, attr2
;
1470 if (gfc_invalid_null_arg (pointer
))
1473 attr1
= gfc_expr_attr (pointer
);
1475 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
1477 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
1478 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1484 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
1486 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1487 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
1488 gfc_current_intrinsic
, &pointer
->where
);
1492 /* Target argument is optional. */
1496 if (gfc_invalid_null_arg (target
))
1499 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
1500 attr2
= gfc_expr_attr (target
);
1503 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1504 "or target VARIABLE or FUNCTION",
1505 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1510 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
1512 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1513 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
1514 gfc_current_intrinsic
, &target
->where
);
1519 if (attr1
.pointer
&& gfc_is_coindexed (target
))
1521 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1522 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1523 gfc_current_intrinsic
, &target
->where
);
1528 if (!same_type_check (pointer
, 0, target
, 1, true))
1530 /* F2018 C838 explicitly allows an assumed-rank variable as the first
1531 argument of intrinsic inquiry functions. */
1532 if (pointer
->rank
!= -1 && !rank_check (target
, 0, pointer
->rank
))
1534 if (target
->rank
> 0 && target
->ref
)
1536 for (i
= 0; i
< target
->rank
; i
++)
1537 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1539 gfc_error ("Array section with a vector subscript at %L shall not "
1540 "be the target of a pointer",
1551 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1553 /* gfc_notify_std would be a waste of time as the return value
1554 is seemingly used only for the generic resolution. The error
1555 will be: Too many arguments. */
1556 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1559 return gfc_check_atan2 (y
, x
);
1564 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1566 if (!type_check (y
, 0, BT_REAL
))
1568 if (!same_type_check (y
, 0, x
, 1))
1576 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1577 gfc_expr
*stat
, int stat_no
)
1579 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1582 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1583 && !(atom
->ts
.type
== BT_LOGICAL
1584 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1586 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1587 "integer of ATOMIC_INT_KIND or a logical of "
1588 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1592 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1594 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1595 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1599 if (atom
->ts
.type
!= value
->ts
.type
)
1601 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1602 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1603 gfc_current_intrinsic
, &value
->where
,
1604 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1610 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1612 if (!scalar_check (stat
, stat_no
))
1614 if (!variable_check (stat
, stat_no
, false))
1616 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1619 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1620 gfc_current_intrinsic
, &stat
->where
))
1629 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1631 if (atom
->expr_type
== EXPR_FUNCTION
1632 && atom
->value
.function
.isym
1633 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1634 atom
= atom
->value
.function
.actual
->expr
;
1636 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1638 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1639 "definable", gfc_current_intrinsic
, &atom
->where
);
1643 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1648 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1650 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1652 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1653 "integer of ATOMIC_INT_KIND", &atom
->where
,
1654 gfc_current_intrinsic
);
1658 return gfc_check_atomic_def (atom
, value
, stat
);
1663 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1665 if (atom
->expr_type
== EXPR_FUNCTION
1666 && atom
->value
.function
.isym
1667 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1668 atom
= atom
->value
.function
.actual
->expr
;
1670 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1672 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1673 "definable", gfc_current_intrinsic
, &value
->where
);
1677 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1682 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1684 /* IMAGE has to be a positive, scalar integer. */
1685 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1686 || !positive_check (0, image
))
1691 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1692 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1701 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1705 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1706 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1715 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1716 || !positive_check (1, kind
))
1719 /* Get the kind, reporting error on non-constant or overflow. */
1720 gfc_current_locus
= kind
->where
;
1721 if (gfc_extract_int (kind
, &k
, 1))
1723 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1725 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1726 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1727 gfc_current_intrinsic
, &kind
->where
);
1736 gfc_check_get_team (gfc_expr
*level
)
1740 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1741 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1750 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1751 gfc_expr
*new_val
, gfc_expr
*stat
)
1753 if (atom
->expr_type
== EXPR_FUNCTION
1754 && atom
->value
.function
.isym
1755 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1756 atom
= atom
->value
.function
.actual
->expr
;
1758 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1761 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1764 if (!same_type_check (atom
, 0, old
, 1))
1767 if (!same_type_check (atom
, 0, compare
, 2))
1770 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1772 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1773 "definable", gfc_current_intrinsic
, &atom
->where
);
1777 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1779 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1780 "definable", gfc_current_intrinsic
, &old
->where
);
1788 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1790 if (event
->ts
.type
!= BT_DERIVED
1791 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1792 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1794 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1795 "shall be of type EVENT_TYPE", &event
->where
);
1799 if (!scalar_check (event
, 0))
1802 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1804 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1805 "shall be definable", &count
->where
);
1809 if (!type_check (count
, 1, BT_INTEGER
))
1812 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1813 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1815 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1817 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1818 "shall have at least the range of the default integer",
1825 if (!type_check (stat
, 2, BT_INTEGER
))
1827 if (!scalar_check (stat
, 2))
1829 if (!variable_check (stat
, 2, false))
1832 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1833 gfc_current_intrinsic
, &stat
->where
))
1842 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1845 if (atom
->expr_type
== EXPR_FUNCTION
1846 && atom
->value
.function
.isym
1847 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1848 atom
= atom
->value
.function
.actual
->expr
;
1850 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1852 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1853 "integer of ATOMIC_INT_KIND", &atom
->where
,
1854 gfc_current_intrinsic
);
1858 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1861 if (!scalar_check (old
, 2))
1864 if (!same_type_check (atom
, 0, old
, 2))
1867 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1869 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1870 "definable", gfc_current_intrinsic
, &atom
->where
);
1874 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1876 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1877 "definable", gfc_current_intrinsic
, &old
->where
);
1885 /* BESJN and BESYN functions. */
1888 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1890 if (!type_check (n
, 0, BT_INTEGER
))
1892 if (n
->expr_type
== EXPR_CONSTANT
)
1895 gfc_extract_int (n
, &i
);
1896 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1897 "N at %L", &n
->where
))
1901 if (!type_check (x
, 1, BT_REAL
))
1908 /* Transformational version of the Bessel JN and YN functions. */
1911 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1913 if (!type_check (n1
, 0, BT_INTEGER
))
1915 if (!scalar_check (n1
, 0))
1917 if (!nonnegative_check ("N1", n1
))
1920 if (!type_check (n2
, 1, BT_INTEGER
))
1922 if (!scalar_check (n2
, 1))
1924 if (!nonnegative_check ("N2", n2
))
1927 if (!type_check (x
, 2, BT_REAL
))
1929 if (!scalar_check (x
, 2))
1937 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1939 extern int gfc_max_integer_kind
;
1941 /* If i and j are both BOZ, convert to widest INTEGER. */
1942 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_BOZ
)
1944 if (!gfc_boz2int (i
, gfc_max_integer_kind
))
1946 if (!gfc_boz2int (j
, gfc_max_integer_kind
))
1950 /* If i is BOZ and j is integer, convert i to type of j. */
1951 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
1952 && !gfc_boz2int (i
, j
->ts
.kind
))
1955 /* If j is BOZ and i is integer, convert j to type of i. */
1956 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
1957 && !gfc_boz2int (j
, i
->ts
.kind
))
1960 if (!type_check (i
, 0, BT_INTEGER
))
1963 if (!type_check (j
, 1, BT_INTEGER
))
1971 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1973 if (!type_check (i
, 0, BT_INTEGER
))
1976 if (!type_check (pos
, 1, BT_INTEGER
))
1979 if (!nonnegative_check ("pos", pos
))
1982 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1990 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1992 if (i
->ts
.type
== BT_BOZ
)
1994 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1995 "CHAR intrinsic subprogram"), &i
->where
))
1998 if (!gfc_boz2int (i
, gfc_default_integer_kind
))
2002 if (!type_check (i
, 0, BT_INTEGER
))
2005 if (!kind_check (kind
, 1, BT_CHARACTER
))
2013 gfc_check_chdir (gfc_expr
*dir
)
2015 if (!type_check (dir
, 0, BT_CHARACTER
))
2017 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
2025 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
2027 if (!type_check (dir
, 0, BT_CHARACTER
))
2029 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
2035 if (!type_check (status
, 1, BT_INTEGER
))
2037 if (!scalar_check (status
, 1))
2045 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
2047 if (!type_check (name
, 0, BT_CHARACTER
))
2049 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2052 if (!type_check (mode
, 1, BT_CHARACTER
))
2054 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2062 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
2064 if (!type_check (name
, 0, BT_CHARACTER
))
2066 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2069 if (!type_check (mode
, 1, BT_CHARACTER
))
2071 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2077 if (!type_check (status
, 2, BT_INTEGER
))
2080 if (!scalar_check (status
, 2))
2088 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
2092 /* Check kind first, because it may be needed in conversion of a BOZ. */
2095 if (!kind_check (kind
, 2, BT_COMPLEX
))
2097 gfc_extract_int (kind
, &k
);
2100 k
= gfc_default_complex_kind
;
2102 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, k
))
2105 if (!numeric_check (x
, 0))
2110 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, k
))
2113 if (!numeric_check (y
, 1))
2116 if (x
->ts
.type
== BT_COMPLEX
)
2118 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2119 "present if %<x%> is COMPLEX",
2120 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2125 if (y
->ts
.type
== BT_COMPLEX
)
2127 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2128 "of either REAL or INTEGER",
2129 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2135 if (!kind
&& warn_conversion
2136 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
2137 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2138 "COMPLEX(%d) at %L might lose precision, consider using "
2139 "the KIND argument", gfc_typename (&x
->ts
),
2140 gfc_default_real_kind
, &x
->where
);
2141 else if (y
&& !kind
&& warn_conversion
2142 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
2143 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2144 "COMPLEX(%d) at %L might lose precision, consider using "
2145 "the KIND argument", gfc_typename (&y
->ts
),
2146 gfc_default_real_kind
, &y
->where
);
2152 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
2153 gfc_expr
*errmsg
, bool co_reduce
)
2155 if (!variable_check (a
, 0, false))
2158 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
2162 /* Fortran 2008, 12.5.2.4, paragraph 18. */
2163 if (gfc_has_vector_subscript (a
))
2165 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
2166 "subroutine %s shall not have a vector subscript",
2167 &a
->where
, gfc_current_intrinsic
);
2171 if (gfc_is_coindexed (a
))
2173 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
2174 "coindexed", &a
->where
, gfc_current_intrinsic
);
2178 if (image_idx
!= NULL
)
2180 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
2182 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
2188 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
2190 if (!scalar_check (stat
, co_reduce
? 3 : 2))
2192 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
2194 if (stat
->ts
.kind
!= 4)
2196 gfc_error ("The stat= argument at %L must be a kind=4 integer "
2197 "variable", &stat
->where
);
2204 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
2206 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
2208 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
2210 if (errmsg
->ts
.kind
!= 1)
2212 gfc_error ("The errmsg= argument at %L must be a default-kind "
2213 "character variable", &errmsg
->where
);
2218 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2220 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
2230 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
2233 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
2235 gfc_error ("Support for the A argument at %L which is polymorphic A "
2236 "argument or has allocatable components is not yet "
2237 "implemented", &a
->where
);
2240 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
2245 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
2246 gfc_expr
*stat
, gfc_expr
*errmsg
)
2248 symbol_attribute attr
;
2249 gfc_formal_arglist
*formal
;
2252 if (a
->ts
.type
== BT_CLASS
)
2254 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
2259 if (gfc_expr_attr (a
).alloc_comp
)
2261 gfc_error ("Support for the A argument at %L with allocatable components"
2262 " is not yet implemented", &a
->where
);
2266 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
2269 if (!gfc_resolve_expr (op
))
2272 attr
= gfc_expr_attr (op
);
2273 if (!attr
.pure
|| !attr
.function
)
2275 gfc_error ("OPERATION argument at %L must be a PURE function",
2282 /* None of the intrinsics fulfills the criteria of taking two arguments,
2283 returning the same type and kind as the arguments and being permitted
2284 as actual argument. */
2285 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
2286 op
->symtree
->n
.sym
->name
, &op
->where
);
2290 if (gfc_is_proc_ptr_comp (op
))
2292 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
2293 sym
= comp
->ts
.interface
;
2296 sym
= op
->symtree
->n
.sym
;
2298 formal
= sym
->formal
;
2300 if (!formal
|| !formal
->next
|| formal
->next
->next
)
2302 gfc_error ("The function passed as OPERATION at %L shall have two "
2303 "arguments", &op
->where
);
2307 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
2308 gfc_set_default_type (sym
->result
, 0, NULL
);
2310 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
2312 gfc_error ("The A argument at %L has type %s but the function passed as "
2313 "OPERATION at %L returns %s",
2314 &a
->where
, gfc_typename (a
), &op
->where
,
2315 gfc_typename (&sym
->result
->ts
));
2318 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
2319 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
2321 gfc_error ("The function passed as OPERATION at %L has arguments of type "
2322 "%s and %s but shall have type %s", &op
->where
,
2323 gfc_typename (&formal
->sym
->ts
),
2324 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (a
));
2327 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
2328 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
2329 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
2330 || formal
->next
->sym
->attr
.pointer
)
2332 gfc_error ("The function passed as OPERATION at %L shall have scalar "
2333 "nonallocatable nonpointer arguments and return a "
2334 "nonallocatable nonpointer scalar", &op
->where
);
2338 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
2340 gfc_error ("The function passed as OPERATION at %L shall have the VALUE "
2341 "attribute either for none or both arguments", &op
->where
);
2345 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
2347 gfc_error ("The function passed as OPERATION at %L shall have the TARGET "
2348 "attribute either for none or both arguments", &op
->where
);
2352 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
2354 gfc_error ("The function passed as OPERATION at %L shall have the "
2355 "ASYNCHRONOUS attribute either for none or both arguments",
2360 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
2362 gfc_error ("The function passed as OPERATION at %L shall not have the "
2363 "OPTIONAL attribute for either of the arguments", &op
->where
);
2367 if (a
->ts
.type
== BT_CHARACTER
)
2370 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
2373 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2374 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2376 cl
= formal
->sym
->ts
.u
.cl
;
2377 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2378 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2380 cl
= formal
->next
->sym
->ts
.u
.cl
;
2381 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2382 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2385 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2386 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2389 && ((formal_size1
&& actual_size
!= formal_size1
)
2390 || (formal_size2
&& actual_size
!= formal_size2
)))
2392 gfc_error ("The character length of the A argument at %L and of the "
2393 "arguments of the OPERATION at %L shall be the same",
2394 &a
->where
, &op
->where
);
2397 if (actual_size
&& result_size
&& actual_size
!= result_size
)
2399 gfc_error ("The character length of the A argument at %L and of the "
2400 "function result of the OPERATION at %L shall be the same",
2401 &a
->where
, &op
->where
);
2411 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2414 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
2415 && a
->ts
.type
!= BT_CHARACTER
)
2417 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
2418 "integer, real or character",
2419 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2423 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2428 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2431 if (!numeric_check (a
, 0))
2433 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2438 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
2440 if (!boz_args_check (x
, y
))
2443 if (x
->ts
.type
== BT_BOZ
)
2445 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2446 " intrinsic subprogram"), &x
->where
))
2451 if (y
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (x
, y
->ts
.kind
))
2453 if (y
->ts
.type
== BT_REAL
&& !gfc_boz2real (x
, y
->ts
.kind
))
2457 if (y
->ts
.type
== BT_BOZ
)
2459 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2460 " intrinsic subprogram"), &y
->where
))
2465 if (x
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (y
, x
->ts
.kind
))
2467 if (x
->ts
.type
== BT_REAL
&& !gfc_boz2real (y
, x
->ts
.kind
))
2471 if (!int_or_real_check (x
, 0))
2473 if (!scalar_check (x
, 0))
2476 if (!int_or_real_check (y
, 1))
2478 if (!scalar_check (y
, 1))
2486 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
2488 if (!logical_array_check (mask
, 0))
2490 if (!dim_check (dim
, 1, false))
2492 if (!dim_rank_check (dim
, mask
, 0))
2494 if (!kind_check (kind
, 2, BT_INTEGER
))
2496 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2497 "with KIND argument at %L",
2498 gfc_current_intrinsic
, &kind
->where
))
2506 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2508 if (!array_check (array
, 0))
2511 if (!type_check (shift
, 1, BT_INTEGER
))
2514 if (!dim_check (dim
, 2, true))
2517 if (!dim_rank_check (dim
, array
, false))
2520 if (array
->rank
== 1 || shift
->rank
== 0)
2522 if (!scalar_check (shift
, 1))
2525 else if (shift
->rank
== array
->rank
- 1)
2530 else if (dim
->expr_type
== EXPR_CONSTANT
)
2531 gfc_extract_int (dim
, &d
);
2538 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2541 if (!identical_dimen_shape (array
, i
, shift
, j
))
2543 gfc_error ("%qs argument of %qs intrinsic at %L has "
2544 "invalid shape in dimension %d (%ld/%ld)",
2545 gfc_current_intrinsic_arg
[1]->name
,
2546 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2547 mpz_get_si (array
->shape
[i
]),
2548 mpz_get_si (shift
->shape
[j
]));
2558 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2559 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2560 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2569 gfc_check_ctime (gfc_expr
*time
)
2571 if (!scalar_check (time
, 0))
2574 if (!type_check (time
, 0, BT_INTEGER
))
2581 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2583 if (!double_check (y
, 0) || !double_check (x
, 1))
2590 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2592 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2595 if (!numeric_check (x
, 0))
2600 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, gfc_default_double_kind
))
2603 if (!numeric_check (y
, 1))
2606 if (x
->ts
.type
== BT_COMPLEX
)
2608 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2609 "present if %<x%> is COMPLEX",
2610 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2615 if (y
->ts
.type
== BT_COMPLEX
)
2617 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2618 "of either REAL or INTEGER",
2619 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2630 gfc_check_dble (gfc_expr
*x
)
2632 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2635 if (!numeric_check (x
, 0))
2643 gfc_check_digits (gfc_expr
*x
)
2645 if (!int_or_real_check (x
, 0))
2653 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2655 switch (vector_a
->ts
.type
)
2658 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2665 if (!numeric_check (vector_b
, 1))
2670 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2671 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2672 gfc_current_intrinsic
, &vector_a
->where
);
2676 if (!rank_check (vector_a
, 0, 1))
2679 if (!rank_check (vector_b
, 1, 1))
2682 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2684 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2685 "intrinsic %<dot_product%>",
2686 gfc_current_intrinsic_arg
[0]->name
,
2687 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2696 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2698 if (!type_check (x
, 0, BT_REAL
)
2699 || !type_check (y
, 1, BT_REAL
))
2702 if (x
->ts
.kind
!= gfc_default_real_kind
)
2704 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2705 "real", gfc_current_intrinsic_arg
[0]->name
,
2706 gfc_current_intrinsic
, &x
->where
);
2710 if (y
->ts
.kind
!= gfc_default_real_kind
)
2712 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2713 "real", gfc_current_intrinsic_arg
[1]->name
,
2714 gfc_current_intrinsic
, &y
->where
);
2722 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2724 /* i and j cannot both be BOZ literal constants. */
2725 if (!boz_args_check (i
, j
))
2728 /* If i is BOZ and j is integer, convert i to type of j. If j is not
2729 an integer, clear the BOZ; otherwise, check that i is an integer. */
2730 if (i
->ts
.type
== BT_BOZ
)
2732 if (j
->ts
.type
!= BT_INTEGER
)
2734 else if (!gfc_boz2int (i
, j
->ts
.kind
))
2737 else if (!type_check (i
, 0, BT_INTEGER
))
2739 if (j
->ts
.type
== BT_BOZ
)
2744 /* If j is BOZ and i is integer, convert j to type of i. If i is not
2745 an integer, clear the BOZ; otherwise, check that i is an integer. */
2746 if (j
->ts
.type
== BT_BOZ
)
2748 if (i
->ts
.type
!= BT_INTEGER
)
2750 else if (!gfc_boz2int (j
, i
->ts
.kind
))
2753 else if (!type_check (j
, 1, BT_INTEGER
))
2756 if (!same_type_check (i
, 0, j
, 1))
2759 if (!type_check (shift
, 2, BT_INTEGER
))
2762 if (!nonnegative_check ("SHIFT", shift
))
2765 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2773 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2778 if (!array_check (array
, 0))
2781 if (!type_check (shift
, 1, BT_INTEGER
))
2784 if (!dim_check (dim
, 3, true))
2787 if (!dim_rank_check (dim
, array
, false))
2792 else if (dim
->expr_type
== EXPR_CONSTANT
)
2793 gfc_extract_int (dim
, &d
);
2797 if (array
->rank
== 1 || shift
->rank
== 0)
2799 if (!scalar_check (shift
, 1))
2802 else if (shift
->rank
== array
->rank
- 1)
2807 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2810 if (!identical_dimen_shape (array
, i
, shift
, j
))
2812 gfc_error ("%qs argument of %qs intrinsic at %L has "
2813 "invalid shape in dimension %d (%ld/%ld)",
2814 gfc_current_intrinsic_arg
[1]->name
,
2815 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2816 mpz_get_si (array
->shape
[i
]),
2817 mpz_get_si (shift
->shape
[j
]));
2827 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2828 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2829 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2833 if (boundary
!= NULL
)
2835 if (!same_type_check (array
, 0, boundary
, 2))
2838 /* Reject unequal string lengths and emit a better error message than
2839 gfc_check_same_strlen would. */
2840 if (array
->ts
.type
== BT_CHARACTER
)
2842 ssize_t len_a
, len_b
;
2844 len_a
= gfc_var_strlen (array
);
2845 len_b
= gfc_var_strlen (boundary
);
2846 if (len_a
!= -1 && len_b
!= -1 && len_a
!= len_b
)
2848 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2849 gfc_current_intrinsic_arg
[2]->name
,
2850 gfc_current_intrinsic_arg
[0]->name
,
2851 &boundary
->where
, gfc_current_intrinsic
);
2856 if (array
->rank
== 1 || boundary
->rank
== 0)
2858 if (!scalar_check (boundary
, 2))
2861 else if (boundary
->rank
== array
->rank
- 1)
2866 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2870 if (!identical_dimen_shape (array
, i
, boundary
, j
))
2872 gfc_error ("%qs argument of %qs intrinsic at %L has "
2873 "invalid shape in dimension %d (%ld/%ld)",
2874 gfc_current_intrinsic_arg
[2]->name
,
2875 gfc_current_intrinsic
, &shift
->where
, i
+1,
2876 mpz_get_si (array
->shape
[i
]),
2877 mpz_get_si (boundary
->shape
[j
]));
2887 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2888 "rank %d or be a scalar",
2889 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2890 &shift
->where
, array
->rank
- 1);
2896 switch (array
->ts
.type
)
2906 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2907 "of type %qs", gfc_current_intrinsic_arg
[2]->name
,
2908 gfc_current_intrinsic
, &array
->where
,
2909 gfc_current_intrinsic_arg
[0]->name
,
2910 gfc_typename (array
));
2920 gfc_check_float (gfc_expr
*a
)
2922 if (a
->ts
.type
== BT_BOZ
)
2924 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the"
2925 " FLOAT intrinsic subprogram"), &a
->where
))
2930 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
2934 if (!type_check (a
, 0, BT_INTEGER
))
2937 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2938 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2939 "kind argument to %s intrinsic at %L",
2940 gfc_current_intrinsic
, &a
->where
))
2946 /* A single complex argument. */
2949 gfc_check_fn_c (gfc_expr
*a
)
2951 if (!type_check (a
, 0, BT_COMPLEX
))
2958 /* A single real argument. */
2961 gfc_check_fn_r (gfc_expr
*a
)
2963 if (!type_check (a
, 0, BT_REAL
))
2969 /* A single double argument. */
2972 gfc_check_fn_d (gfc_expr
*a
)
2974 if (!double_check (a
, 0))
2980 /* A single real or complex argument. */
2983 gfc_check_fn_rc (gfc_expr
*a
)
2985 if (!real_or_complex_check (a
, 0))
2993 gfc_check_fn_rc2008 (gfc_expr
*a
)
2995 if (!real_or_complex_check (a
, 0))
2998 if (a
->ts
.type
== BT_COMPLEX
2999 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
3000 "of %qs intrinsic at %L",
3001 gfc_current_intrinsic_arg
[0]->name
,
3002 gfc_current_intrinsic
, &a
->where
))
3010 gfc_check_fnum (gfc_expr
*unit
)
3012 if (!type_check (unit
, 0, BT_INTEGER
))
3015 if (!scalar_check (unit
, 0))
3023 gfc_check_huge (gfc_expr
*x
)
3025 if (!int_or_real_check (x
, 0))
3033 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
3035 if (!type_check (x
, 0, BT_REAL
))
3037 if (!same_type_check (x
, 0, y
, 1))
3044 /* Check that the single argument is an integer. */
3047 gfc_check_i (gfc_expr
*i
)
3049 if (!type_check (i
, 0, BT_INTEGER
))
3057 gfc_check_iand_ieor_ior (gfc_expr
*i
, gfc_expr
*j
)
3059 /* i and j cannot both be BOZ literal constants. */
3060 if (!boz_args_check (i
, j
))
3063 /* If i is BOZ and j is integer, convert i to type of j. */
3064 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
3065 && !gfc_boz2int (i
, j
->ts
.kind
))
3068 /* If j is BOZ and i is integer, convert j to type of i. */
3069 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
3070 && !gfc_boz2int (j
, i
->ts
.kind
))
3073 if (!type_check (i
, 0, BT_INTEGER
))
3076 if (!type_check (j
, 1, BT_INTEGER
))
3079 if (i
->ts
.kind
!= j
->ts
.kind
)
3081 gfc_error ("Arguments of %qs have different kind type parameters "
3082 "at %L", gfc_current_intrinsic
, &i
->where
);
3091 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
3093 if (!type_check (i
, 0, BT_INTEGER
))
3096 if (!type_check (pos
, 1, BT_INTEGER
))
3099 if (!type_check (len
, 2, BT_INTEGER
))
3102 if (!nonnegative_check ("pos", pos
))
3105 if (!nonnegative_check ("len", len
))
3108 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
3116 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
3120 if (!type_check (c
, 0, BT_CHARACTER
))
3123 if (!kind_check (kind
, 1, BT_INTEGER
))
3126 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3127 "with KIND argument at %L",
3128 gfc_current_intrinsic
, &kind
->where
))
3131 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
3137 /* Substring references don't have the charlength set. */
3139 while (ref
&& ref
->type
!= REF_SUBSTRING
)
3142 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3146 /* Check that the argument is length one. Non-constant lengths
3147 can't be checked here, so assume they are ok. */
3148 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
3150 /* If we already have a length for this expression then use it. */
3151 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3153 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
3160 start
= ref
->u
.ss
.start
;
3161 end
= ref
->u
.ss
.end
;
3164 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3165 || start
->expr_type
!= EXPR_CONSTANT
)
3168 i
= mpz_get_si (end
->value
.integer
) + 1
3169 - mpz_get_si (start
->value
.integer
);
3177 gfc_error ("Argument of %s at %L must be of length one",
3178 gfc_current_intrinsic
, &c
->where
);
3187 gfc_check_idnint (gfc_expr
*a
)
3189 if (!double_check (a
, 0))
3197 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
3200 if (!type_check (string
, 0, BT_CHARACTER
)
3201 || !type_check (substring
, 1, BT_CHARACTER
))
3204 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
3207 if (!kind_check (kind
, 3, BT_INTEGER
))
3209 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3210 "with KIND argument at %L",
3211 gfc_current_intrinsic
, &kind
->where
))
3214 if (string
->ts
.kind
!= substring
->ts
.kind
)
3216 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
3217 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
3218 gfc_current_intrinsic
, &substring
->where
,
3219 gfc_current_intrinsic_arg
[0]->name
);
3228 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
3230 /* BOZ is dealt within simplify_int*. */
3231 if (x
->ts
.type
== BT_BOZ
)
3234 if (!numeric_check (x
, 0))
3237 if (!kind_check (kind
, 1, BT_INTEGER
))
3245 gfc_check_intconv (gfc_expr
*x
)
3247 if (strcmp (gfc_current_intrinsic
, "short") == 0
3248 || strcmp (gfc_current_intrinsic
, "long") == 0)
3250 gfc_error ("%qs intrinsic subprogram at %L has been removed. "
3251 "Use INT intrinsic subprogram.", gfc_current_intrinsic
,
3256 /* BOZ is dealt within simplify_int*. */
3257 if (x
->ts
.type
== BT_BOZ
)
3260 if (!numeric_check (x
, 0))
3267 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
3269 if (!type_check (i
, 0, BT_INTEGER
)
3270 || !type_check (shift
, 1, BT_INTEGER
))
3273 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3281 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
3283 if (!type_check (i
, 0, BT_INTEGER
)
3284 || !type_check (shift
, 1, BT_INTEGER
))
3291 if (!type_check (size
, 2, BT_INTEGER
))
3294 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
3297 if (size
->expr_type
== EXPR_CONSTANT
)
3299 gfc_extract_int (size
, &i3
);
3302 gfc_error ("SIZE at %L must be positive", &size
->where
);
3306 if (shift
->expr_type
== EXPR_CONSTANT
)
3308 gfc_extract_int (shift
, &i2
);
3314 gfc_error ("The absolute value of SHIFT at %L must be less "
3315 "than or equal to SIZE at %L", &shift
->where
,
3322 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3330 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
3332 if (!type_check (pid
, 0, BT_INTEGER
))
3335 if (!scalar_check (pid
, 0))
3338 if (!type_check (sig
, 1, BT_INTEGER
))
3341 if (!scalar_check (sig
, 1))
3349 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
3351 if (!type_check (pid
, 0, BT_INTEGER
))
3354 if (!scalar_check (pid
, 0))
3357 if (!type_check (sig
, 1, BT_INTEGER
))
3360 if (!scalar_check (sig
, 1))
3365 if (!type_check (status
, 2, BT_INTEGER
))
3368 if (!scalar_check (status
, 2))
3371 if (status
->expr_type
!= EXPR_VARIABLE
)
3373 gfc_error ("STATUS at %L shall be an INTENT(OUT) variable",
3378 if (status
->expr_type
== EXPR_VARIABLE
3379 && status
->symtree
&& status
->symtree
->n
.sym
3380 && status
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3382 gfc_error ("%qs at %L shall be an INTENT(OUT) variable",
3383 status
->symtree
->name
, &status
->where
);
3393 gfc_check_kind (gfc_expr
*x
)
3395 if (gfc_invalid_null_arg (x
))
3398 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
3400 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3401 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
3402 gfc_current_intrinsic
, &x
->where
);
3405 if (x
->ts
.type
== BT_PROCEDURE
)
3407 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
3408 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3418 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3420 if (!array_check (array
, 0))
3423 if (!dim_check (dim
, 1, false))
3426 if (!dim_rank_check (dim
, array
, 1))
3429 if (!kind_check (kind
, 2, BT_INTEGER
))
3431 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3432 "with KIND argument at %L",
3433 gfc_current_intrinsic
, &kind
->where
))
3441 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
3443 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3445 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3449 if (!coarray_check (coarray
, 0))
3454 if (!dim_check (dim
, 1, false))
3457 if (!dim_corank_check (dim
, coarray
))
3461 if (!kind_check (kind
, 2, BT_INTEGER
))
3469 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
3471 if (!type_check (s
, 0, BT_CHARACTER
))
3474 if (gfc_invalid_null_arg (s
))
3477 if (!kind_check (kind
, 1, BT_INTEGER
))
3479 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3480 "with KIND argument at %L",
3481 gfc_current_intrinsic
, &kind
->where
))
3489 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
3491 if (!type_check (a
, 0, BT_CHARACTER
))
3493 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
3496 if (!type_check (b
, 1, BT_CHARACTER
))
3498 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
3506 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
3508 if (!type_check (path1
, 0, BT_CHARACTER
))
3510 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3513 if (!type_check (path2
, 1, BT_CHARACTER
))
3515 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3523 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3525 if (!type_check (path1
, 0, BT_CHARACTER
))
3527 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3530 if (!type_check (path2
, 1, BT_CHARACTER
))
3532 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
3538 if (!type_check (status
, 2, BT_INTEGER
))
3541 if (!scalar_check (status
, 2))
3549 gfc_check_loc (gfc_expr
*expr
)
3551 return variable_check (expr
, 0, true);
3556 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
3558 if (!type_check (path1
, 0, BT_CHARACTER
))
3560 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3563 if (!type_check (path2
, 1, BT_CHARACTER
))
3565 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3573 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3575 if (!type_check (path1
, 0, BT_CHARACTER
))
3577 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3580 if (!type_check (path2
, 1, BT_CHARACTER
))
3582 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3588 if (!type_check (status
, 2, BT_INTEGER
))
3591 if (!scalar_check (status
, 2))
3599 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
3601 if (!type_check (a
, 0, BT_LOGICAL
))
3603 if (!kind_check (kind
, 1, BT_LOGICAL
))
3610 /* Min/max family. */
3613 min_max_args (gfc_actual_arglist
*args
)
3615 gfc_actual_arglist
*arg
;
3616 int i
, j
, nargs
, *nlabels
, nlabelless
;
3617 bool a1
= false, a2
= false;
3619 if (args
== NULL
|| args
->next
== NULL
)
3621 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3622 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
3629 if (!args
->next
->name
)
3633 for (arg
= args
; arg
; arg
= arg
->next
)
3640 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3642 nlabels
= XALLOCAVEC (int, nargs
);
3643 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
3649 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
3651 n
= strtol (&arg
->name
[1], &endp
, 10);
3652 if (endp
[0] != '\0')
3656 if (n
<= nlabelless
)
3669 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3670 !a1
? "a1" : "a2", gfc_current_intrinsic
,
3671 gfc_current_intrinsic_where
);
3675 /* Check for duplicates. */
3676 for (i
= 0; i
< nargs
; i
++)
3677 for (j
= i
+ 1; j
< nargs
; j
++)
3678 if (nlabels
[i
] == nlabels
[j
])
3684 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3685 &arg
->expr
->where
, gfc_current_intrinsic
);
3689 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3690 &arg
->expr
->where
, gfc_current_intrinsic
);
3696 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3698 gfc_actual_arglist
*arg
, *tmp
;
3702 if (!min_max_args (arglist
))
3705 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3708 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3710 if (x
->ts
.type
== type
)
3712 if (x
->ts
.type
== BT_CHARACTER
)
3714 gfc_error ("Different character kinds at %L", &x
->where
);
3717 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3718 "kinds at %L", &x
->where
))
3723 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3724 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3725 gfc_basic_typename (type
), kind
);
3730 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3731 if (!gfc_check_conformance (tmp
->expr
, x
,
3732 _("arguments 'a%d' and 'a%d' for "
3733 "intrinsic '%s'"), m
, n
,
3734 gfc_current_intrinsic
))
3743 gfc_check_min_max (gfc_actual_arglist
*arg
)
3747 if (!min_max_args (arg
))
3752 if (x
->ts
.type
== BT_CHARACTER
)
3754 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3755 "with CHARACTER argument at %L",
3756 gfc_current_intrinsic
, &x
->where
))
3759 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3761 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3762 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3766 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3771 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3773 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3778 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3780 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3785 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3787 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3791 /* End of min/max family. */
3794 gfc_check_malloc (gfc_expr
*size
)
3796 if (!type_check (size
, 0, BT_INTEGER
))
3799 if (!scalar_check (size
, 0))
3807 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3809 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3811 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3812 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3813 gfc_current_intrinsic
, &matrix_a
->where
);
3817 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3819 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3820 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3821 gfc_current_intrinsic
, &matrix_b
->where
);
3825 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3826 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3828 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3829 gfc_current_intrinsic
, &matrix_a
->where
,
3830 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3834 switch (matrix_a
->rank
)
3837 if (!rank_check (matrix_b
, 1, 2))
3839 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3840 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3842 gfc_error ("Different shape on dimension 1 for arguments %qs "
3843 "and %qs at %L for intrinsic matmul",
3844 gfc_current_intrinsic_arg
[0]->name
,
3845 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3851 if (matrix_b
->rank
!= 2)
3853 if (!rank_check (matrix_b
, 1, 1))
3856 /* matrix_b has rank 1 or 2 here. Common check for the cases
3857 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3858 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3859 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3861 gfc_error ("Different shape on dimension 2 for argument %qs and "
3862 "dimension 1 for argument %qs at %L for intrinsic "
3863 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3864 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3870 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3871 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3872 gfc_current_intrinsic
, &matrix_a
->where
);
3880 /* Whoever came up with this interface was probably on something.
3881 The possibilities for the occupation of the second and third
3888 NULL MASK minloc(array, mask=m)
3891 I.e. in the case of minloc(array,mask), mask will be in the second
3892 position of the argument list and we'll have to fix that up. Also,
3893 add the BACK argument if that isn't present. */
3896 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3898 gfc_expr
*a
, *m
, *d
, *k
, *b
;
3901 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3905 m
= ap
->next
->next
->expr
;
3906 k
= ap
->next
->next
->next
->expr
;
3907 b
= ap
->next
->next
->next
->next
->expr
;
3911 if (!type_check (b
, 4, BT_LOGICAL
) || !scalar_check (b
,4))
3916 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3917 ap
->next
->next
->next
->next
->expr
= b
;
3918 ap
->next
->next
->next
->next
->name
= gfc_get_string ("back");
3921 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3922 && ap
->next
->name
== NULL
)
3926 ap
->next
->expr
= NULL
;
3927 ap
->next
->next
->expr
= m
;
3930 if (!dim_check (d
, 1, false))
3933 if (!dim_rank_check (d
, a
, 0))
3936 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3940 && !gfc_check_conformance (a
, m
,
3941 _("arguments '%s' and '%s' for intrinsic %s"),
3942 gfc_current_intrinsic_arg
[0]->name
,
3943 gfc_current_intrinsic_arg
[2]->name
,
3944 gfc_current_intrinsic
))
3947 if (!kind_check (k
, 1, BT_INTEGER
))
3953 /* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3954 above, with the additional "value" argument. */
3957 gfc_check_findloc (gfc_actual_arglist
*ap
)
3959 gfc_expr
*a
, *v
, *m
, *d
, *k
, *b
;
3963 if (!intrinsic_type_check (a
, 0) || !array_check (a
, 0))
3967 if (!intrinsic_type_check (v
, 1) || !scalar_check (v
,1))
3970 /* Check if the type are both logical. */
3971 a1
= a
->ts
.type
== BT_LOGICAL
;
3972 v1
= v
->ts
.type
== BT_LOGICAL
;
3973 if ((a1
&& !v1
) || (!a1
&& v1
))
3976 /* Check if the type are both character. */
3977 a1
= a
->ts
.type
== BT_CHARACTER
;
3978 v1
= v
->ts
.type
== BT_CHARACTER
;
3979 if ((a1
&& !v1
) || (!a1
&& v1
))
3982 /* Check the kind of the characters argument match. */
3983 if (a1
&& v1
&& a
->ts
.kind
!= v
->ts
.kind
)
3986 d
= ap
->next
->next
->expr
;
3987 m
= ap
->next
->next
->next
->expr
;
3988 k
= ap
->next
->next
->next
->next
->expr
;
3989 b
= ap
->next
->next
->next
->next
->next
->expr
;
3993 if (!type_check (b
, 5, BT_LOGICAL
) || !scalar_check (b
,4))
3998 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3999 ap
->next
->next
->next
->next
->next
->expr
= b
;
4000 ap
->next
->next
->next
->next
->next
->name
= gfc_get_string ("back");
4003 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
4004 && ap
->next
->name
== NULL
)
4008 ap
->next
->next
->expr
= NULL
;
4009 ap
->next
->next
->next
->expr
= m
;
4012 if (!dim_check (d
, 2, false))
4015 if (!dim_rank_check (d
, a
, 0))
4018 if (m
!= NULL
&& !type_check (m
, 3, BT_LOGICAL
))
4022 && !gfc_check_conformance (a
, m
,
4023 _("arguments '%s' and '%s' for intrinsic %s"),
4024 gfc_current_intrinsic_arg
[0]->name
,
4025 gfc_current_intrinsic_arg
[3]->name
,
4026 gfc_current_intrinsic
))
4029 if (!kind_check (k
, 1, BT_INTEGER
))
4035 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4036 "conformance to argument %qs at %L",
4037 gfc_current_intrinsic_arg
[0]->name
,
4038 gfc_current_intrinsic
, &a
->where
,
4039 gfc_current_intrinsic_arg
[1]->name
, &v
->where
);
4044 /* Similar to minloc/maxloc, the argument list might need to be
4045 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4046 difference is that MINLOC/MAXLOC take an additional KIND argument.
4047 The possibilities are:
4053 NULL MASK minval(array, mask=m)
4056 I.e. in the case of minval(array,mask), mask will be in the second
4057 position of the argument list and we'll have to fix that up. */
4060 check_reduction (gfc_actual_arglist
*ap
)
4062 gfc_expr
*a
, *m
, *d
;
4066 m
= ap
->next
->next
->expr
;
4068 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
4069 && ap
->next
->name
== NULL
)
4073 ap
->next
->expr
= NULL
;
4074 ap
->next
->next
->expr
= m
;
4077 if (!dim_check (d
, 1, false))
4080 if (!dim_rank_check (d
, a
, 0))
4083 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
4087 && !gfc_check_conformance (a
, m
,
4088 _("arguments '%s' and '%s' for intrinsic %s"),
4089 gfc_current_intrinsic_arg
[0]->name
,
4090 gfc_current_intrinsic_arg
[2]->name
,
4091 gfc_current_intrinsic
))
4099 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
4101 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
4102 || !array_check (ap
->expr
, 0))
4105 return check_reduction (ap
);
4110 gfc_check_product_sum (gfc_actual_arglist
*ap
)
4112 if (!numeric_check (ap
->expr
, 0)
4113 || !array_check (ap
->expr
, 0))
4116 return check_reduction (ap
);
4120 /* For IANY, IALL and IPARITY. */
4123 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
4127 if (!type_check (i
, 0, BT_INTEGER
))
4130 if (!nonnegative_check ("I", i
))
4133 if (!kind_check (kind
, 1, BT_INTEGER
))
4137 gfc_extract_int (kind
, &k
);
4139 k
= gfc_default_integer_kind
;
4141 if (!less_than_bitsizekind ("I", i
, k
))
4149 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
4151 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
4153 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4154 gfc_current_intrinsic_arg
[0]->name
,
4155 gfc_current_intrinsic
, &ap
->expr
->where
);
4159 if (!array_check (ap
->expr
, 0))
4162 return check_reduction (ap
);
4167 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4169 if (gfc_invalid_null_arg (tsource
))
4172 if (gfc_invalid_null_arg (fsource
))
4175 if (!same_type_check (tsource
, 0, fsource
, 1))
4178 if (!type_check (mask
, 2, BT_LOGICAL
))
4181 if (tsource
->ts
.type
== BT_CHARACTER
)
4182 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
4189 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
4191 /* i and j cannot both be BOZ literal constants. */
4192 if (!boz_args_check (i
, j
))
4195 /* If i is BOZ and j is integer, convert i to type of j. */
4196 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
4197 && !gfc_boz2int (i
, j
->ts
.kind
))
4200 /* If j is BOZ and i is integer, convert j to type of i. */
4201 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
4202 && !gfc_boz2int (j
, i
->ts
.kind
))
4205 if (!type_check (i
, 0, BT_INTEGER
))
4208 if (!type_check (j
, 1, BT_INTEGER
))
4211 if (!same_type_check (i
, 0, j
, 1))
4214 if (mask
->ts
.type
== BT_BOZ
&& !gfc_boz2int(mask
, i
->ts
.kind
))
4217 if (!type_check (mask
, 2, BT_INTEGER
))
4220 if (!same_type_check (i
, 0, mask
, 2))
4228 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
4230 if (!variable_check (from
, 0, false))
4232 if (!allocatable_check (from
, 0))
4234 if (gfc_is_coindexed (from
))
4236 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4237 "coindexed", &from
->where
);
4241 if (!variable_check (to
, 1, false))
4243 if (!allocatable_check (to
, 1))
4245 if (gfc_is_coindexed (to
))
4247 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4248 "coindexed", &to
->where
);
4252 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
4254 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4255 "polymorphic if FROM is polymorphic",
4260 if (!same_type_check (to
, 1, from
, 0))
4263 if (to
->rank
!= from
->rank
)
4265 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4266 "must have the same rank %d/%d", &to
->where
, from
->rank
,
4271 /* IR F08/0040; cf. 12-006A. */
4272 if (gfc_get_corank (to
) != gfc_get_corank (from
))
4274 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4275 "must have the same corank %d/%d", &to
->where
,
4276 gfc_get_corank (from
), gfc_get_corank (to
));
4280 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
4281 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4282 and cmp2 are allocatable. After the allocation is transferred,
4283 the 'to' chain is broken by the nullification of the 'from'. A bit
4284 of reflection reveals that this can only occur for derived types
4285 with recursive allocatable components. */
4286 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
4287 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
4289 gfc_ref
*to_ref
, *from_ref
;
4291 from_ref
= from
->ref
;
4292 bool aliasing
= true;
4294 for (; from_ref
&& to_ref
;
4295 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
4297 if (to_ref
->type
!= from
->ref
->type
)
4299 else if (to_ref
->type
== REF_ARRAY
4300 && to_ref
->u
.ar
.type
!= AR_FULL
4301 && from_ref
->u
.ar
.type
!= AR_FULL
)
4302 /* Play safe; assume sections and elements are different. */
4304 else if (to_ref
->type
== REF_COMPONENT
4305 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
4314 gfc_error ("The FROM and TO arguments at %L violate aliasing "
4315 "restrictions (F2003 12.4.1.7)", &to
->where
);
4320 /* CLASS arguments: Make sure the vtab of from is present. */
4321 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
4322 gfc_find_vtab (&from
->ts
);
4329 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
4331 if (!type_check (x
, 0, BT_REAL
))
4334 if (!type_check (s
, 1, BT_REAL
))
4337 if (s
->expr_type
== EXPR_CONSTANT
)
4339 if (mpfr_sgn (s
->value
.real
) == 0)
4341 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4352 gfc_check_new_line (gfc_expr
*a
)
4354 if (!type_check (a
, 0, BT_CHARACTER
))
4362 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
4364 if (!type_check (array
, 0, BT_REAL
))
4367 if (!array_check (array
, 0))
4370 if (!dim_check (dim
, 1, false))
4373 if (!dim_rank_check (dim
, array
, false))
4380 gfc_check_null (gfc_expr
*mold
)
4382 symbol_attribute attr
;
4387 if (mold
->expr_type
== EXPR_NULL
)
4390 if (!variable_check (mold
, 0, true))
4393 attr
= gfc_variable_attr (mold
, NULL
);
4395 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
4397 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4398 "ALLOCATABLE or procedure pointer",
4399 gfc_current_intrinsic_arg
[0]->name
,
4400 gfc_current_intrinsic
, &mold
->where
);
4404 if (attr
.allocatable
4405 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
4406 "allocatable MOLD at %L", &mold
->where
))
4410 if (gfc_is_coindexed (mold
))
4412 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4413 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
4414 gfc_current_intrinsic
, &mold
->where
);
4423 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4425 if (!array_check (array
, 0))
4428 if (!type_check (mask
, 1, BT_LOGICAL
))
4431 if (!gfc_check_conformance (array
, mask
,
4432 _("arguments '%s' and '%s' for intrinsic '%s'"),
4433 gfc_current_intrinsic_arg
[0]->name
,
4434 gfc_current_intrinsic_arg
[1]->name
,
4435 gfc_current_intrinsic
))
4440 mpz_t array_size
, vector_size
;
4441 bool have_array_size
, have_vector_size
;
4443 if (!same_type_check (array
, 0, vector
, 2))
4446 if (!rank_check (vector
, 2, 1))
4449 /* VECTOR requires at least as many elements as MASK
4450 has .TRUE. values. */
4451 have_array_size
= gfc_array_size(array
, &array_size
);
4452 have_vector_size
= gfc_array_size(vector
, &vector_size
);
4454 if (have_vector_size
4455 && (mask
->expr_type
== EXPR_ARRAY
4456 || (mask
->expr_type
== EXPR_CONSTANT
4457 && have_array_size
)))
4459 int mask_true_values
= 0;
4461 if (mask
->expr_type
== EXPR_ARRAY
)
4463 gfc_constructor
*mask_ctor
;
4464 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4467 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4469 mask_true_values
= 0;
4473 if (mask_ctor
->expr
->value
.logical
)
4476 mask_ctor
= gfc_constructor_next (mask_ctor
);
4479 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
4480 mask_true_values
= mpz_get_si (array_size
);
4482 if (mpz_get_si (vector_size
) < mask_true_values
)
4484 gfc_error ("%qs argument of %qs intrinsic at %L must "
4485 "provide at least as many elements as there "
4486 "are .TRUE. values in %qs (%ld/%d)",
4487 gfc_current_intrinsic_arg
[2]->name
,
4488 gfc_current_intrinsic
, &vector
->where
,
4489 gfc_current_intrinsic_arg
[1]->name
,
4490 mpz_get_si (vector_size
), mask_true_values
);
4495 if (have_array_size
)
4496 mpz_clear (array_size
);
4497 if (have_vector_size
)
4498 mpz_clear (vector_size
);
4506 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
4508 if (!type_check (mask
, 0, BT_LOGICAL
))
4511 if (!array_check (mask
, 0))
4514 if (!dim_check (dim
, 1, false))
4517 if (!dim_rank_check (dim
, mask
, false))
4525 gfc_check_precision (gfc_expr
*x
)
4527 if (!real_or_complex_check (x
, 0))
4535 gfc_check_present (gfc_expr
*a
)
4539 if (!variable_check (a
, 0, true))
4542 sym
= a
->symtree
->n
.sym
;
4543 if (!sym
->attr
.dummy
)
4545 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4546 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
4547 gfc_current_intrinsic
, &a
->where
);
4551 /* For CLASS, the optional attribute might be set at either location. */
4552 if ((sym
->ts
.type
!= BT_CLASS
|| !CLASS_DATA (sym
)->attr
.optional
)
4553 && !sym
->attr
.optional
)
4555 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4556 "an OPTIONAL dummy variable",
4557 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4562 /* 13.14.82 PRESENT(A)
4564 Argument. A shall be the name of an optional dummy argument that is
4565 accessible in the subprogram in which the PRESENT function reference
4569 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
4570 && (a
->ref
->u
.ar
.type
== AR_FULL
4571 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
4572 && a
->ref
->u
.ar
.as
->rank
== 0))))
4574 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4575 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
4576 gfc_current_intrinsic
, &a
->where
, sym
->name
);
4585 gfc_check_radix (gfc_expr
*x
)
4587 if (!int_or_real_check (x
, 0))
4595 gfc_check_range (gfc_expr
*x
)
4597 if (!numeric_check (x
, 0))
4605 gfc_check_rank (gfc_expr
*a
)
4607 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4608 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4610 bool is_variable
= true;
4612 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4613 if (a
->expr_type
== EXPR_FUNCTION
)
4614 is_variable
= a
->value
.function
.esym
4615 ? a
->value
.function
.esym
->result
->attr
.pointer
4616 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
4618 if (a
->expr_type
== EXPR_OP
4619 || a
->expr_type
== EXPR_NULL
4620 || a
->expr_type
== EXPR_COMPCALL
4621 || a
->expr_type
== EXPR_PPC
4622 || a
->ts
.type
== BT_PROCEDURE
4625 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4626 "object", &a
->where
);
4635 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
4637 if (!kind_check (kind
, 1, BT_REAL
))
4640 /* BOZ is dealt with in gfc_simplify_real. */
4641 if (a
->ts
.type
== BT_BOZ
)
4644 if (!numeric_check (a
, 0))
4652 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
4654 if (!type_check (path1
, 0, BT_CHARACTER
))
4656 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4659 if (!type_check (path2
, 1, BT_CHARACTER
))
4661 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4669 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
4671 if (!type_check (path1
, 0, BT_CHARACTER
))
4673 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4676 if (!type_check (path2
, 1, BT_CHARACTER
))
4678 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4684 if (!type_check (status
, 2, BT_INTEGER
))
4687 if (!scalar_check (status
, 2))
4695 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
4697 if (!type_check (x
, 0, BT_CHARACTER
))
4700 if (!scalar_check (x
, 0))
4703 if (!type_check (y
, 0, BT_INTEGER
))
4706 if (!scalar_check (y
, 1))
4714 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
4715 gfc_expr
*pad
, gfc_expr
*order
)
4720 bool shape_is_const
;
4722 if (!array_check (source
, 0))
4725 if (!rank_check (shape
, 1, 1))
4728 if (!type_check (shape
, 1, BT_INTEGER
))
4731 if (!gfc_array_size (shape
, &size
))
4733 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4734 "array of constant size", &shape
->where
);
4738 shape_size
= mpz_get_ui (size
);
4741 if (shape_size
<= 0)
4743 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4744 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4748 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4750 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4751 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4755 gfc_simplify_expr (shape
, 0);
4756 shape_is_const
= gfc_is_constant_array_expr (shape
);
4758 if (shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
)
4762 for (i
= 0; i
< shape_size
; ++i
)
4764 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4767 if (e
->expr_type
!= EXPR_CONSTANT
)
4770 gfc_extract_int (e
, &extent
);
4773 gfc_error ("%qs argument of %qs intrinsic at %L has "
4774 "negative element (%d)",
4775 gfc_current_intrinsic_arg
[1]->name
,
4776 gfc_current_intrinsic
, &shape
->where
, extent
);
4784 if (!same_type_check (source
, 0, pad
, 2))
4787 if (!array_check (pad
, 2))
4793 if (!array_check (order
, 3))
4796 if (!type_check (order
, 3, BT_INTEGER
))
4799 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_array_expr (order
))
4801 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4804 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4807 gfc_array_size (order
, &size
);
4808 order_size
= mpz_get_ui (size
);
4811 if (order_size
!= shape_size
)
4813 gfc_error ("%qs argument of %qs intrinsic at %L "
4814 "has wrong number of elements (%d/%d)",
4815 gfc_current_intrinsic_arg
[3]->name
,
4816 gfc_current_intrinsic
, &order
->where
,
4817 order_size
, shape_size
);
4821 for (i
= 1; i
<= order_size
; ++i
)
4823 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4824 if (e
->expr_type
!= EXPR_CONSTANT
)
4827 gfc_extract_int (e
, &dim
);
4829 if (dim
< 1 || dim
> order_size
)
4831 gfc_error ("%qs argument of %qs intrinsic at %L "
4832 "has out-of-range dimension (%d)",
4833 gfc_current_intrinsic_arg
[3]->name
,
4834 gfc_current_intrinsic
, &e
->where
, dim
);
4838 if (perm
[dim
-1] != 0)
4840 gfc_error ("%qs argument of %qs intrinsic at %L has "
4841 "invalid permutation of dimensions (dimension "
4843 gfc_current_intrinsic_arg
[3]->name
,
4844 gfc_current_intrinsic
, &e
->where
, dim
);
4853 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
4854 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4855 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4857 /* Check the match in size between source and destination. */
4858 if (gfc_array_size (source
, &nelems
))
4864 mpz_init_set_ui (size
, 1);
4865 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4866 c
; c
= gfc_constructor_next (c
))
4867 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4869 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4875 gfc_error ("Without padding, there are not enough elements "
4876 "in the intrinsic RESHAPE source at %L to match "
4877 "the shape", &source
->where
);
4888 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4890 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4892 gfc_error ("%qs argument of %qs intrinsic at %L "
4893 "cannot be of type %s",
4894 gfc_current_intrinsic_arg
[0]->name
,
4895 gfc_current_intrinsic
,
4896 &a
->where
, gfc_typename (a
));
4900 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4902 gfc_error ("%qs argument of %qs intrinsic at %L "
4903 "must be of an extensible type",
4904 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4909 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4911 gfc_error ("%qs argument of %qs intrinsic at %L "
4912 "cannot be of type %s",
4913 gfc_current_intrinsic_arg
[0]->name
,
4914 gfc_current_intrinsic
,
4915 &b
->where
, gfc_typename (b
));
4919 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4921 gfc_error ("%qs argument of %qs intrinsic at %L "
4922 "must be of an extensible type",
4923 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4933 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4935 if (!type_check (x
, 0, BT_REAL
))
4938 if (!type_check (i
, 1, BT_INTEGER
))
4946 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4948 if (!type_check (x
, 0, BT_CHARACTER
))
4951 if (!type_check (y
, 1, BT_CHARACTER
))
4954 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4957 if (!kind_check (kind
, 3, BT_INTEGER
))
4959 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4960 "with KIND argument at %L",
4961 gfc_current_intrinsic
, &kind
->where
))
4964 if (!same_type_check (x
, 0, y
, 1))
4972 gfc_check_secnds (gfc_expr
*r
)
4974 if (!type_check (r
, 0, BT_REAL
))
4977 if (!kind_value_check (r
, 0, 4))
4980 if (!scalar_check (r
, 0))
4988 gfc_check_selected_char_kind (gfc_expr
*name
)
4990 if (!type_check (name
, 0, BT_CHARACTER
))
4993 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4996 if (!scalar_check (name
, 0))
5004 gfc_check_selected_int_kind (gfc_expr
*r
)
5006 if (!type_check (r
, 0, BT_INTEGER
))
5009 if (!scalar_check (r
, 0))
5017 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
5019 if (p
== NULL
&& r
== NULL
5020 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
5021 " neither %<P%> nor %<R%> argument at %L",
5022 gfc_current_intrinsic_where
))
5027 if (!type_check (p
, 0, BT_INTEGER
))
5030 if (!scalar_check (p
, 0))
5036 if (!type_check (r
, 1, BT_INTEGER
))
5039 if (!scalar_check (r
, 1))
5045 if (!type_check (radix
, 1, BT_INTEGER
))
5048 if (!scalar_check (radix
, 1))
5051 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
5052 "RADIX argument at %L", gfc_current_intrinsic
,
5062 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5064 if (!type_check (x
, 0, BT_REAL
))
5067 if (!type_check (i
, 1, BT_INTEGER
))
5075 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
5079 if (gfc_invalid_null_arg (source
))
5082 if (!kind_check (kind
, 1, BT_INTEGER
))
5084 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5085 "with KIND argument at %L",
5086 gfc_current_intrinsic
, &kind
->where
))
5089 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
5092 if (source
->ref
== NULL
)
5095 ar
= gfc_find_array_ref (source
);
5097 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
5099 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5100 "an assumed size array", &source
->where
);
5109 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
5111 if (!type_check (i
, 0, BT_INTEGER
))
5114 if (!type_check (shift
, 0, BT_INTEGER
))
5117 if (!nonnegative_check ("SHIFT", shift
))
5120 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
5128 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
5130 if (!int_or_real_check (a
, 0))
5133 if (!same_type_check (a
, 0, b
, 1))
5141 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5143 if (!array_check (array
, 0))
5146 if (!dim_check (dim
, 1, true))
5149 if (!dim_rank_check (dim
, array
, 0))
5152 if (!kind_check (kind
, 2, BT_INTEGER
))
5154 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5155 "with KIND argument at %L",
5156 gfc_current_intrinsic
, &kind
->where
))
5165 gfc_check_sizeof (gfc_expr
*arg
)
5167 if (gfc_invalid_null_arg (arg
))
5170 if (arg
->ts
.type
== BT_PROCEDURE
)
5172 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5173 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5178 if (illegal_boz_arg (arg
))
5181 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5182 if (arg
->ts
.type
== BT_ASSUMED
5183 && (arg
->symtree
->n
.sym
->as
== NULL
5184 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
5185 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
5186 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
5188 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5189 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5194 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5195 && arg
->symtree
->n
.sym
->as
!= NULL
5196 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5197 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5199 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5200 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5201 gfc_current_intrinsic
, &arg
->where
);
5209 /* Check whether an expression is interoperable. When returning false,
5210 msg is set to a string telling why the expression is not interoperable,
5211 otherwise, it is set to NULL. The msg string can be used in diagnostics.
5212 If c_loc is true, character with len > 1 are allowed (cf. Fortran
5213 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5214 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5218 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
5222 if (expr
->expr_type
== EXPR_NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
5224 *msg
= "NULL() is not interoperable";
5228 if (expr
->ts
.type
== BT_BOZ
)
5230 *msg
= "BOZ literal constant";
5234 if (expr
->ts
.type
== BT_CLASS
)
5236 *msg
= "Expression is polymorphic";
5240 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
5241 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
5243 *msg
= "Expression is a noninteroperable derived type";
5247 if (expr
->ts
.type
== BT_PROCEDURE
)
5249 *msg
= "Procedure unexpected as argument";
5253 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
5256 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
5257 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
5259 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
5263 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
5264 && expr
->ts
.kind
!= 1)
5266 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
5270 if (expr
->ts
.type
== BT_CHARACTER
) {
5271 if (expr
->ts
.deferred
)
5273 /* TS 29113 allows deferred-length strings as dummy arguments,
5274 but it is not an interoperable type. */
5275 *msg
= "Expression shall not be a deferred-length string";
5279 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
5280 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
5281 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5285 && !gfc_length_one_character_type_p (&expr
->ts
))
5287 *msg
= "Type shall have a character length of 1";
5292 /* Note: The following checks are about interoperatable variables, Fortran
5293 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5294 is allowed, e.g. assumed-shape arrays with TS 29113. */
5296 if (gfc_is_coarray (expr
))
5298 *msg
= "Coarrays are not interoperable";
5302 /* Checks for C_SIZEOF need to take into account edits to 18-007r1, see
5303 https://j3-fortran.org/doc/year/22/22-101r1.txt . */
5304 if (!c_loc
&& !c_f_ptr
&& expr
->rank
> 0 && expr
->expr_type
== EXPR_VARIABLE
)
5306 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
5307 if (ar
->type
== AR_FULL
&& ar
->as
->type
== AS_ASSUMED_SIZE
)
5309 *msg
= "Assumed-size arrays are not interoperable";
5319 gfc_check_c_sizeof (gfc_expr
*arg
)
5323 if (!is_c_interoperable (arg
, &msg
, false, false))
5325 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5326 "interoperable data entity: %s",
5327 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5332 if (arg
->ts
.type
== BT_ASSUMED
)
5334 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5336 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5341 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5342 && arg
->symtree
->n
.sym
->as
!= NULL
5343 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5344 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5346 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5347 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5348 gfc_current_intrinsic
, &arg
->where
);
5357 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
5359 if (c_ptr_1
->ts
.type
!= BT_DERIVED
5360 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5361 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
5362 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
5364 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5365 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
5369 if (!scalar_check (c_ptr_1
, 0))
5373 && (c_ptr_2
->ts
.type
!= BT_DERIVED
5374 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5375 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
5376 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
5378 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5379 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
5380 gfc_typename (&c_ptr_1
->ts
),
5381 gfc_typename (&c_ptr_2
->ts
));
5385 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
5393 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
5395 symbol_attribute attr
;
5398 if (cptr
->ts
.type
!= BT_DERIVED
5399 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5400 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
5402 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5403 "type TYPE(C_PTR)", &cptr
->where
);
5407 if (!scalar_check (cptr
, 0))
5410 attr
= gfc_expr_attr (fptr
);
5414 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5419 if (fptr
->ts
.type
== BT_CLASS
)
5421 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5426 if (gfc_is_coindexed (fptr
))
5428 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5429 "coindexed", &fptr
->where
);
5433 if (fptr
->rank
== 0 && shape
)
5435 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5436 "FPTR", &fptr
->where
);
5439 else if (fptr
->rank
&& !shape
)
5441 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5442 "FPTR at %L", &fptr
->where
);
5446 if (shape
&& !rank_check (shape
, 2, 1))
5449 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
5455 if (gfc_array_size (shape
, &size
))
5457 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
5460 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5461 "size as the RANK of FPTR", &shape
->where
);
5468 if (fptr
->ts
.type
== BT_CLASS
)
5470 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
5474 if (fptr
->ts
.type
== BT_PROCEDURE
&& attr
.function
)
5476 gfc_error ("FPTR argument to C_F_POINTER at %L is a function "
5477 "returning a pointer", &fptr
->where
);
5481 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
5482 return gfc_notify_std (GFC_STD_F2018
,
5483 "Noninteroperable array FPTR argument to "
5484 "C_F_POINTER at %L: %s", &fptr
->where
, msg
);
5491 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
5493 symbol_attribute attr
;
5495 if (cptr
->ts
.type
!= BT_DERIVED
5496 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5497 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
5499 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5500 "type TYPE(C_FUNPTR)", &cptr
->where
);
5504 if (!scalar_check (cptr
, 0))
5507 attr
= gfc_expr_attr (fptr
);
5509 if (!attr
.proc_pointer
)
5511 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5512 "pointer", &fptr
->where
);
5516 if (gfc_is_coindexed (fptr
))
5518 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5519 "coindexed", &fptr
->where
);
5523 if (!attr
.is_bind_c
)
5524 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5525 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
5532 gfc_check_c_funloc (gfc_expr
*x
)
5534 symbol_attribute attr
;
5536 if (gfc_is_coindexed (x
))
5538 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5539 "coindexed", &x
->where
);
5543 attr
= gfc_expr_attr (x
);
5545 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
5546 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
5547 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5548 if (x
->symtree
->n
.sym
== ns
->proc_name
)
5550 gfc_error ("Function result %qs at %L is invalid as X argument "
5551 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
5555 if (attr
.flavor
!= FL_PROCEDURE
)
5557 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5558 "or a procedure pointer", &x
->where
);
5562 if (!attr
.is_bind_c
)
5563 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5564 "at %L to C_FUNLOC", &x
->where
);
5570 gfc_check_c_loc (gfc_expr
*x
)
5572 symbol_attribute attr
;
5575 if (gfc_is_coindexed (x
))
5577 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
5581 if (x
->ts
.type
== BT_CLASS
)
5583 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5588 attr
= gfc_expr_attr (x
);
5591 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
5592 || attr
.flavor
== FL_PARAMETER
))
5594 gfc_error ("Argument X at %L to C_LOC shall have either "
5595 "the POINTER or the TARGET attribute", &x
->where
);
5599 if (x
->ts
.type
== BT_CHARACTER
5600 && gfc_var_strlen (x
) == 0)
5602 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5603 "string", &x
->where
);
5607 if (!is_c_interoperable (x
, &msg
, true, false))
5609 if (x
->ts
.type
== BT_CLASS
)
5611 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5617 && !gfc_notify_std (GFC_STD_F2018
,
5618 "Noninteroperable array at %L as"
5619 " argument to C_LOC: %s", &x
->where
, msg
))
5622 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
5624 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
5626 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
5627 && !attr
.allocatable
5628 && !gfc_notify_std (GFC_STD_F2008
,
5629 "Array of interoperable type at %L "
5630 "to C_LOC which is nonallocatable and neither "
5631 "assumed size nor explicit size", &x
->where
))
5633 else if (ar
->type
!= AR_FULL
5634 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
5635 "to C_LOC", &x
->where
))
5644 gfc_check_sleep_sub (gfc_expr
*seconds
)
5646 if (!type_check (seconds
, 0, BT_INTEGER
))
5649 if (!scalar_check (seconds
, 0))
5656 gfc_check_sngl (gfc_expr
*a
)
5658 if (!type_check (a
, 0, BT_REAL
))
5661 if ((a
->ts
.kind
!= gfc_default_double_kind
)
5662 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
5663 "REAL argument to %s intrinsic at %L",
5664 gfc_current_intrinsic
, &a
->where
))
5671 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
5673 if (gfc_invalid_null_arg (source
))
5676 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
5678 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5679 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
5680 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
5688 if (!dim_check (dim
, 1, false))
5691 /* dim_rank_check() does not apply here. */
5693 && dim
->expr_type
== EXPR_CONSTANT
5694 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
5695 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
5697 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5698 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
5699 gfc_current_intrinsic
, &dim
->where
);
5703 if (!type_check (ncopies
, 2, BT_INTEGER
))
5706 if (!scalar_check (ncopies
, 2))
5713 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5717 arg_strlen_is_zero (gfc_expr
*c
, int n
)
5719 if (gfc_var_strlen (c
) == 0)
5721 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5722 "length at least 1", gfc_current_intrinsic_arg
[n
]->name
,
5723 gfc_current_intrinsic
, &c
->where
);
5730 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
5732 if (!type_check (unit
, 0, BT_INTEGER
))
5735 if (!scalar_check (unit
, 0))
5738 if (!type_check (c
, 1, BT_CHARACTER
))
5740 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5742 if (strcmp (gfc_current_intrinsic
, "fgetc") == 0
5743 && !variable_check (c
, 1, false))
5745 if (arg_strlen_is_zero (c
, 1))
5751 if (!type_check (status
, 2, BT_INTEGER
)
5752 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5753 || !scalar_check (status
, 2)
5754 || !variable_check (status
, 2, false))
5762 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5764 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5769 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5771 if (!type_check (c
, 0, BT_CHARACTER
))
5773 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5775 if (strcmp (gfc_current_intrinsic
, "fget") == 0
5776 && !variable_check (c
, 0, false))
5778 if (arg_strlen_is_zero (c
, 0))
5784 if (!type_check (status
, 1, BT_INTEGER
)
5785 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5786 || !scalar_check (status
, 1)
5787 || !variable_check (status
, 1, false))
5795 gfc_check_fgetput (gfc_expr
*c
)
5797 return gfc_check_fgetput_sub (c
, NULL
);
5802 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5804 if (!type_check (unit
, 0, BT_INTEGER
))
5807 if (!scalar_check (unit
, 0))
5810 if (!type_check (offset
, 1, BT_INTEGER
))
5813 if (!scalar_check (offset
, 1))
5816 if (!type_check (whence
, 2, BT_INTEGER
))
5819 if (!scalar_check (whence
, 2))
5825 if (!type_check (status
, 3, BT_INTEGER
))
5828 if (!kind_value_check (status
, 3, 4))
5831 if (!scalar_check (status
, 3))
5840 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5842 if (!type_check (unit
, 0, BT_INTEGER
))
5845 if (!scalar_check (unit
, 0))
5848 if (!type_check (array
, 1, BT_INTEGER
)
5849 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5852 if (!array_check (array
, 1))
5860 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5862 if (!type_check (unit
, 0, BT_INTEGER
))
5865 if (!scalar_check (unit
, 0))
5868 if (!type_check (array
, 1, BT_INTEGER
)
5869 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5872 if (!array_check (array
, 1))
5878 if (!type_check (status
, 2, BT_INTEGER
)
5879 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5882 if (!scalar_check (status
, 2))
5890 gfc_check_ftell (gfc_expr
*unit
)
5892 if (!type_check (unit
, 0, BT_INTEGER
))
5895 if (!scalar_check (unit
, 0))
5903 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5905 if (!type_check (unit
, 0, BT_INTEGER
))
5908 if (!scalar_check (unit
, 0))
5911 if (!type_check (offset
, 1, BT_INTEGER
))
5914 if (!scalar_check (offset
, 1))
5922 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5924 if (!type_check (name
, 0, BT_CHARACTER
))
5926 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5929 if (!type_check (array
, 1, BT_INTEGER
)
5930 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5933 if (!array_check (array
, 1))
5941 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5943 if (!type_check (name
, 0, BT_CHARACTER
))
5945 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5948 if (!type_check (array
, 1, BT_INTEGER
)
5949 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5952 if (!array_check (array
, 1))
5958 if (!type_check (status
, 2, BT_INTEGER
)
5959 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5962 if (!scalar_check (status
, 2))
5970 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5974 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5976 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5980 if (!coarray_check (coarray
, 0))
5985 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5986 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5990 if (sub
->ts
.type
!= BT_INTEGER
)
5992 gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
5993 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5997 if (gfc_array_size (sub
, &nelems
))
5999 int corank
= gfc_get_corank (coarray
);
6001 if (mpz_cmp_ui (nelems
, corank
) != 0)
6003 gfc_error ("The number of array elements of the SUB argument to "
6004 "IMAGE_INDEX at %L shall be %d (corank) not %d",
6005 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
6017 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
6019 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6021 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6027 if (!type_check (distance
, 0, BT_INTEGER
))
6030 if (!nonnegative_check ("DISTANCE", distance
))
6033 if (!scalar_check (distance
, 0))
6036 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6037 "NUM_IMAGES at %L", &distance
->where
))
6043 if (!type_check (failed
, 1, BT_LOGICAL
))
6046 if (!scalar_check (failed
, 1))
6049 if (!gfc_notify_std (GFC_STD_F2018
, "FAILED= argument to "
6050 "NUM_IMAGES at %L", &failed
->where
))
6059 gfc_check_team_number (gfc_expr
*team
)
6061 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6063 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6069 if (team
->ts
.type
!= BT_DERIVED
6070 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
6071 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
6073 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
6074 "shall be of type TEAM_TYPE", &team
->where
);
6086 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
6088 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6090 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6094 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
6097 if (dim
!= NULL
&& coarray
== NULL
)
6099 gfc_error ("DIM argument without COARRAY argument not allowed for "
6100 "THIS_IMAGE intrinsic at %L", &dim
->where
);
6104 if (distance
&& (coarray
|| dim
))
6106 gfc_error ("The DISTANCE argument may not be specified together with the "
6107 "COARRAY or DIM argument in intrinsic at %L",
6112 /* Assume that we have "this_image (distance)". */
6113 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
6117 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6126 if (!type_check (distance
, 2, BT_INTEGER
))
6129 if (!nonnegative_check ("DISTANCE", distance
))
6132 if (!scalar_check (distance
, 2))
6135 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6136 "THIS_IMAGE at %L", &distance
->where
))
6142 if (!coarray_check (coarray
, 0))
6147 if (!dim_check (dim
, 1, false))
6150 if (!dim_corank_check (dim
, coarray
))
6157 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6158 by gfc_simplify_transfer. Return false if we cannot do so. */
6161 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
6162 size_t *source_size
, size_t *result_size
,
6163 size_t *result_length_p
)
6165 size_t result_elt_size
;
6167 if (source
->expr_type
== EXPR_FUNCTION
)
6170 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
6173 /* Calculate the size of the source. */
6174 if (!gfc_target_expr_size (source
, source_size
))
6177 /* Determine the size of the element. */
6178 if (!gfc_element_size (mold
, &result_elt_size
))
6181 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6182 * a scalar with the type and type parameters of MOLD shall not have a
6183 * storage size equal to zero.
6184 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6185 * If MOLD is an array and SIZE is absent, the result is an array and of
6186 * rank one. Its size is as small as possible such that its physical
6187 * representation is not shorter than that of SOURCE.
6188 * If SIZE is present, the result is an array of rank one and size SIZE.
6190 if (result_elt_size
== 0 && *source_size
> 0
6191 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6193 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6194 "array and shall not have storage size 0 when %<SOURCE%> "
6195 "argument has size greater than 0", &mold
->where
);
6199 if (result_elt_size
== 0 && *source_size
== 0 && !size
)
6202 if (result_length_p
)
6203 *result_length_p
= 0;
6207 if ((result_elt_size
> 0 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6213 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6216 result_length
= *source_size
/ result_elt_size
;
6217 if (result_length
* result_elt_size
< *source_size
)
6221 *result_size
= result_length
* result_elt_size
;
6222 if (result_length_p
)
6223 *result_length_p
= result_length
;
6226 *result_size
= result_elt_size
;
6233 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6238 if (gfc_invalid_null_arg (source
))
6241 /* SOURCE shall be a scalar or array of any type. */
6242 if (source
->ts
.type
== BT_PROCEDURE
6243 && source
->symtree
->n
.sym
->attr
.subroutine
== 1)
6245 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6246 "must not be a %s", &source
->where
,
6247 gfc_basic_typename (source
->ts
.type
));
6251 if (source
->ts
.type
== BT_BOZ
&& illegal_boz_arg (source
))
6254 if (mold
->ts
.type
== BT_BOZ
&& illegal_boz_arg (mold
))
6257 if (gfc_invalid_null_arg (mold
))
6260 /* MOLD shall be a scalar or array of any type. */
6261 if (mold
->ts
.type
== BT_PROCEDURE
6262 && mold
->symtree
->n
.sym
->attr
.subroutine
== 1)
6264 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6265 "must not be a %s", &mold
->where
,
6266 gfc_basic_typename (mold
->ts
.type
));
6270 if (mold
->ts
.type
== BT_HOLLERITH
)
6272 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6273 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
6277 /* SIZE (optional) shall be an integer scalar. The corresponding actual
6278 argument shall not be an optional dummy argument. */
6281 if (!type_check (size
, 2, BT_INTEGER
))
6283 if (size
->ts
.type
== BT_BOZ
)
6288 if (!scalar_check (size
, 2))
6291 if (!nonoptional_check (size
, 2))
6295 if (!warn_surprising
)
6298 /* If we can't calculate the sizes, we cannot check any more.
6299 Return true for that case. */
6301 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6302 &result_size
, NULL
))
6305 if (source_size
< result_size
)
6306 gfc_warning (OPT_Wsurprising
,
6307 "Intrinsic TRANSFER at %L has partly undefined result: "
6308 "source size %zd < result size %zd", &source
->where
,
6309 source_size
, result_size
);
6316 gfc_check_transpose (gfc_expr
*matrix
)
6318 if (!rank_check (matrix
, 0, 2))
6326 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6328 if (!array_check (array
, 0))
6331 if (!dim_check (dim
, 1, false))
6334 if (!dim_rank_check (dim
, array
, 0))
6337 if (!kind_check (kind
, 2, BT_INTEGER
))
6339 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6340 "with KIND argument at %L",
6341 gfc_current_intrinsic
, &kind
->where
))
6349 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
6351 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6353 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6357 if (!coarray_check (coarray
, 0))
6362 if (!dim_check (dim
, 1, false))
6365 if (!dim_corank_check (dim
, coarray
))
6369 if (!kind_check (kind
, 2, BT_INTEGER
))
6377 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6381 if (!rank_check (vector
, 0, 1))
6384 if (!array_check (mask
, 1))
6387 if (!type_check (mask
, 1, BT_LOGICAL
))
6390 if (!same_type_check (vector
, 0, field
, 2))
6393 gfc_simplify_expr (mask
, 0);
6395 if (mask
->expr_type
== EXPR_ARRAY
6396 && gfc_array_size (vector
, &vector_size
))
6398 int mask_true_count
= 0;
6399 gfc_constructor
*mask_ctor
;
6400 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6403 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
6405 mask_true_count
= 0;
6409 if (mask_ctor
->expr
->value
.logical
)
6412 mask_ctor
= gfc_constructor_next (mask_ctor
);
6415 if (mpz_get_si (vector_size
) < mask_true_count
)
6417 gfc_error ("%qs argument of %qs intrinsic at %L must "
6418 "provide at least as many elements as there "
6419 "are .TRUE. values in %qs (%ld/%d)",
6420 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6421 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
6422 mpz_get_si (vector_size
), mask_true_count
);
6426 mpz_clear (vector_size
);
6429 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
6431 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6432 "the same rank as %qs or be a scalar",
6433 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6434 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
6438 if (mask
->rank
== field
->rank
)
6441 for (i
= 0; i
< field
->rank
; i
++)
6442 if (! identical_dimen_shape (mask
, i
, field
, i
))
6444 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6445 "must have identical shape.",
6446 gfc_current_intrinsic_arg
[2]->name
,
6447 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6457 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
6459 if (!type_check (x
, 0, BT_CHARACTER
))
6462 if (!same_type_check (x
, 0, y
, 1))
6465 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
6468 if (!kind_check (kind
, 3, BT_INTEGER
))
6470 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6471 "with KIND argument at %L",
6472 gfc_current_intrinsic
, &kind
->where
))
6480 gfc_check_trim (gfc_expr
*x
)
6482 if (!type_check (x
, 0, BT_CHARACTER
))
6485 if (gfc_invalid_null_arg (x
))
6488 if (!scalar_check (x
, 0))
6496 gfc_check_ttynam (gfc_expr
*unit
)
6498 if (!scalar_check (unit
, 0))
6501 if (!type_check (unit
, 0, BT_INTEGER
))
6508 /************* Check functions for intrinsic subroutines *************/
6511 gfc_check_cpu_time (gfc_expr
*time
)
6513 if (!scalar_check (time
, 0))
6516 if (!type_check (time
, 0, BT_REAL
))
6519 if (!variable_check (time
, 0, false))
6527 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
6528 gfc_expr
*zone
, gfc_expr
*values
)
6532 if (!type_check (date
, 0, BT_CHARACTER
))
6534 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6536 if (!scalar_check (date
, 0))
6538 if (!variable_check (date
, 0, false))
6544 if (!type_check (time
, 1, BT_CHARACTER
))
6546 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
6548 if (!scalar_check (time
, 1))
6550 if (!variable_check (time
, 1, false))
6556 if (!type_check (zone
, 2, BT_CHARACTER
))
6558 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
6560 if (!scalar_check (zone
, 2))
6562 if (!variable_check (zone
, 2, false))
6568 if (!type_check (values
, 3, BT_INTEGER
))
6570 if (!array_check (values
, 3))
6572 if (!rank_check (values
, 3, 1))
6574 if (!variable_check (values
, 3, false))
6576 if (!array_size_check (values
, 3, 8))
6579 if (values
->ts
.kind
!= gfc_default_integer_kind
6580 && !gfc_notify_std (GFC_STD_F2018
, "VALUES argument of "
6581 "DATE_AND_TIME at %L has non-default kind",
6585 /* F2018:16.9.59 DATE_AND_TIME
6586 "VALUES shall be a rank-one array of type integer
6587 with a decimal exponent range of at least four."
6588 This is a hard limit also required by the implementation in
6590 if (values
->ts
.kind
< 2)
6592 gfc_error ("VALUES argument of DATE_AND_TIME at %L must have "
6593 "a decimal exponent range of at least four",
6604 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
6605 gfc_expr
*to
, gfc_expr
*topos
)
6607 if (!type_check (from
, 0, BT_INTEGER
))
6610 if (!type_check (frompos
, 1, BT_INTEGER
))
6613 if (!type_check (len
, 2, BT_INTEGER
))
6616 if (!same_type_check (from
, 0, to
, 3))
6619 if (!variable_check (to
, 3, false))
6622 if (!type_check (topos
, 4, BT_INTEGER
))
6625 if (!nonnegative_check ("frompos", frompos
))
6628 if (!nonnegative_check ("topos", topos
))
6631 if (!nonnegative_check ("len", len
))
6634 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
6637 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
6644 /* Check the arguments for RANDOM_INIT. */
6647 gfc_check_random_init (gfc_expr
*repeatable
, gfc_expr
*image_distinct
)
6649 if (!type_check (repeatable
, 0, BT_LOGICAL
))
6652 if (!scalar_check (repeatable
, 0))
6655 if (!type_check (image_distinct
, 1, BT_LOGICAL
))
6658 if (!scalar_check (image_distinct
, 1))
6666 gfc_check_random_number (gfc_expr
*harvest
)
6668 if (!type_check (harvest
, 0, BT_REAL
))
6671 if (!variable_check (harvest
, 0, false))
6679 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
6681 unsigned int nargs
= 0, seed_size
;
6682 locus
*where
= NULL
;
6683 mpz_t put_size
, get_size
;
6685 /* Keep the number of bytes in sync with master_state in
6686 libgfortran/intrinsics/random.c. */
6687 seed_size
= 32 / gfc_default_integer_kind
;
6691 if (size
->expr_type
!= EXPR_VARIABLE
6692 || !size
->symtree
->n
.sym
->attr
.optional
)
6695 if (!scalar_check (size
, 0))
6698 if (!type_check (size
, 0, BT_INTEGER
))
6701 if (!variable_check (size
, 0, false))
6704 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
6710 if (put
->expr_type
!= EXPR_VARIABLE
6711 || !put
->symtree
->n
.sym
->attr
.optional
)
6714 where
= &put
->where
;
6717 if (!array_check (put
, 1))
6720 if (!rank_check (put
, 1, 1))
6723 if (!type_check (put
, 1, BT_INTEGER
))
6726 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
6729 if (gfc_array_size (put
, &put_size
)
6730 && mpz_get_ui (put_size
) < seed_size
)
6731 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6732 "too small (%i/%i)",
6733 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6734 &put
->where
, (int) mpz_get_ui (put_size
), seed_size
);
6739 if (get
->expr_type
!= EXPR_VARIABLE
6740 || !get
->symtree
->n
.sym
->attr
.optional
)
6743 where
= &get
->where
;
6746 if (!array_check (get
, 2))
6749 if (!rank_check (get
, 2, 1))
6752 if (!type_check (get
, 2, BT_INTEGER
))
6755 if (!variable_check (get
, 2, false))
6758 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
6761 if (gfc_array_size (get
, &get_size
)
6762 && mpz_get_ui (get_size
) < seed_size
)
6763 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6764 "too small (%i/%i)",
6765 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6766 &get
->where
, (int) mpz_get_ui (get_size
), seed_size
);
6769 /* RANDOM_SEED may not have more than one non-optional argument. */
6771 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
6777 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
6781 int num_percent
, nargs
;
6784 if (e
->expr_type
!= EXPR_CONSTANT
)
6787 len
= e
->value
.character
.length
;
6788 if (e
->value
.character
.string
[len
-1] != '\0')
6789 gfc_internal_error ("fe_runtime_error string must be null terminated");
6792 for (i
=0; i
<len
-1; i
++)
6793 if (e
->value
.character
.string
[i
] == '%')
6797 for (; a
; a
= a
->next
)
6800 if (nargs
-1 != num_percent
)
6801 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6802 nargs
, num_percent
++);
6808 gfc_check_second_sub (gfc_expr
*time
)
6810 if (!scalar_check (time
, 0))
6813 if (!type_check (time
, 0, BT_REAL
))
6816 if (!kind_value_check (time
, 0, 4))
6823 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6824 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6825 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6826 count_max are all optional arguments */
6829 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
6830 gfc_expr
*count_max
)
6832 int first_int_kind
= -1;
6836 if (!scalar_check (count
, 0))
6839 if (!type_check (count
, 0, BT_INTEGER
))
6842 if (count
->ts
.kind
!= gfc_default_integer_kind
6843 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
6844 "SYSTEM_CLOCK at %L has non-default kind",
6848 if (count
->ts
.kind
< gfc_default_integer_kind
6849 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6850 "COUNT argument to SYSTEM_CLOCK at %L "
6851 "with kind smaller than default integer",
6855 if (!variable_check (count
, 0, false))
6858 first_int_kind
= count
->ts
.kind
;
6861 if (count_rate
!= NULL
)
6863 if (!scalar_check (count_rate
, 1))
6866 if (!variable_check (count_rate
, 1, false))
6869 if (count_rate
->ts
.type
== BT_REAL
)
6871 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
6872 "SYSTEM_CLOCK at %L", &count_rate
->where
))
6877 if (!type_check (count_rate
, 1, BT_INTEGER
))
6880 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6881 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6882 "SYSTEM_CLOCK at %L has non-default kind",
6883 &count_rate
->where
))
6886 if (count_rate
->ts
.kind
< gfc_default_integer_kind
6887 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6888 "COUNT_RATE argument to SYSTEM_CLOCK at %L "
6889 "with kind smaller than default integer",
6890 &count_rate
->where
))
6893 if (first_int_kind
< 0)
6894 first_int_kind
= count_rate
->ts
.kind
;
6899 if (count_max
!= NULL
)
6901 if (!scalar_check (count_max
, 2))
6904 if (!type_check (count_max
, 2, BT_INTEGER
))
6907 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6908 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6909 "SYSTEM_CLOCK at %L has non-default kind",
6913 if (!variable_check (count_max
, 2, false))
6916 if (count_max
->ts
.kind
< gfc_default_integer_kind
6917 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6918 "COUNT_MAX argument to SYSTEM_CLOCK at %L "
6919 "with kind smaller than default integer",
6923 if (first_int_kind
< 0)
6924 first_int_kind
= count_max
->ts
.kind
;
6927 if (first_int_kind
> 0)
6930 && count_rate
->ts
.type
== BT_INTEGER
6931 && count_rate
->ts
.kind
!= first_int_kind
6932 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6933 "integer arguments to SYSTEM_CLOCK at %L "
6934 "with different kind parameters",
6935 &count_rate
->where
))
6938 if (count_max
&& count_max
->ts
.kind
!= first_int_kind
6939 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6940 "integer arguments to SYSTEM_CLOCK at %L "
6941 "with different kind parameters",
6951 gfc_check_irand (gfc_expr
*x
)
6956 if (!scalar_check (x
, 0))
6959 if (!type_check (x
, 0, BT_INTEGER
))
6962 if (!kind_value_check (x
, 0, 4))
6970 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6972 if (!scalar_check (seconds
, 0))
6974 if (!type_check (seconds
, 0, BT_INTEGER
))
6977 if (!int_or_proc_check (handler
, 1))
6979 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6985 if (!scalar_check (status
, 2))
6987 if (!type_check (status
, 2, BT_INTEGER
))
6989 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6997 gfc_check_rand (gfc_expr
*x
)
7002 if (!scalar_check (x
, 0))
7005 if (!type_check (x
, 0, BT_INTEGER
))
7008 if (!kind_value_check (x
, 0, 4))
7016 gfc_check_srand (gfc_expr
*x
)
7018 if (!scalar_check (x
, 0))
7021 if (!type_check (x
, 0, BT_INTEGER
))
7024 if (!kind_value_check (x
, 0, 4))
7032 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
7034 if (!scalar_check (time
, 0))
7036 if (!type_check (time
, 0, BT_INTEGER
))
7039 if (!type_check (result
, 1, BT_CHARACTER
))
7041 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
7049 gfc_check_dtime_etime (gfc_expr
*x
)
7051 if (!array_check (x
, 0))
7054 if (!rank_check (x
, 0, 1))
7057 if (!variable_check (x
, 0, false))
7060 if (!type_check (x
, 0, BT_REAL
))
7063 if (!kind_value_check (x
, 0, 4))
7071 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
7073 if (!array_check (values
, 0))
7076 if (!rank_check (values
, 0, 1))
7079 if (!variable_check (values
, 0, false))
7082 if (!type_check (values
, 0, BT_REAL
))
7085 if (!kind_value_check (values
, 0, 4))
7088 if (!scalar_check (time
, 1))
7091 if (!type_check (time
, 1, BT_REAL
))
7094 if (!kind_value_check (time
, 1, 4))
7102 gfc_check_fdate_sub (gfc_expr
*date
)
7104 if (!type_check (date
, 0, BT_CHARACTER
))
7106 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
7114 gfc_check_gerror (gfc_expr
*msg
)
7116 if (!type_check (msg
, 0, BT_CHARACTER
))
7118 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7126 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
7128 if (!type_check (cwd
, 0, BT_CHARACTER
))
7130 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
7136 if (!scalar_check (status
, 1))
7139 if (!type_check (status
, 1, BT_INTEGER
))
7147 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
7149 if (!type_check (pos
, 0, BT_INTEGER
))
7152 if (pos
->ts
.kind
> gfc_default_integer_kind
)
7154 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
7155 "not wider than the default kind (%d)",
7156 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7157 &pos
->where
, gfc_default_integer_kind
);
7161 if (!type_check (value
, 1, BT_CHARACTER
))
7163 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
7171 gfc_check_getlog (gfc_expr
*msg
)
7173 if (!type_check (msg
, 0, BT_CHARACTER
))
7175 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7183 gfc_check_exit (gfc_expr
*status
)
7188 if (!type_check (status
, 0, BT_INTEGER
))
7191 if (!scalar_check (status
, 0))
7199 gfc_check_flush (gfc_expr
*unit
)
7204 if (!type_check (unit
, 0, BT_INTEGER
))
7207 if (!scalar_check (unit
, 0))
7215 gfc_check_free (gfc_expr
*i
)
7217 if (!type_check (i
, 0, BT_INTEGER
))
7220 if (!scalar_check (i
, 0))
7228 gfc_check_hostnm (gfc_expr
*name
)
7230 if (!type_check (name
, 0, BT_CHARACTER
))
7232 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7240 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
7242 if (!type_check (name
, 0, BT_CHARACTER
))
7244 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7250 if (!scalar_check (status
, 1))
7253 if (!type_check (status
, 1, BT_INTEGER
))
7261 gfc_check_itime_idate (gfc_expr
*values
)
7263 if (!array_check (values
, 0))
7266 if (!rank_check (values
, 0, 1))
7269 if (!variable_check (values
, 0, false))
7272 if (!type_check (values
, 0, BT_INTEGER
))
7275 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
7283 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
7285 if (!type_check (time
, 0, BT_INTEGER
))
7288 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
7291 if (!scalar_check (time
, 0))
7294 if (!array_check (values
, 1))
7297 if (!rank_check (values
, 1, 1))
7300 if (!variable_check (values
, 1, false))
7303 if (!type_check (values
, 1, BT_INTEGER
))
7306 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
7314 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
7316 if (!scalar_check (unit
, 0))
7319 if (!type_check (unit
, 0, BT_INTEGER
))
7322 if (!type_check (name
, 1, BT_CHARACTER
))
7324 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
7332 gfc_check_is_contiguous (gfc_expr
*array
)
7334 if (array
->expr_type
== EXPR_NULL
)
7336 gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7337 "associated pointer", &array
->where
, gfc_current_intrinsic
);
7341 if (!array_check (array
, 0))
7349 gfc_check_isatty (gfc_expr
*unit
)
7354 if (!type_check (unit
, 0, BT_INTEGER
))
7357 if (!scalar_check (unit
, 0))
7365 gfc_check_isnan (gfc_expr
*x
)
7367 if (!type_check (x
, 0, BT_REAL
))
7375 gfc_check_perror (gfc_expr
*string
)
7377 if (!type_check (string
, 0, BT_CHARACTER
))
7379 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
7387 gfc_check_umask (gfc_expr
*mask
)
7389 if (!type_check (mask
, 0, BT_INTEGER
))
7392 if (!scalar_check (mask
, 0))
7400 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
7402 if (!type_check (mask
, 0, BT_INTEGER
))
7405 if (!scalar_check (mask
, 0))
7411 if (!scalar_check (old
, 1))
7414 if (!type_check (old
, 1, BT_INTEGER
))
7422 gfc_check_unlink (gfc_expr
*name
)
7424 if (!type_check (name
, 0, BT_CHARACTER
))
7426 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7434 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
7436 if (!type_check (name
, 0, BT_CHARACTER
))
7438 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7444 if (!scalar_check (status
, 1))
7447 if (!type_check (status
, 1, BT_INTEGER
))
7455 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
7457 if (!scalar_check (number
, 0))
7459 if (!type_check (number
, 0, BT_INTEGER
))
7462 if (!int_or_proc_check (handler
, 1))
7464 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7472 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
7474 if (!scalar_check (number
, 0))
7476 if (!type_check (number
, 0, BT_INTEGER
))
7479 if (!int_or_proc_check (handler
, 1))
7481 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7487 if (!type_check (status
, 2, BT_INTEGER
))
7489 if (!scalar_check (status
, 2))
7497 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
7499 if (!type_check (cmd
, 0, BT_CHARACTER
))
7501 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
7504 if (!scalar_check (status
, 1))
7507 if (!type_check (status
, 1, BT_INTEGER
))
7510 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
7517 /* This is used for the GNU intrinsics AND, OR and XOR. */
7519 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
7521 if (i
->ts
.type
!= BT_INTEGER
7522 && i
->ts
.type
!= BT_LOGICAL
7523 && i
->ts
.type
!= BT_BOZ
)
7525 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7526 "LOGICAL, or a BOZ literal constant",
7527 gfc_current_intrinsic_arg
[0]->name
,
7528 gfc_current_intrinsic
, &i
->where
);
7532 if (j
->ts
.type
!= BT_INTEGER
7533 && j
->ts
.type
!= BT_LOGICAL
7534 && j
->ts
.type
!= BT_BOZ
)
7536 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7537 "LOGICAL, or a BOZ literal constant",
7538 gfc_current_intrinsic_arg
[1]->name
,
7539 gfc_current_intrinsic
, &j
->where
);
7543 /* i and j cannot both be BOZ literal constants. */
7544 if (!boz_args_check (i
, j
))
7547 /* If i is BOZ and j is integer, convert i to type of j. */
7548 if (i
->ts
.type
== BT_BOZ
)
7550 if (j
->ts
.type
!= BT_INTEGER
)
7552 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7553 gfc_current_intrinsic_arg
[1]->name
,
7554 gfc_current_intrinsic
, &j
->where
);
7558 if (!gfc_boz2int (i
, j
->ts
.kind
))
7562 /* If j is BOZ and i is integer, convert j to type of i. */
7563 if (j
->ts
.type
== BT_BOZ
)
7565 if (i
->ts
.type
!= BT_INTEGER
)
7567 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7568 gfc_current_intrinsic_arg
[0]->name
,
7569 gfc_current_intrinsic
, &j
->where
);
7573 if (!gfc_boz2int (j
, i
->ts
.kind
))
7577 if (!same_type_check (i
, 0, j
, 1, false))
7580 if (!scalar_check (i
, 0))
7583 if (!scalar_check (j
, 1))
7591 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
7594 if (a
->expr_type
== EXPR_NULL
)
7596 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7597 "argument to STORAGE_SIZE, because it returns a "
7598 "disassociated pointer", &a
->where
);
7602 if (a
->ts
.type
== BT_ASSUMED
)
7604 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7605 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7610 if (a
->ts
.type
== BT_PROCEDURE
)
7612 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7613 "procedure", gfc_current_intrinsic_arg
[0]->name
,
7614 gfc_current_intrinsic
, &a
->where
);
7618 if (a
->ts
.type
== BT_BOZ
&& illegal_boz_arg (a
))
7624 if (!type_check (kind
, 1, BT_INTEGER
))
7627 if (!scalar_check (kind
, 1))
7630 if (kind
->expr_type
!= EXPR_CONSTANT
)
7632 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7633 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,