2 Copyright (C) 2002-2023 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 (!variable_check (mold
, 0, true))
4390 attr
= gfc_variable_attr (mold
, NULL
);
4392 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
4394 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4395 "ALLOCATABLE or procedure pointer",
4396 gfc_current_intrinsic_arg
[0]->name
,
4397 gfc_current_intrinsic
, &mold
->where
);
4401 if (attr
.allocatable
4402 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
4403 "allocatable MOLD at %L", &mold
->where
))
4407 if (gfc_is_coindexed (mold
))
4409 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4410 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
4411 gfc_current_intrinsic
, &mold
->where
);
4420 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4422 if (!array_check (array
, 0))
4425 if (!type_check (mask
, 1, BT_LOGICAL
))
4428 if (!gfc_check_conformance (array
, mask
,
4429 _("arguments '%s' and '%s' for intrinsic '%s'"),
4430 gfc_current_intrinsic_arg
[0]->name
,
4431 gfc_current_intrinsic_arg
[1]->name
,
4432 gfc_current_intrinsic
))
4437 mpz_t array_size
, vector_size
;
4438 bool have_array_size
, have_vector_size
;
4440 if (!same_type_check (array
, 0, vector
, 2))
4443 if (!rank_check (vector
, 2, 1))
4446 /* VECTOR requires at least as many elements as MASK
4447 has .TRUE. values. */
4448 have_array_size
= gfc_array_size(array
, &array_size
);
4449 have_vector_size
= gfc_array_size(vector
, &vector_size
);
4451 if (have_vector_size
4452 && (mask
->expr_type
== EXPR_ARRAY
4453 || (mask
->expr_type
== EXPR_CONSTANT
4454 && have_array_size
)))
4456 int mask_true_values
= 0;
4458 if (mask
->expr_type
== EXPR_ARRAY
)
4460 gfc_constructor
*mask_ctor
;
4461 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4464 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4466 mask_true_values
= 0;
4470 if (mask_ctor
->expr
->value
.logical
)
4473 mask_ctor
= gfc_constructor_next (mask_ctor
);
4476 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
4477 mask_true_values
= mpz_get_si (array_size
);
4479 if (mpz_get_si (vector_size
) < mask_true_values
)
4481 gfc_error ("%qs argument of %qs intrinsic at %L must "
4482 "provide at least as many elements as there "
4483 "are .TRUE. values in %qs (%ld/%d)",
4484 gfc_current_intrinsic_arg
[2]->name
,
4485 gfc_current_intrinsic
, &vector
->where
,
4486 gfc_current_intrinsic_arg
[1]->name
,
4487 mpz_get_si (vector_size
), mask_true_values
);
4492 if (have_array_size
)
4493 mpz_clear (array_size
);
4494 if (have_vector_size
)
4495 mpz_clear (vector_size
);
4503 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
4505 if (!type_check (mask
, 0, BT_LOGICAL
))
4508 if (!array_check (mask
, 0))
4511 if (!dim_check (dim
, 1, false))
4514 if (!dim_rank_check (dim
, mask
, false))
4522 gfc_check_precision (gfc_expr
*x
)
4524 if (!real_or_complex_check (x
, 0))
4532 gfc_check_present (gfc_expr
*a
)
4536 if (!variable_check (a
, 0, true))
4539 sym
= a
->symtree
->n
.sym
;
4540 if (!sym
->attr
.dummy
)
4542 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4543 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
4544 gfc_current_intrinsic
, &a
->where
);
4548 /* For CLASS, the optional attribute might be set at either location. */
4549 if ((sym
->ts
.type
!= BT_CLASS
|| !CLASS_DATA (sym
)->attr
.optional
)
4550 && !sym
->attr
.optional
)
4552 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4553 "an OPTIONAL dummy variable",
4554 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4559 /* 13.14.82 PRESENT(A)
4561 Argument. A shall be the name of an optional dummy argument that is
4562 accessible in the subprogram in which the PRESENT function reference
4566 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
4567 && (a
->ref
->u
.ar
.type
== AR_FULL
4568 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
4569 && a
->ref
->u
.ar
.as
->rank
== 0))))
4571 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4572 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
4573 gfc_current_intrinsic
, &a
->where
, sym
->name
);
4582 gfc_check_radix (gfc_expr
*x
)
4584 if (!int_or_real_check (x
, 0))
4592 gfc_check_range (gfc_expr
*x
)
4594 if (!numeric_check (x
, 0))
4602 gfc_check_rank (gfc_expr
*a
)
4604 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4605 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4607 bool is_variable
= true;
4609 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4610 if (a
->expr_type
== EXPR_FUNCTION
)
4611 is_variable
= a
->value
.function
.esym
4612 ? a
->value
.function
.esym
->result
->attr
.pointer
4613 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
4615 if (a
->expr_type
== EXPR_OP
4616 || a
->expr_type
== EXPR_NULL
4617 || a
->expr_type
== EXPR_COMPCALL
4618 || a
->expr_type
== EXPR_PPC
4619 || a
->ts
.type
== BT_PROCEDURE
4622 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4623 "object", &a
->where
);
4632 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
4634 if (!kind_check (kind
, 1, BT_REAL
))
4637 /* BOZ is dealt with in gfc_simplify_real. */
4638 if (a
->ts
.type
== BT_BOZ
)
4641 if (!numeric_check (a
, 0))
4649 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
4651 if (!type_check (path1
, 0, BT_CHARACTER
))
4653 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4656 if (!type_check (path2
, 1, BT_CHARACTER
))
4658 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4666 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
4668 if (!type_check (path1
, 0, BT_CHARACTER
))
4670 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4673 if (!type_check (path2
, 1, BT_CHARACTER
))
4675 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4681 if (!type_check (status
, 2, BT_INTEGER
))
4684 if (!scalar_check (status
, 2))
4692 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
4694 if (!type_check (x
, 0, BT_CHARACTER
))
4697 if (!scalar_check (x
, 0))
4700 if (!type_check (y
, 0, BT_INTEGER
))
4703 if (!scalar_check (y
, 1))
4711 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
4712 gfc_expr
*pad
, gfc_expr
*order
)
4717 bool shape_is_const
;
4719 if (!array_check (source
, 0))
4722 if (!rank_check (shape
, 1, 1))
4725 if (!type_check (shape
, 1, BT_INTEGER
))
4728 if (!gfc_array_size (shape
, &size
))
4730 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4731 "array of constant size", &shape
->where
);
4735 shape_size
= mpz_get_ui (size
);
4738 if (shape_size
<= 0)
4740 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4741 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4745 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4747 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4748 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4752 gfc_simplify_expr (shape
, 0);
4753 shape_is_const
= gfc_is_constant_array_expr (shape
);
4755 if (shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
)
4759 for (i
= 0; i
< shape_size
; ++i
)
4761 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4764 if (e
->expr_type
!= EXPR_CONSTANT
)
4767 gfc_extract_int (e
, &extent
);
4770 gfc_error ("%qs argument of %qs intrinsic at %L has "
4771 "negative element (%d)",
4772 gfc_current_intrinsic_arg
[1]->name
,
4773 gfc_current_intrinsic
, &shape
->where
, extent
);
4781 if (!same_type_check (source
, 0, pad
, 2))
4784 if (!array_check (pad
, 2))
4790 if (!array_check (order
, 3))
4793 if (!type_check (order
, 3, BT_INTEGER
))
4796 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_array_expr (order
))
4798 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4801 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4804 gfc_array_size (order
, &size
);
4805 order_size
= mpz_get_ui (size
);
4808 if (order_size
!= shape_size
)
4810 gfc_error ("%qs argument of %qs intrinsic at %L "
4811 "has wrong number of elements (%d/%d)",
4812 gfc_current_intrinsic_arg
[3]->name
,
4813 gfc_current_intrinsic
, &order
->where
,
4814 order_size
, shape_size
);
4818 for (i
= 1; i
<= order_size
; ++i
)
4820 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4821 if (e
->expr_type
!= EXPR_CONSTANT
)
4824 gfc_extract_int (e
, &dim
);
4826 if (dim
< 1 || dim
> order_size
)
4828 gfc_error ("%qs argument of %qs intrinsic at %L "
4829 "has out-of-range dimension (%d)",
4830 gfc_current_intrinsic_arg
[3]->name
,
4831 gfc_current_intrinsic
, &e
->where
, dim
);
4835 if (perm
[dim
-1] != 0)
4837 gfc_error ("%qs argument of %qs intrinsic at %L has "
4838 "invalid permutation of dimensions (dimension "
4840 gfc_current_intrinsic_arg
[3]->name
,
4841 gfc_current_intrinsic
, &e
->where
, dim
);
4850 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
4851 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4852 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4854 /* Check the match in size between source and destination. */
4855 if (gfc_array_size (source
, &nelems
))
4861 mpz_init_set_ui (size
, 1);
4862 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4863 c
; c
= gfc_constructor_next (c
))
4864 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4866 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4872 gfc_error ("Without padding, there are not enough elements "
4873 "in the intrinsic RESHAPE source at %L to match "
4874 "the shape", &source
->where
);
4885 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4887 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4889 gfc_error ("%qs argument of %qs intrinsic at %L "
4890 "cannot be of type %s",
4891 gfc_current_intrinsic_arg
[0]->name
,
4892 gfc_current_intrinsic
,
4893 &a
->where
, gfc_typename (a
));
4897 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4899 gfc_error ("%qs argument of %qs intrinsic at %L "
4900 "must be of an extensible type",
4901 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4906 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4908 gfc_error ("%qs argument of %qs intrinsic at %L "
4909 "cannot be of type %s",
4910 gfc_current_intrinsic_arg
[0]->name
,
4911 gfc_current_intrinsic
,
4912 &b
->where
, gfc_typename (b
));
4916 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4918 gfc_error ("%qs argument of %qs intrinsic at %L "
4919 "must be of an extensible type",
4920 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4930 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4932 if (!type_check (x
, 0, BT_REAL
))
4935 if (!type_check (i
, 1, BT_INTEGER
))
4943 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4945 if (!type_check (x
, 0, BT_CHARACTER
))
4948 if (!type_check (y
, 1, BT_CHARACTER
))
4951 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4954 if (!kind_check (kind
, 3, BT_INTEGER
))
4956 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4957 "with KIND argument at %L",
4958 gfc_current_intrinsic
, &kind
->where
))
4961 if (!same_type_check (x
, 0, y
, 1))
4969 gfc_check_secnds (gfc_expr
*r
)
4971 if (!type_check (r
, 0, BT_REAL
))
4974 if (!kind_value_check (r
, 0, 4))
4977 if (!scalar_check (r
, 0))
4985 gfc_check_selected_char_kind (gfc_expr
*name
)
4987 if (!type_check (name
, 0, BT_CHARACTER
))
4990 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4993 if (!scalar_check (name
, 0))
5001 gfc_check_selected_int_kind (gfc_expr
*r
)
5003 if (!type_check (r
, 0, BT_INTEGER
))
5006 if (!scalar_check (r
, 0))
5014 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
5016 if (p
== NULL
&& r
== NULL
5017 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
5018 " neither %<P%> nor %<R%> argument at %L",
5019 gfc_current_intrinsic_where
))
5024 if (!type_check (p
, 0, BT_INTEGER
))
5027 if (!scalar_check (p
, 0))
5033 if (!type_check (r
, 1, BT_INTEGER
))
5036 if (!scalar_check (r
, 1))
5042 if (!type_check (radix
, 1, BT_INTEGER
))
5045 if (!scalar_check (radix
, 1))
5048 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
5049 "RADIX argument at %L", gfc_current_intrinsic
,
5059 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5061 if (!type_check (x
, 0, BT_REAL
))
5064 if (!type_check (i
, 1, BT_INTEGER
))
5072 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
5076 if (gfc_invalid_null_arg (source
))
5079 if (!kind_check (kind
, 1, BT_INTEGER
))
5081 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5082 "with KIND argument at %L",
5083 gfc_current_intrinsic
, &kind
->where
))
5086 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
5089 if (source
->ref
== NULL
)
5092 ar
= gfc_find_array_ref (source
);
5094 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
5096 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5097 "an assumed size array", &source
->where
);
5106 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
5108 if (!type_check (i
, 0, BT_INTEGER
))
5111 if (!type_check (shift
, 0, BT_INTEGER
))
5114 if (!nonnegative_check ("SHIFT", shift
))
5117 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
5125 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
5127 if (!int_or_real_check (a
, 0))
5130 if (!same_type_check (a
, 0, b
, 1))
5138 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5140 if (!array_check (array
, 0))
5143 if (!dim_check (dim
, 1, true))
5146 if (!dim_rank_check (dim
, array
, 0))
5149 if (!kind_check (kind
, 2, BT_INTEGER
))
5151 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5152 "with KIND argument at %L",
5153 gfc_current_intrinsic
, &kind
->where
))
5162 gfc_check_sizeof (gfc_expr
*arg
)
5164 if (gfc_invalid_null_arg (arg
))
5167 if (arg
->ts
.type
== BT_PROCEDURE
)
5169 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5170 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5175 if (illegal_boz_arg (arg
))
5178 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5179 if (arg
->ts
.type
== BT_ASSUMED
5180 && (arg
->symtree
->n
.sym
->as
== NULL
5181 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
5182 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
5183 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
5185 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5186 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5191 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5192 && arg
->symtree
->n
.sym
->as
!= NULL
5193 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5194 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5196 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5197 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5198 gfc_current_intrinsic
, &arg
->where
);
5206 /* Check whether an expression is interoperable. When returning false,
5207 msg is set to a string telling why the expression is not interoperable,
5208 otherwise, it is set to NULL. The msg string can be used in diagnostics.
5209 If c_loc is true, character with len > 1 are allowed (cf. Fortran
5210 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5211 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5215 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
5219 if (expr
->expr_type
== EXPR_NULL
)
5221 *msg
= "NULL() is not interoperable";
5225 if (expr
->ts
.type
== BT_BOZ
)
5227 *msg
= "BOZ literal constant";
5231 if (expr
->ts
.type
== BT_CLASS
)
5233 *msg
= "Expression is polymorphic";
5237 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
5238 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
5240 *msg
= "Expression is a noninteroperable derived type";
5244 if (expr
->ts
.type
== BT_PROCEDURE
)
5246 *msg
= "Procedure unexpected as argument";
5250 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
5253 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
5254 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
5256 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
5260 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
5261 && expr
->ts
.kind
!= 1)
5263 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
5267 if (expr
->ts
.type
== BT_CHARACTER
) {
5268 if (expr
->ts
.deferred
)
5270 /* TS 29113 allows deferred-length strings as dummy arguments,
5271 but it is not an interoperable type. */
5272 *msg
= "Expression shall not be a deferred-length string";
5276 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
5277 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
5278 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5282 && !gfc_length_one_character_type_p (&expr
->ts
))
5284 *msg
= "Type shall have a character length of 1";
5289 /* Note: The following checks are about interoperatable variables, Fortran
5290 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5291 is allowed, e.g. assumed-shape arrays with TS 29113. */
5293 if (gfc_is_coarray (expr
))
5295 *msg
= "Coarrays are not interoperable";
5299 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
5301 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
5302 if (ar
->type
!= AR_FULL
)
5304 *msg
= "Only whole-arrays are interoperable";
5307 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
5308 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
5310 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
5320 gfc_check_c_sizeof (gfc_expr
*arg
)
5324 if (!is_c_interoperable (arg
, &msg
, false, false))
5326 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5327 "interoperable data entity: %s",
5328 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5333 if (arg
->ts
.type
== BT_ASSUMED
)
5335 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5337 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5342 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5343 && arg
->symtree
->n
.sym
->as
!= NULL
5344 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5345 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5347 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5348 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5349 gfc_current_intrinsic
, &arg
->where
);
5358 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
5360 if (c_ptr_1
->ts
.type
!= BT_DERIVED
5361 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5362 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
5363 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
5365 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5366 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
5370 if (!scalar_check (c_ptr_1
, 0))
5374 && (c_ptr_2
->ts
.type
!= BT_DERIVED
5375 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5376 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
5377 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
5379 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5380 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
5381 gfc_typename (&c_ptr_1
->ts
),
5382 gfc_typename (&c_ptr_2
->ts
));
5386 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
5394 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
5396 symbol_attribute attr
;
5399 if (cptr
->ts
.type
!= BT_DERIVED
5400 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5401 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
5403 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5404 "type TYPE(C_PTR)", &cptr
->where
);
5408 if (!scalar_check (cptr
, 0))
5411 attr
= gfc_expr_attr (fptr
);
5415 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5420 if (fptr
->ts
.type
== BT_CLASS
)
5422 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5427 if (gfc_is_coindexed (fptr
))
5429 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5430 "coindexed", &fptr
->where
);
5434 if (fptr
->rank
== 0 && shape
)
5436 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5437 "FPTR", &fptr
->where
);
5440 else if (fptr
->rank
&& !shape
)
5442 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5443 "FPTR at %L", &fptr
->where
);
5447 if (shape
&& !rank_check (shape
, 2, 1))
5450 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
5456 if (gfc_array_size (shape
, &size
))
5458 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
5461 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5462 "size as the RANK of FPTR", &shape
->where
);
5469 if (fptr
->ts
.type
== BT_CLASS
)
5471 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
5475 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
5476 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable array FPTR "
5477 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
5484 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
5486 symbol_attribute attr
;
5488 if (cptr
->ts
.type
!= BT_DERIVED
5489 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5490 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
5492 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5493 "type TYPE(C_FUNPTR)", &cptr
->where
);
5497 if (!scalar_check (cptr
, 0))
5500 attr
= gfc_expr_attr (fptr
);
5502 if (!attr
.proc_pointer
)
5504 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5505 "pointer", &fptr
->where
);
5509 if (gfc_is_coindexed (fptr
))
5511 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5512 "coindexed", &fptr
->where
);
5516 if (!attr
.is_bind_c
)
5517 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5518 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
5525 gfc_check_c_funloc (gfc_expr
*x
)
5527 symbol_attribute attr
;
5529 if (gfc_is_coindexed (x
))
5531 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5532 "coindexed", &x
->where
);
5536 attr
= gfc_expr_attr (x
);
5538 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
5539 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
5540 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5541 if (x
->symtree
->n
.sym
== ns
->proc_name
)
5543 gfc_error ("Function result %qs at %L is invalid as X argument "
5544 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
5548 if (attr
.flavor
!= FL_PROCEDURE
)
5550 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5551 "or a procedure pointer", &x
->where
);
5555 if (!attr
.is_bind_c
)
5556 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5557 "at %L to C_FUNLOC", &x
->where
);
5563 gfc_check_c_loc (gfc_expr
*x
)
5565 symbol_attribute attr
;
5568 if (gfc_is_coindexed (x
))
5570 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
5574 if (x
->ts
.type
== BT_CLASS
)
5576 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5581 attr
= gfc_expr_attr (x
);
5584 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
5585 || attr
.flavor
== FL_PARAMETER
))
5587 gfc_error ("Argument X at %L to C_LOC shall have either "
5588 "the POINTER or the TARGET attribute", &x
->where
);
5592 if (x
->ts
.type
== BT_CHARACTER
5593 && gfc_var_strlen (x
) == 0)
5595 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5596 "string", &x
->where
);
5600 if (!is_c_interoperable (x
, &msg
, true, false))
5602 if (x
->ts
.type
== BT_CLASS
)
5604 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5610 && !gfc_notify_std (GFC_STD_F2018
,
5611 "Noninteroperable array at %L as"
5612 " argument to C_LOC: %s", &x
->where
, msg
))
5615 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
5617 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
5619 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
5620 && !attr
.allocatable
5621 && !gfc_notify_std (GFC_STD_F2008
,
5622 "Array of interoperable type at %L "
5623 "to C_LOC which is nonallocatable and neither "
5624 "assumed size nor explicit size", &x
->where
))
5626 else if (ar
->type
!= AR_FULL
5627 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
5628 "to C_LOC", &x
->where
))
5637 gfc_check_sleep_sub (gfc_expr
*seconds
)
5639 if (!type_check (seconds
, 0, BT_INTEGER
))
5642 if (!scalar_check (seconds
, 0))
5649 gfc_check_sngl (gfc_expr
*a
)
5651 if (!type_check (a
, 0, BT_REAL
))
5654 if ((a
->ts
.kind
!= gfc_default_double_kind
)
5655 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
5656 "REAL argument to %s intrinsic at %L",
5657 gfc_current_intrinsic
, &a
->where
))
5664 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
5666 if (gfc_invalid_null_arg (source
))
5669 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
5671 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5672 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
5673 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
5681 if (!dim_check (dim
, 1, false))
5684 /* dim_rank_check() does not apply here. */
5686 && dim
->expr_type
== EXPR_CONSTANT
5687 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
5688 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
5690 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5691 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
5692 gfc_current_intrinsic
, &dim
->where
);
5696 if (!type_check (ncopies
, 2, BT_INTEGER
))
5699 if (!scalar_check (ncopies
, 2))
5706 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5710 arg_strlen_is_zero (gfc_expr
*c
, int n
)
5712 if (gfc_var_strlen (c
) == 0)
5714 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5715 "length at least 1", gfc_current_intrinsic_arg
[n
]->name
,
5716 gfc_current_intrinsic
, &c
->where
);
5723 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
5725 if (!type_check (unit
, 0, BT_INTEGER
))
5728 if (!scalar_check (unit
, 0))
5731 if (!type_check (c
, 1, BT_CHARACTER
))
5733 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5735 if (strcmp (gfc_current_intrinsic
, "fgetc") == 0
5736 && !variable_check (c
, 1, false))
5738 if (arg_strlen_is_zero (c
, 1))
5744 if (!type_check (status
, 2, BT_INTEGER
)
5745 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5746 || !scalar_check (status
, 2)
5747 || !variable_check (status
, 2, false))
5755 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5757 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5762 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5764 if (!type_check (c
, 0, BT_CHARACTER
))
5766 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5768 if (strcmp (gfc_current_intrinsic
, "fget") == 0
5769 && !variable_check (c
, 0, false))
5771 if (arg_strlen_is_zero (c
, 0))
5777 if (!type_check (status
, 1, BT_INTEGER
)
5778 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5779 || !scalar_check (status
, 1)
5780 || !variable_check (status
, 1, false))
5788 gfc_check_fgetput (gfc_expr
*c
)
5790 return gfc_check_fgetput_sub (c
, NULL
);
5795 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5797 if (!type_check (unit
, 0, BT_INTEGER
))
5800 if (!scalar_check (unit
, 0))
5803 if (!type_check (offset
, 1, BT_INTEGER
))
5806 if (!scalar_check (offset
, 1))
5809 if (!type_check (whence
, 2, BT_INTEGER
))
5812 if (!scalar_check (whence
, 2))
5818 if (!type_check (status
, 3, BT_INTEGER
))
5821 if (!kind_value_check (status
, 3, 4))
5824 if (!scalar_check (status
, 3))
5833 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5835 if (!type_check (unit
, 0, BT_INTEGER
))
5838 if (!scalar_check (unit
, 0))
5841 if (!type_check (array
, 1, BT_INTEGER
)
5842 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5845 if (!array_check (array
, 1))
5853 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5855 if (!type_check (unit
, 0, BT_INTEGER
))
5858 if (!scalar_check (unit
, 0))
5861 if (!type_check (array
, 1, BT_INTEGER
)
5862 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5865 if (!array_check (array
, 1))
5871 if (!type_check (status
, 2, BT_INTEGER
)
5872 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5875 if (!scalar_check (status
, 2))
5883 gfc_check_ftell (gfc_expr
*unit
)
5885 if (!type_check (unit
, 0, BT_INTEGER
))
5888 if (!scalar_check (unit
, 0))
5896 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5898 if (!type_check (unit
, 0, BT_INTEGER
))
5901 if (!scalar_check (unit
, 0))
5904 if (!type_check (offset
, 1, BT_INTEGER
))
5907 if (!scalar_check (offset
, 1))
5915 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5917 if (!type_check (name
, 0, BT_CHARACTER
))
5919 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5922 if (!type_check (array
, 1, BT_INTEGER
)
5923 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5926 if (!array_check (array
, 1))
5934 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5936 if (!type_check (name
, 0, BT_CHARACTER
))
5938 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5941 if (!type_check (array
, 1, BT_INTEGER
)
5942 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5945 if (!array_check (array
, 1))
5951 if (!type_check (status
, 2, BT_INTEGER
)
5952 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5955 if (!scalar_check (status
, 2))
5963 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5967 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5969 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5973 if (!coarray_check (coarray
, 0))
5978 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5979 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5983 if (sub
->ts
.type
!= BT_INTEGER
)
5985 gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
5986 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5990 if (gfc_array_size (sub
, &nelems
))
5992 int corank
= gfc_get_corank (coarray
);
5994 if (mpz_cmp_ui (nelems
, corank
) != 0)
5996 gfc_error ("The number of array elements of the SUB argument to "
5997 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5998 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
6010 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
6012 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6014 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6020 if (!type_check (distance
, 0, BT_INTEGER
))
6023 if (!nonnegative_check ("DISTANCE", distance
))
6026 if (!scalar_check (distance
, 0))
6029 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6030 "NUM_IMAGES at %L", &distance
->where
))
6036 if (!type_check (failed
, 1, BT_LOGICAL
))
6039 if (!scalar_check (failed
, 1))
6042 if (!gfc_notify_std (GFC_STD_F2018
, "FAILED= argument to "
6043 "NUM_IMAGES at %L", &failed
->where
))
6052 gfc_check_team_number (gfc_expr
*team
)
6054 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6056 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6062 if (team
->ts
.type
!= BT_DERIVED
6063 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
6064 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
6066 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
6067 "shall be of type TEAM_TYPE", &team
->where
);
6079 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
6081 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6083 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6087 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
6090 if (dim
!= NULL
&& coarray
== NULL
)
6092 gfc_error ("DIM argument without COARRAY argument not allowed for "
6093 "THIS_IMAGE intrinsic at %L", &dim
->where
);
6097 if (distance
&& (coarray
|| dim
))
6099 gfc_error ("The DISTANCE argument may not be specified together with the "
6100 "COARRAY or DIM argument in intrinsic at %L",
6105 /* Assume that we have "this_image (distance)". */
6106 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
6110 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6119 if (!type_check (distance
, 2, BT_INTEGER
))
6122 if (!nonnegative_check ("DISTANCE", distance
))
6125 if (!scalar_check (distance
, 2))
6128 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6129 "THIS_IMAGE at %L", &distance
->where
))
6135 if (!coarray_check (coarray
, 0))
6140 if (!dim_check (dim
, 1, false))
6143 if (!dim_corank_check (dim
, coarray
))
6150 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6151 by gfc_simplify_transfer. Return false if we cannot do so. */
6154 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
6155 size_t *source_size
, size_t *result_size
,
6156 size_t *result_length_p
)
6158 size_t result_elt_size
;
6160 if (source
->expr_type
== EXPR_FUNCTION
)
6163 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
6166 /* Calculate the size of the source. */
6167 if (!gfc_target_expr_size (source
, source_size
))
6170 /* Determine the size of the element. */
6171 if (!gfc_element_size (mold
, &result_elt_size
))
6174 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6175 * a scalar with the type and type parameters of MOLD shall not have a
6176 * storage size equal to zero.
6177 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6178 * If MOLD is an array and SIZE is absent, the result is an array and of
6179 * rank one. Its size is as small as possible such that its physical
6180 * representation is not shorter than that of SOURCE.
6181 * If SIZE is present, the result is an array of rank one and size SIZE.
6183 if (result_elt_size
== 0 && *source_size
> 0
6184 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6186 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6187 "array and shall not have storage size 0 when %<SOURCE%> "
6188 "argument has size greater than 0", &mold
->where
);
6192 if (result_elt_size
== 0 && *source_size
== 0 && !size
)
6195 if (result_length_p
)
6196 *result_length_p
= 0;
6200 if ((result_elt_size
> 0 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6206 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6209 result_length
= *source_size
/ result_elt_size
;
6210 if (result_length
* result_elt_size
< *source_size
)
6214 *result_size
= result_length
* result_elt_size
;
6215 if (result_length_p
)
6216 *result_length_p
= result_length
;
6219 *result_size
= result_elt_size
;
6226 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6231 if (gfc_invalid_null_arg (source
))
6234 /* SOURCE shall be a scalar or array of any type. */
6235 if (source
->ts
.type
== BT_PROCEDURE
6236 && source
->symtree
->n
.sym
->attr
.subroutine
== 1)
6238 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6239 "must not be a %s", &source
->where
,
6240 gfc_basic_typename (source
->ts
.type
));
6244 if (source
->ts
.type
== BT_BOZ
&& illegal_boz_arg (source
))
6247 if (mold
->ts
.type
== BT_BOZ
&& illegal_boz_arg (mold
))
6250 if (gfc_invalid_null_arg (mold
))
6253 /* MOLD shall be a scalar or array of any type. */
6254 if (mold
->ts
.type
== BT_PROCEDURE
6255 && mold
->symtree
->n
.sym
->attr
.subroutine
== 1)
6257 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6258 "must not be a %s", &mold
->where
,
6259 gfc_basic_typename (mold
->ts
.type
));
6263 if (mold
->ts
.type
== BT_HOLLERITH
)
6265 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6266 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
6270 /* SIZE (optional) shall be an integer scalar. The corresponding actual
6271 argument shall not be an optional dummy argument. */
6274 if (!type_check (size
, 2, BT_INTEGER
))
6276 if (size
->ts
.type
== BT_BOZ
)
6281 if (!scalar_check (size
, 2))
6284 if (!nonoptional_check (size
, 2))
6288 if (!warn_surprising
)
6291 /* If we can't calculate the sizes, we cannot check any more.
6292 Return true for that case. */
6294 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6295 &result_size
, NULL
))
6298 if (source_size
< result_size
)
6299 gfc_warning (OPT_Wsurprising
,
6300 "Intrinsic TRANSFER at %L has partly undefined result: "
6301 "source size %ld < result size %ld", &source
->where
,
6302 (long) source_size
, (long) result_size
);
6309 gfc_check_transpose (gfc_expr
*matrix
)
6311 if (!rank_check (matrix
, 0, 2))
6319 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6321 if (!array_check (array
, 0))
6324 if (!dim_check (dim
, 1, false))
6327 if (!dim_rank_check (dim
, array
, 0))
6330 if (!kind_check (kind
, 2, BT_INTEGER
))
6332 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6333 "with KIND argument at %L",
6334 gfc_current_intrinsic
, &kind
->where
))
6342 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
6344 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6346 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6350 if (!coarray_check (coarray
, 0))
6355 if (!dim_check (dim
, 1, false))
6358 if (!dim_corank_check (dim
, coarray
))
6362 if (!kind_check (kind
, 2, BT_INTEGER
))
6370 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6374 if (!rank_check (vector
, 0, 1))
6377 if (!array_check (mask
, 1))
6380 if (!type_check (mask
, 1, BT_LOGICAL
))
6383 if (!same_type_check (vector
, 0, field
, 2))
6386 gfc_simplify_expr (mask
, 0);
6388 if (mask
->expr_type
== EXPR_ARRAY
6389 && gfc_array_size (vector
, &vector_size
))
6391 int mask_true_count
= 0;
6392 gfc_constructor
*mask_ctor
;
6393 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6396 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
6398 mask_true_count
= 0;
6402 if (mask_ctor
->expr
->value
.logical
)
6405 mask_ctor
= gfc_constructor_next (mask_ctor
);
6408 if (mpz_get_si (vector_size
) < mask_true_count
)
6410 gfc_error ("%qs argument of %qs intrinsic at %L must "
6411 "provide at least as many elements as there "
6412 "are .TRUE. values in %qs (%ld/%d)",
6413 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6414 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
6415 mpz_get_si (vector_size
), mask_true_count
);
6419 mpz_clear (vector_size
);
6422 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
6424 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6425 "the same rank as %qs or be a scalar",
6426 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6427 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
6431 if (mask
->rank
== field
->rank
)
6434 for (i
= 0; i
< field
->rank
; i
++)
6435 if (! identical_dimen_shape (mask
, i
, field
, i
))
6437 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6438 "must have identical shape.",
6439 gfc_current_intrinsic_arg
[2]->name
,
6440 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6450 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
6452 if (!type_check (x
, 0, BT_CHARACTER
))
6455 if (!same_type_check (x
, 0, y
, 1))
6458 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
6461 if (!kind_check (kind
, 3, BT_INTEGER
))
6463 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6464 "with KIND argument at %L",
6465 gfc_current_intrinsic
, &kind
->where
))
6473 gfc_check_trim (gfc_expr
*x
)
6475 if (!type_check (x
, 0, BT_CHARACTER
))
6478 if (gfc_invalid_null_arg (x
))
6481 if (!scalar_check (x
, 0))
6489 gfc_check_ttynam (gfc_expr
*unit
)
6491 if (!scalar_check (unit
, 0))
6494 if (!type_check (unit
, 0, BT_INTEGER
))
6501 /************* Check functions for intrinsic subroutines *************/
6504 gfc_check_cpu_time (gfc_expr
*time
)
6506 if (!scalar_check (time
, 0))
6509 if (!type_check (time
, 0, BT_REAL
))
6512 if (!variable_check (time
, 0, false))
6520 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
6521 gfc_expr
*zone
, gfc_expr
*values
)
6525 if (!type_check (date
, 0, BT_CHARACTER
))
6527 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6529 if (!scalar_check (date
, 0))
6531 if (!variable_check (date
, 0, false))
6537 if (!type_check (time
, 1, BT_CHARACTER
))
6539 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
6541 if (!scalar_check (time
, 1))
6543 if (!variable_check (time
, 1, false))
6549 if (!type_check (zone
, 2, BT_CHARACTER
))
6551 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
6553 if (!scalar_check (zone
, 2))
6555 if (!variable_check (zone
, 2, false))
6561 if (!type_check (values
, 3, BT_INTEGER
))
6563 if (!array_check (values
, 3))
6565 if (!rank_check (values
, 3, 1))
6567 if (!variable_check (values
, 3, false))
6569 if (!array_size_check (values
, 3, 8))
6572 if (values
->ts
.kind
!= gfc_default_integer_kind
6573 && !gfc_notify_std (GFC_STD_F2018
, "VALUES argument of "
6574 "DATE_AND_TIME at %L has non-default kind",
6578 /* F2018:16.9.59 DATE_AND_TIME
6579 "VALUES shall be a rank-one array of type integer
6580 with a decimal exponent range of at least four."
6581 This is a hard limit also required by the implementation in
6583 if (values
->ts
.kind
< 2)
6585 gfc_error ("VALUES argument of DATE_AND_TIME at %L must have "
6586 "a decimal exponent range of at least four",
6597 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
6598 gfc_expr
*to
, gfc_expr
*topos
)
6600 if (!type_check (from
, 0, BT_INTEGER
))
6603 if (!type_check (frompos
, 1, BT_INTEGER
))
6606 if (!type_check (len
, 2, BT_INTEGER
))
6609 if (!same_type_check (from
, 0, to
, 3))
6612 if (!variable_check (to
, 3, false))
6615 if (!type_check (topos
, 4, BT_INTEGER
))
6618 if (!nonnegative_check ("frompos", frompos
))
6621 if (!nonnegative_check ("topos", topos
))
6624 if (!nonnegative_check ("len", len
))
6627 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
6630 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
6637 /* Check the arguments for RANDOM_INIT. */
6640 gfc_check_random_init (gfc_expr
*repeatable
, gfc_expr
*image_distinct
)
6642 if (!type_check (repeatable
, 0, BT_LOGICAL
))
6645 if (!scalar_check (repeatable
, 0))
6648 if (!type_check (image_distinct
, 1, BT_LOGICAL
))
6651 if (!scalar_check (image_distinct
, 1))
6659 gfc_check_random_number (gfc_expr
*harvest
)
6661 if (!type_check (harvest
, 0, BT_REAL
))
6664 if (!variable_check (harvest
, 0, false))
6672 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
6674 unsigned int nargs
= 0, seed_size
;
6675 locus
*where
= NULL
;
6676 mpz_t put_size
, get_size
;
6678 /* Keep the number of bytes in sync with master_state in
6679 libgfortran/intrinsics/random.c. */
6680 seed_size
= 32 / gfc_default_integer_kind
;
6684 if (size
->expr_type
!= EXPR_VARIABLE
6685 || !size
->symtree
->n
.sym
->attr
.optional
)
6688 if (!scalar_check (size
, 0))
6691 if (!type_check (size
, 0, BT_INTEGER
))
6694 if (!variable_check (size
, 0, false))
6697 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
6703 if (put
->expr_type
!= EXPR_VARIABLE
6704 || !put
->symtree
->n
.sym
->attr
.optional
)
6707 where
= &put
->where
;
6710 if (!array_check (put
, 1))
6713 if (!rank_check (put
, 1, 1))
6716 if (!type_check (put
, 1, BT_INTEGER
))
6719 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
6722 if (gfc_array_size (put
, &put_size
)
6723 && mpz_get_ui (put_size
) < seed_size
)
6724 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6725 "too small (%i/%i)",
6726 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6727 &put
->where
, (int) mpz_get_ui (put_size
), seed_size
);
6732 if (get
->expr_type
!= EXPR_VARIABLE
6733 || !get
->symtree
->n
.sym
->attr
.optional
)
6736 where
= &get
->where
;
6739 if (!array_check (get
, 2))
6742 if (!rank_check (get
, 2, 1))
6745 if (!type_check (get
, 2, BT_INTEGER
))
6748 if (!variable_check (get
, 2, false))
6751 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
6754 if (gfc_array_size (get
, &get_size
)
6755 && mpz_get_ui (get_size
) < seed_size
)
6756 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6757 "too small (%i/%i)",
6758 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6759 &get
->where
, (int) mpz_get_ui (get_size
), seed_size
);
6762 /* RANDOM_SEED may not have more than one non-optional argument. */
6764 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
6770 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
6774 int num_percent
, nargs
;
6777 if (e
->expr_type
!= EXPR_CONSTANT
)
6780 len
= e
->value
.character
.length
;
6781 if (e
->value
.character
.string
[len
-1] != '\0')
6782 gfc_internal_error ("fe_runtime_error string must be null terminated");
6785 for (i
=0; i
<len
-1; i
++)
6786 if (e
->value
.character
.string
[i
] == '%')
6790 for (; a
; a
= a
->next
)
6793 if (nargs
-1 != num_percent
)
6794 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6795 nargs
, num_percent
++);
6801 gfc_check_second_sub (gfc_expr
*time
)
6803 if (!scalar_check (time
, 0))
6806 if (!type_check (time
, 0, BT_REAL
))
6809 if (!kind_value_check (time
, 0, 4))
6816 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6817 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6818 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6819 count_max are all optional arguments */
6822 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
6823 gfc_expr
*count_max
)
6825 int first_int_kind
= -1;
6829 if (!scalar_check (count
, 0))
6832 if (!type_check (count
, 0, BT_INTEGER
))
6835 if (count
->ts
.kind
!= gfc_default_integer_kind
6836 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
6837 "SYSTEM_CLOCK at %L has non-default kind",
6841 if (count
->ts
.kind
< gfc_default_integer_kind
6842 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6843 "COUNT argument to SYSTEM_CLOCK at %L "
6844 "with kind smaller than default integer",
6848 if (!variable_check (count
, 0, false))
6851 first_int_kind
= count
->ts
.kind
;
6854 if (count_rate
!= NULL
)
6856 if (!scalar_check (count_rate
, 1))
6859 if (!variable_check (count_rate
, 1, false))
6862 if (count_rate
->ts
.type
== BT_REAL
)
6864 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
6865 "SYSTEM_CLOCK at %L", &count_rate
->where
))
6870 if (!type_check (count_rate
, 1, BT_INTEGER
))
6873 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6874 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6875 "SYSTEM_CLOCK at %L has non-default kind",
6876 &count_rate
->where
))
6879 if (count_rate
->ts
.kind
< gfc_default_integer_kind
6880 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6881 "COUNT_RATE argument to SYSTEM_CLOCK at %L "
6882 "with kind smaller than default integer",
6883 &count_rate
->where
))
6886 if (first_int_kind
< 0)
6887 first_int_kind
= count_rate
->ts
.kind
;
6892 if (count_max
!= NULL
)
6894 if (!scalar_check (count_max
, 2))
6897 if (!type_check (count_max
, 2, BT_INTEGER
))
6900 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6901 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6902 "SYSTEM_CLOCK at %L has non-default kind",
6906 if (!variable_check (count_max
, 2, false))
6909 if (count_max
->ts
.kind
< gfc_default_integer_kind
6910 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6911 "COUNT_MAX argument to SYSTEM_CLOCK at %L "
6912 "with kind smaller than default integer",
6916 if (first_int_kind
< 0)
6917 first_int_kind
= count_max
->ts
.kind
;
6920 if (first_int_kind
> 0)
6923 && count_rate
->ts
.type
== BT_INTEGER
6924 && count_rate
->ts
.kind
!= first_int_kind
6925 && !gfc_notify_std (GFC_STD_F2023_DEL
,
6926 "integer arguments to SYSTEM_CLOCK at %L "
6927 "with different kind parameters",
6928 &count_rate
->where
))
6931 if (count_max
&& count_max
->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",
6944 gfc_check_irand (gfc_expr
*x
)
6949 if (!scalar_check (x
, 0))
6952 if (!type_check (x
, 0, BT_INTEGER
))
6955 if (!kind_value_check (x
, 0, 4))
6963 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6965 if (!scalar_check (seconds
, 0))
6967 if (!type_check (seconds
, 0, BT_INTEGER
))
6970 if (!int_or_proc_check (handler
, 1))
6972 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6978 if (!scalar_check (status
, 2))
6980 if (!type_check (status
, 2, BT_INTEGER
))
6982 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6990 gfc_check_rand (gfc_expr
*x
)
6995 if (!scalar_check (x
, 0))
6998 if (!type_check (x
, 0, BT_INTEGER
))
7001 if (!kind_value_check (x
, 0, 4))
7009 gfc_check_srand (gfc_expr
*x
)
7011 if (!scalar_check (x
, 0))
7014 if (!type_check (x
, 0, BT_INTEGER
))
7017 if (!kind_value_check (x
, 0, 4))
7025 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
7027 if (!scalar_check (time
, 0))
7029 if (!type_check (time
, 0, BT_INTEGER
))
7032 if (!type_check (result
, 1, BT_CHARACTER
))
7034 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
7042 gfc_check_dtime_etime (gfc_expr
*x
)
7044 if (!array_check (x
, 0))
7047 if (!rank_check (x
, 0, 1))
7050 if (!variable_check (x
, 0, false))
7053 if (!type_check (x
, 0, BT_REAL
))
7056 if (!kind_value_check (x
, 0, 4))
7064 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
7066 if (!array_check (values
, 0))
7069 if (!rank_check (values
, 0, 1))
7072 if (!variable_check (values
, 0, false))
7075 if (!type_check (values
, 0, BT_REAL
))
7078 if (!kind_value_check (values
, 0, 4))
7081 if (!scalar_check (time
, 1))
7084 if (!type_check (time
, 1, BT_REAL
))
7087 if (!kind_value_check (time
, 1, 4))
7095 gfc_check_fdate_sub (gfc_expr
*date
)
7097 if (!type_check (date
, 0, BT_CHARACTER
))
7099 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
7107 gfc_check_gerror (gfc_expr
*msg
)
7109 if (!type_check (msg
, 0, BT_CHARACTER
))
7111 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7119 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
7121 if (!type_check (cwd
, 0, BT_CHARACTER
))
7123 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
7129 if (!scalar_check (status
, 1))
7132 if (!type_check (status
, 1, BT_INTEGER
))
7140 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
7142 if (!type_check (pos
, 0, BT_INTEGER
))
7145 if (pos
->ts
.kind
> gfc_default_integer_kind
)
7147 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
7148 "not wider than the default kind (%d)",
7149 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7150 &pos
->where
, gfc_default_integer_kind
);
7154 if (!type_check (value
, 1, BT_CHARACTER
))
7156 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
7164 gfc_check_getlog (gfc_expr
*msg
)
7166 if (!type_check (msg
, 0, BT_CHARACTER
))
7168 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7176 gfc_check_exit (gfc_expr
*status
)
7181 if (!type_check (status
, 0, BT_INTEGER
))
7184 if (!scalar_check (status
, 0))
7192 gfc_check_flush (gfc_expr
*unit
)
7197 if (!type_check (unit
, 0, BT_INTEGER
))
7200 if (!scalar_check (unit
, 0))
7208 gfc_check_free (gfc_expr
*i
)
7210 if (!type_check (i
, 0, BT_INTEGER
))
7213 if (!scalar_check (i
, 0))
7221 gfc_check_hostnm (gfc_expr
*name
)
7223 if (!type_check (name
, 0, BT_CHARACTER
))
7225 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7233 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
7235 if (!type_check (name
, 0, BT_CHARACTER
))
7237 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7243 if (!scalar_check (status
, 1))
7246 if (!type_check (status
, 1, BT_INTEGER
))
7254 gfc_check_itime_idate (gfc_expr
*values
)
7256 if (!array_check (values
, 0))
7259 if (!rank_check (values
, 0, 1))
7262 if (!variable_check (values
, 0, false))
7265 if (!type_check (values
, 0, BT_INTEGER
))
7268 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
7276 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
7278 if (!type_check (time
, 0, BT_INTEGER
))
7281 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
7284 if (!scalar_check (time
, 0))
7287 if (!array_check (values
, 1))
7290 if (!rank_check (values
, 1, 1))
7293 if (!variable_check (values
, 1, false))
7296 if (!type_check (values
, 1, BT_INTEGER
))
7299 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
7307 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
7309 if (!scalar_check (unit
, 0))
7312 if (!type_check (unit
, 0, BT_INTEGER
))
7315 if (!type_check (name
, 1, BT_CHARACTER
))
7317 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
7325 gfc_check_is_contiguous (gfc_expr
*array
)
7327 if (array
->expr_type
== EXPR_NULL
)
7329 gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7330 "associated pointer", &array
->where
, gfc_current_intrinsic
);
7334 if (!array_check (array
, 0))
7342 gfc_check_isatty (gfc_expr
*unit
)
7347 if (!type_check (unit
, 0, BT_INTEGER
))
7350 if (!scalar_check (unit
, 0))
7358 gfc_check_isnan (gfc_expr
*x
)
7360 if (!type_check (x
, 0, BT_REAL
))
7368 gfc_check_perror (gfc_expr
*string
)
7370 if (!type_check (string
, 0, BT_CHARACTER
))
7372 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
7380 gfc_check_umask (gfc_expr
*mask
)
7382 if (!type_check (mask
, 0, BT_INTEGER
))
7385 if (!scalar_check (mask
, 0))
7393 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
7395 if (!type_check (mask
, 0, BT_INTEGER
))
7398 if (!scalar_check (mask
, 0))
7404 if (!scalar_check (old
, 1))
7407 if (!type_check (old
, 1, BT_INTEGER
))
7415 gfc_check_unlink (gfc_expr
*name
)
7417 if (!type_check (name
, 0, BT_CHARACTER
))
7419 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7427 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
7429 if (!type_check (name
, 0, BT_CHARACTER
))
7431 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7437 if (!scalar_check (status
, 1))
7440 if (!type_check (status
, 1, BT_INTEGER
))
7448 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
7450 if (!scalar_check (number
, 0))
7452 if (!type_check (number
, 0, BT_INTEGER
))
7455 if (!int_or_proc_check (handler
, 1))
7457 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7465 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
7467 if (!scalar_check (number
, 0))
7469 if (!type_check (number
, 0, BT_INTEGER
))
7472 if (!int_or_proc_check (handler
, 1))
7474 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7480 if (!type_check (status
, 2, BT_INTEGER
))
7482 if (!scalar_check (status
, 2))
7490 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
7492 if (!type_check (cmd
, 0, BT_CHARACTER
))
7494 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
7497 if (!scalar_check (status
, 1))
7500 if (!type_check (status
, 1, BT_INTEGER
))
7503 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
7510 /* This is used for the GNU intrinsics AND, OR and XOR. */
7512 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
7514 if (i
->ts
.type
!= BT_INTEGER
7515 && i
->ts
.type
!= BT_LOGICAL
7516 && i
->ts
.type
!= BT_BOZ
)
7518 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7519 "LOGICAL, or a BOZ literal constant",
7520 gfc_current_intrinsic_arg
[0]->name
,
7521 gfc_current_intrinsic
, &i
->where
);
7525 if (j
->ts
.type
!= BT_INTEGER
7526 && j
->ts
.type
!= BT_LOGICAL
7527 && j
->ts
.type
!= BT_BOZ
)
7529 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7530 "LOGICAL, or a BOZ literal constant",
7531 gfc_current_intrinsic_arg
[1]->name
,
7532 gfc_current_intrinsic
, &j
->where
);
7536 /* i and j cannot both be BOZ literal constants. */
7537 if (!boz_args_check (i
, j
))
7540 /* If i is BOZ and j is integer, convert i to type of j. */
7541 if (i
->ts
.type
== BT_BOZ
)
7543 if (j
->ts
.type
!= BT_INTEGER
)
7545 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7546 gfc_current_intrinsic_arg
[1]->name
,
7547 gfc_current_intrinsic
, &j
->where
);
7551 if (!gfc_boz2int (i
, j
->ts
.kind
))
7555 /* If j is BOZ and i is integer, convert j to type of i. */
7556 if (j
->ts
.type
== BT_BOZ
)
7558 if (i
->ts
.type
!= BT_INTEGER
)
7560 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7561 gfc_current_intrinsic_arg
[0]->name
,
7562 gfc_current_intrinsic
, &j
->where
);
7566 if (!gfc_boz2int (j
, i
->ts
.kind
))
7570 if (!same_type_check (i
, 0, j
, 1, false))
7573 if (!scalar_check (i
, 0))
7576 if (!scalar_check (j
, 1))
7584 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
7587 if (a
->expr_type
== EXPR_NULL
)
7589 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7590 "argument to STORAGE_SIZE, because it returns a "
7591 "disassociated pointer", &a
->where
);
7595 if (a
->ts
.type
== BT_ASSUMED
)
7597 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7598 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7603 if (a
->ts
.type
== BT_PROCEDURE
)
7605 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7606 "procedure", gfc_current_intrinsic_arg
[0]->name
,
7607 gfc_current_intrinsic
, &a
->where
);
7611 if (a
->ts
.type
== BT_BOZ
&& illegal_boz_arg (a
))
7617 if (!type_check (kind
, 1, BT_INTEGER
))
7620 if (!scalar_check (kind
, 1))
7623 if (kind
->expr_type
!= EXPR_CONSTANT
)
7625 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7626 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,