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 precedures 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
);
1255 /***** Check functions *****/
1257 /* Check subroutine suitable for intrinsics taking a real argument and
1258 a kind argument for the result. */
1261 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
1263 if (!type_check (a
, 0, BT_REAL
))
1265 if (!kind_check (kind
, 1, type
))
1272 /* Check subroutine suitable for ceiling, floor and nint. */
1275 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
1277 return check_a_kind (a
, kind
, BT_INTEGER
);
1281 /* Check subroutine suitable for aint, anint. */
1284 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
1286 return check_a_kind (a
, kind
, BT_REAL
);
1291 gfc_check_abs (gfc_expr
*a
)
1293 if (!numeric_check (a
, 0))
1301 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
1303 if (a
->ts
.type
== BT_BOZ
)
1305 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1306 "ACHAR intrinsic subprogram"), &a
->where
))
1309 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
1313 if (!type_check (a
, 0, BT_INTEGER
))
1316 if (!kind_check (kind
, 1, BT_CHARACTER
))
1324 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
1326 if (!type_check (name
, 0, BT_CHARACTER
)
1327 || !scalar_check (name
, 0))
1329 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1332 if (!type_check (mode
, 1, BT_CHARACTER
)
1333 || !scalar_check (mode
, 1))
1335 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1343 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
1345 if (!logical_array_check (mask
, 0))
1348 if (!dim_check (dim
, 1, false))
1351 if (!dim_rank_check (dim
, mask
, 0))
1358 /* Limited checking for ALLOCATED intrinsic. Additional checking
1359 is performed in intrinsic.cc(sort_actual), because ALLOCATED
1360 has two mutually exclusive non-optional arguments. */
1363 gfc_check_allocated (gfc_expr
*array
)
1365 /* Tests on allocated components of coarrays need to detour the check to
1366 argument of the _caf_get. */
1367 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
1368 && array
->value
.function
.isym
1369 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1371 array
= array
->value
.function
.actual
->expr
;
1376 if (!variable_check (array
, 0, false))
1378 if (!allocatable_check (array
, 0))
1385 /* Common check function where the first argument must be real or
1386 integer and the second argument must be the same as the first. */
1389 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
1391 if (!int_or_real_check (a
, 0))
1394 if (a
->ts
.type
!= p
->ts
.type
)
1396 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
1397 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
1398 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1403 if (a
->ts
.kind
!= p
->ts
.kind
)
1405 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1415 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
1417 if (!double_check (x
, 0) || !double_check (y
, 1))
1424 gfc_invalid_null_arg (gfc_expr
*x
)
1426 if (x
->expr_type
== EXPR_NULL
)
1428 gfc_error ("NULL at %L is not permitted as actual argument "
1429 "to %qs intrinsic function", &x
->where
,
1430 gfc_current_intrinsic
);
1437 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
1439 symbol_attribute attr1
, attr2
;
1443 if (gfc_invalid_null_arg (pointer
))
1446 attr1
= gfc_expr_attr (pointer
);
1448 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
1450 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
1451 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1457 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
1459 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1460 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
1461 gfc_current_intrinsic
, &pointer
->where
);
1465 /* Target argument is optional. */
1469 if (gfc_invalid_null_arg (target
))
1472 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
1473 attr2
= gfc_expr_attr (target
);
1476 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1477 "or target VARIABLE or FUNCTION",
1478 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1483 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
1485 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1486 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
1487 gfc_current_intrinsic
, &target
->where
);
1492 if (attr1
.pointer
&& gfc_is_coindexed (target
))
1494 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1495 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1496 gfc_current_intrinsic
, &target
->where
);
1501 if (!same_type_check (pointer
, 0, target
, 1, true))
1503 /* F2018 C838 explicitly allows an assumed-rank variable as the first
1504 argument of intrinsic inquiry functions. */
1505 if (pointer
->rank
!= -1 && !rank_check (target
, 0, pointer
->rank
))
1507 if (target
->rank
> 0 && target
->ref
)
1509 for (i
= 0; i
< target
->rank
; i
++)
1510 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1512 gfc_error ("Array section with a vector subscript at %L shall not "
1513 "be the target of a pointer",
1524 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1526 /* gfc_notify_std would be a waste of time as the return value
1527 is seemingly used only for the generic resolution. The error
1528 will be: Too many arguments. */
1529 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1532 return gfc_check_atan2 (y
, x
);
1537 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1539 if (!type_check (y
, 0, BT_REAL
))
1541 if (!same_type_check (y
, 0, x
, 1))
1549 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1550 gfc_expr
*stat
, int stat_no
)
1552 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1555 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1556 && !(atom
->ts
.type
== BT_LOGICAL
1557 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1559 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1560 "integer of ATOMIC_INT_KIND or a logical of "
1561 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1565 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1567 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1568 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1572 if (atom
->ts
.type
!= value
->ts
.type
)
1574 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1575 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1576 gfc_current_intrinsic
, &value
->where
,
1577 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1583 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1585 if (!scalar_check (stat
, stat_no
))
1587 if (!variable_check (stat
, stat_no
, false))
1589 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1592 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1593 gfc_current_intrinsic
, &stat
->where
))
1602 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1604 if (atom
->expr_type
== EXPR_FUNCTION
1605 && atom
->value
.function
.isym
1606 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1607 atom
= atom
->value
.function
.actual
->expr
;
1609 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1611 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1612 "definable", gfc_current_intrinsic
, &atom
->where
);
1616 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1621 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1623 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1625 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1626 "integer of ATOMIC_INT_KIND", &atom
->where
,
1627 gfc_current_intrinsic
);
1631 return gfc_check_atomic_def (atom
, value
, stat
);
1636 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1638 if (atom
->expr_type
== EXPR_FUNCTION
1639 && atom
->value
.function
.isym
1640 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1641 atom
= atom
->value
.function
.actual
->expr
;
1643 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1645 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1646 "definable", gfc_current_intrinsic
, &value
->where
);
1650 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1655 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1657 /* IMAGE has to be a positive, scalar integer. */
1658 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1659 || !positive_check (0, image
))
1664 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1665 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1674 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1678 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1679 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1688 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1689 || !positive_check (1, kind
))
1692 /* Get the kind, reporting error on non-constant or overflow. */
1693 gfc_current_locus
= kind
->where
;
1694 if (gfc_extract_int (kind
, &k
, 1))
1696 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1698 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1699 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1700 gfc_current_intrinsic
, &kind
->where
);
1709 gfc_check_get_team (gfc_expr
*level
)
1713 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1714 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1723 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1724 gfc_expr
*new_val
, gfc_expr
*stat
)
1726 if (atom
->expr_type
== EXPR_FUNCTION
1727 && atom
->value
.function
.isym
1728 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1729 atom
= atom
->value
.function
.actual
->expr
;
1731 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1734 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1737 if (!same_type_check (atom
, 0, old
, 1))
1740 if (!same_type_check (atom
, 0, compare
, 2))
1743 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1745 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1746 "definable", gfc_current_intrinsic
, &atom
->where
);
1750 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1752 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1753 "definable", gfc_current_intrinsic
, &old
->where
);
1761 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1763 if (event
->ts
.type
!= BT_DERIVED
1764 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1765 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1767 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1768 "shall be of type EVENT_TYPE", &event
->where
);
1772 if (!scalar_check (event
, 0))
1775 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1777 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1778 "shall be definable", &count
->where
);
1782 if (!type_check (count
, 1, BT_INTEGER
))
1785 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1786 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1788 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1790 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1791 "shall have at least the range of the default integer",
1798 if (!type_check (stat
, 2, BT_INTEGER
))
1800 if (!scalar_check (stat
, 2))
1802 if (!variable_check (stat
, 2, false))
1805 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1806 gfc_current_intrinsic
, &stat
->where
))
1815 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1818 if (atom
->expr_type
== EXPR_FUNCTION
1819 && atom
->value
.function
.isym
1820 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1821 atom
= atom
->value
.function
.actual
->expr
;
1823 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1825 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1826 "integer of ATOMIC_INT_KIND", &atom
->where
,
1827 gfc_current_intrinsic
);
1831 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1834 if (!scalar_check (old
, 2))
1837 if (!same_type_check (atom
, 0, old
, 2))
1840 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1842 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1843 "definable", gfc_current_intrinsic
, &atom
->where
);
1847 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1849 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1850 "definable", gfc_current_intrinsic
, &old
->where
);
1858 /* BESJN and BESYN functions. */
1861 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1863 if (!type_check (n
, 0, BT_INTEGER
))
1865 if (n
->expr_type
== EXPR_CONSTANT
)
1868 gfc_extract_int (n
, &i
);
1869 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1870 "N at %L", &n
->where
))
1874 if (!type_check (x
, 1, BT_REAL
))
1881 /* Transformational version of the Bessel JN and YN functions. */
1884 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1886 if (!type_check (n1
, 0, BT_INTEGER
))
1888 if (!scalar_check (n1
, 0))
1890 if (!nonnegative_check ("N1", n1
))
1893 if (!type_check (n2
, 1, BT_INTEGER
))
1895 if (!scalar_check (n2
, 1))
1897 if (!nonnegative_check ("N2", n2
))
1900 if (!type_check (x
, 2, BT_REAL
))
1902 if (!scalar_check (x
, 2))
1910 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1912 extern int gfc_max_integer_kind
;
1914 /* If i and j are both BOZ, convert to widest INTEGER. */
1915 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_BOZ
)
1917 if (!gfc_boz2int (i
, gfc_max_integer_kind
))
1919 if (!gfc_boz2int (j
, gfc_max_integer_kind
))
1923 /* If i is BOZ and j is integer, convert i to type of j. */
1924 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
1925 && !gfc_boz2int (i
, j
->ts
.kind
))
1928 /* If j is BOZ and i is integer, convert j to type of i. */
1929 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
1930 && !gfc_boz2int (j
, i
->ts
.kind
))
1933 if (!type_check (i
, 0, BT_INTEGER
))
1936 if (!type_check (j
, 1, BT_INTEGER
))
1944 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1946 if (!type_check (i
, 0, BT_INTEGER
))
1949 if (!type_check (pos
, 1, BT_INTEGER
))
1952 if (!nonnegative_check ("pos", pos
))
1955 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1963 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1965 if (i
->ts
.type
== BT_BOZ
)
1967 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1968 "CHAR intrinsic subprogram"), &i
->where
))
1971 if (!gfc_boz2int (i
, gfc_default_integer_kind
))
1975 if (!type_check (i
, 0, BT_INTEGER
))
1978 if (!kind_check (kind
, 1, BT_CHARACTER
))
1986 gfc_check_chdir (gfc_expr
*dir
)
1988 if (!type_check (dir
, 0, BT_CHARACTER
))
1990 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
1998 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
2000 if (!type_check (dir
, 0, BT_CHARACTER
))
2002 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
2008 if (!type_check (status
, 1, BT_INTEGER
))
2010 if (!scalar_check (status
, 1))
2018 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
2020 if (!type_check (name
, 0, BT_CHARACTER
))
2022 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2025 if (!type_check (mode
, 1, BT_CHARACTER
))
2027 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2035 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
2037 if (!type_check (name
, 0, BT_CHARACTER
))
2039 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2042 if (!type_check (mode
, 1, BT_CHARACTER
))
2044 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2050 if (!type_check (status
, 2, BT_INTEGER
))
2053 if (!scalar_check (status
, 2))
2061 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
2065 /* Check kind first, because it may be needed in conversion of a BOZ. */
2068 if (!kind_check (kind
, 2, BT_COMPLEX
))
2070 gfc_extract_int (kind
, &k
);
2073 k
= gfc_default_complex_kind
;
2075 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, k
))
2078 if (!numeric_check (x
, 0))
2083 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, k
))
2086 if (!numeric_check (y
, 1))
2089 if (x
->ts
.type
== BT_COMPLEX
)
2091 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2092 "present if %<x%> is COMPLEX",
2093 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2098 if (y
->ts
.type
== BT_COMPLEX
)
2100 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2101 "of either REAL or INTEGER",
2102 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2108 if (!kind
&& warn_conversion
2109 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
2110 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2111 "COMPLEX(%d) at %L might lose precision, consider using "
2112 "the KIND argument", gfc_typename (&x
->ts
),
2113 gfc_default_real_kind
, &x
->where
);
2114 else if (y
&& !kind
&& warn_conversion
2115 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
2116 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2117 "COMPLEX(%d) at %L might lose precision, consider using "
2118 "the KIND argument", gfc_typename (&y
->ts
),
2119 gfc_default_real_kind
, &y
->where
);
2125 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
2126 gfc_expr
*errmsg
, bool co_reduce
)
2128 if (!variable_check (a
, 0, false))
2131 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
2135 /* Fortran 2008, 12.5.2.4, paragraph 18. */
2136 if (gfc_has_vector_subscript (a
))
2138 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
2139 "subroutine %s shall not have a vector subscript",
2140 &a
->where
, gfc_current_intrinsic
);
2144 if (gfc_is_coindexed (a
))
2146 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
2147 "coindexed", &a
->where
, gfc_current_intrinsic
);
2151 if (image_idx
!= NULL
)
2153 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
2155 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
2161 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
2163 if (!scalar_check (stat
, co_reduce
? 3 : 2))
2165 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
2167 if (stat
->ts
.kind
!= 4)
2169 gfc_error ("The stat= argument at %L must be a kind=4 integer "
2170 "variable", &stat
->where
);
2177 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
2179 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
2181 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
2183 if (errmsg
->ts
.kind
!= 1)
2185 gfc_error ("The errmsg= argument at %L must be a default-kind "
2186 "character variable", &errmsg
->where
);
2191 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2193 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
2203 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
2206 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
2208 gfc_error ("Support for the A argument at %L which is polymorphic A "
2209 "argument or has allocatable components is not yet "
2210 "implemented", &a
->where
);
2213 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
2218 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
2219 gfc_expr
*stat
, gfc_expr
*errmsg
)
2221 symbol_attribute attr
;
2222 gfc_formal_arglist
*formal
;
2225 if (a
->ts
.type
== BT_CLASS
)
2227 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
2232 if (gfc_expr_attr (a
).alloc_comp
)
2234 gfc_error ("Support for the A argument at %L with allocatable components"
2235 " is not yet implemented", &a
->where
);
2239 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
2242 if (!gfc_resolve_expr (op
))
2245 attr
= gfc_expr_attr (op
);
2246 if (!attr
.pure
|| !attr
.function
)
2248 gfc_error ("OPERATION argument at %L must be a PURE function",
2255 /* None of the intrinsics fulfills the criteria of taking two arguments,
2256 returning the same type and kind as the arguments and being permitted
2257 as actual argument. */
2258 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
2259 op
->symtree
->n
.sym
->name
, &op
->where
);
2263 if (gfc_is_proc_ptr_comp (op
))
2265 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
2266 sym
= comp
->ts
.interface
;
2269 sym
= op
->symtree
->n
.sym
;
2271 formal
= sym
->formal
;
2273 if (!formal
|| !formal
->next
|| formal
->next
->next
)
2275 gfc_error ("The function passed as OPERATION at %L shall have two "
2276 "arguments", &op
->where
);
2280 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
2281 gfc_set_default_type (sym
->result
, 0, NULL
);
2283 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
2285 gfc_error ("The A argument at %L has type %s but the function passed as "
2286 "OPERATION at %L returns %s",
2287 &a
->where
, gfc_typename (a
), &op
->where
,
2288 gfc_typename (&sym
->result
->ts
));
2291 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
2292 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
2294 gfc_error ("The function passed as OPERATION at %L has arguments of type "
2295 "%s and %s but shall have type %s", &op
->where
,
2296 gfc_typename (&formal
->sym
->ts
),
2297 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (a
));
2300 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
2301 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
2302 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
2303 || formal
->next
->sym
->attr
.pointer
)
2305 gfc_error ("The function passed as OPERATION at %L shall have scalar "
2306 "nonallocatable nonpointer arguments and return a "
2307 "nonallocatable nonpointer scalar", &op
->where
);
2311 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
2313 gfc_error ("The function passed as OPERATION at %L shall have the VALUE "
2314 "attribute either for none or both arguments", &op
->where
);
2318 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
2320 gfc_error ("The function passed as OPERATION at %L shall have the TARGET "
2321 "attribute either for none or both arguments", &op
->where
);
2325 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
2327 gfc_error ("The function passed as OPERATION at %L shall have the "
2328 "ASYNCHRONOUS attribute either for none or both arguments",
2333 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
2335 gfc_error ("The function passed as OPERATION at %L shall not have the "
2336 "OPTIONAL attribute for either of the arguments", &op
->where
);
2340 if (a
->ts
.type
== BT_CHARACTER
)
2343 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
2346 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2347 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2349 cl
= formal
->sym
->ts
.u
.cl
;
2350 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2351 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2353 cl
= formal
->next
->sym
->ts
.u
.cl
;
2354 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2355 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2358 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2359 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2362 && ((formal_size1
&& actual_size
!= formal_size1
)
2363 || (formal_size2
&& actual_size
!= formal_size2
)))
2365 gfc_error ("The character length of the A argument at %L and of the "
2366 "arguments of the OPERATION at %L shall be the same",
2367 &a
->where
, &op
->where
);
2370 if (actual_size
&& result_size
&& actual_size
!= result_size
)
2372 gfc_error ("The character length of the A argument at %L and of the "
2373 "function result of the OPERATION at %L shall be the same",
2374 &a
->where
, &op
->where
);
2384 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2387 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
2388 && a
->ts
.type
!= BT_CHARACTER
)
2390 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
2391 "integer, real or character",
2392 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2396 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2401 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2404 if (!numeric_check (a
, 0))
2406 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2411 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
2413 if (!boz_args_check (x
, y
))
2416 if (x
->ts
.type
== BT_BOZ
)
2418 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2419 " intrinsic subprogram"), &x
->where
))
2424 if (y
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (x
, y
->ts
.kind
))
2426 if (y
->ts
.type
== BT_REAL
&& !gfc_boz2real (x
, y
->ts
.kind
))
2430 if (y
->ts
.type
== BT_BOZ
)
2432 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2433 " intrinsic subprogram"), &y
->where
))
2438 if (x
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (y
, x
->ts
.kind
))
2440 if (x
->ts
.type
== BT_REAL
&& !gfc_boz2real (y
, x
->ts
.kind
))
2444 if (!int_or_real_check (x
, 0))
2446 if (!scalar_check (x
, 0))
2449 if (!int_or_real_check (y
, 1))
2451 if (!scalar_check (y
, 1))
2459 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
2461 if (!logical_array_check (mask
, 0))
2463 if (!dim_check (dim
, 1, false))
2465 if (!dim_rank_check (dim
, mask
, 0))
2467 if (!kind_check (kind
, 2, BT_INTEGER
))
2469 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2470 "with KIND argument at %L",
2471 gfc_current_intrinsic
, &kind
->where
))
2479 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2481 if (!array_check (array
, 0))
2484 if (!type_check (shift
, 1, BT_INTEGER
))
2487 if (!dim_check (dim
, 2, true))
2490 if (!dim_rank_check (dim
, array
, false))
2493 if (array
->rank
== 1 || shift
->rank
== 0)
2495 if (!scalar_check (shift
, 1))
2498 else if (shift
->rank
== array
->rank
- 1)
2503 else if (dim
->expr_type
== EXPR_CONSTANT
)
2504 gfc_extract_int (dim
, &d
);
2511 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2514 if (!identical_dimen_shape (array
, i
, shift
, j
))
2516 gfc_error ("%qs argument of %qs intrinsic at %L has "
2517 "invalid shape in dimension %d (%ld/%ld)",
2518 gfc_current_intrinsic_arg
[1]->name
,
2519 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2520 mpz_get_si (array
->shape
[i
]),
2521 mpz_get_si (shift
->shape
[j
]));
2531 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2532 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2533 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2542 gfc_check_ctime (gfc_expr
*time
)
2544 if (!scalar_check (time
, 0))
2547 if (!type_check (time
, 0, BT_INTEGER
))
2554 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2556 if (!double_check (y
, 0) || !double_check (x
, 1))
2563 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2565 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2568 if (!numeric_check (x
, 0))
2573 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, gfc_default_double_kind
))
2576 if (!numeric_check (y
, 1))
2579 if (x
->ts
.type
== BT_COMPLEX
)
2581 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2582 "present if %<x%> is COMPLEX",
2583 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2588 if (y
->ts
.type
== BT_COMPLEX
)
2590 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2591 "of either REAL or INTEGER",
2592 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2603 gfc_check_dble (gfc_expr
*x
)
2605 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2608 if (!numeric_check (x
, 0))
2616 gfc_check_digits (gfc_expr
*x
)
2618 if (!int_or_real_check (x
, 0))
2626 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2628 switch (vector_a
->ts
.type
)
2631 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2638 if (!numeric_check (vector_b
, 1))
2643 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2644 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2645 gfc_current_intrinsic
, &vector_a
->where
);
2649 if (!rank_check (vector_a
, 0, 1))
2652 if (!rank_check (vector_b
, 1, 1))
2655 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2657 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2658 "intrinsic %<dot_product%>",
2659 gfc_current_intrinsic_arg
[0]->name
,
2660 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2669 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2671 if (!type_check (x
, 0, BT_REAL
)
2672 || !type_check (y
, 1, BT_REAL
))
2675 if (x
->ts
.kind
!= gfc_default_real_kind
)
2677 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2678 "real", gfc_current_intrinsic_arg
[0]->name
,
2679 gfc_current_intrinsic
, &x
->where
);
2683 if (y
->ts
.kind
!= gfc_default_real_kind
)
2685 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2686 "real", gfc_current_intrinsic_arg
[1]->name
,
2687 gfc_current_intrinsic
, &y
->where
);
2695 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2697 /* i and j cannot both be BOZ literal constants. */
2698 if (!boz_args_check (i
, j
))
2701 /* If i is BOZ and j is integer, convert i to type of j. If j is not
2702 an integer, clear the BOZ; otherwise, check that i is an integer. */
2703 if (i
->ts
.type
== BT_BOZ
)
2705 if (j
->ts
.type
!= BT_INTEGER
)
2707 else if (!gfc_boz2int (i
, j
->ts
.kind
))
2710 else if (!type_check (i
, 0, BT_INTEGER
))
2712 if (j
->ts
.type
== BT_BOZ
)
2717 /* If j is BOZ and i is integer, convert j to type of i. If i is not
2718 an integer, clear the BOZ; otherwise, check that i is an integer. */
2719 if (j
->ts
.type
== BT_BOZ
)
2721 if (i
->ts
.type
!= BT_INTEGER
)
2723 else if (!gfc_boz2int (j
, i
->ts
.kind
))
2726 else if (!type_check (j
, 1, BT_INTEGER
))
2729 if (!same_type_check (i
, 0, j
, 1))
2732 if (!type_check (shift
, 2, BT_INTEGER
))
2735 if (!nonnegative_check ("SHIFT", shift
))
2738 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2746 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2751 if (!array_check (array
, 0))
2754 if (!type_check (shift
, 1, BT_INTEGER
))
2757 if (!dim_check (dim
, 3, true))
2760 if (!dim_rank_check (dim
, array
, false))
2765 else if (dim
->expr_type
== EXPR_CONSTANT
)
2766 gfc_extract_int (dim
, &d
);
2770 if (array
->rank
== 1 || shift
->rank
== 0)
2772 if (!scalar_check (shift
, 1))
2775 else if (shift
->rank
== array
->rank
- 1)
2780 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2783 if (!identical_dimen_shape (array
, i
, shift
, j
))
2785 gfc_error ("%qs argument of %qs intrinsic at %L has "
2786 "invalid shape in dimension %d (%ld/%ld)",
2787 gfc_current_intrinsic_arg
[1]->name
,
2788 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2789 mpz_get_si (array
->shape
[i
]),
2790 mpz_get_si (shift
->shape
[j
]));
2800 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2801 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2802 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2806 if (boundary
!= NULL
)
2808 if (!same_type_check (array
, 0, boundary
, 2))
2811 /* Reject unequal string lengths and emit a better error message than
2812 gfc_check_same_strlen would. */
2813 if (array
->ts
.type
== BT_CHARACTER
)
2815 ssize_t len_a
, len_b
;
2817 len_a
= gfc_var_strlen (array
);
2818 len_b
= gfc_var_strlen (boundary
);
2819 if (len_a
!= -1 && len_b
!= -1 && len_a
!= len_b
)
2821 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2822 gfc_current_intrinsic_arg
[2]->name
,
2823 gfc_current_intrinsic_arg
[0]->name
,
2824 &boundary
->where
, gfc_current_intrinsic
);
2829 if (array
->rank
== 1 || boundary
->rank
== 0)
2831 if (!scalar_check (boundary
, 2))
2834 else if (boundary
->rank
== array
->rank
- 1)
2839 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2843 if (!identical_dimen_shape (array
, i
, boundary
, j
))
2845 gfc_error ("%qs argument of %qs intrinsic at %L has "
2846 "invalid shape in dimension %d (%ld/%ld)",
2847 gfc_current_intrinsic_arg
[2]->name
,
2848 gfc_current_intrinsic
, &shift
->where
, i
+1,
2849 mpz_get_si (array
->shape
[i
]),
2850 mpz_get_si (boundary
->shape
[j
]));
2860 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2861 "rank %d or be a scalar",
2862 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2863 &shift
->where
, array
->rank
- 1);
2869 switch (array
->ts
.type
)
2879 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2880 "of type %qs", gfc_current_intrinsic_arg
[2]->name
,
2881 gfc_current_intrinsic
, &array
->where
,
2882 gfc_current_intrinsic_arg
[0]->name
,
2883 gfc_typename (array
));
2893 gfc_check_float (gfc_expr
*a
)
2895 if (a
->ts
.type
== BT_BOZ
)
2897 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the"
2898 " FLOAT intrinsic subprogram"), &a
->where
))
2903 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
2907 if (!type_check (a
, 0, BT_INTEGER
))
2910 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2911 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2912 "kind argument to %s intrinsic at %L",
2913 gfc_current_intrinsic
, &a
->where
))
2919 /* A single complex argument. */
2922 gfc_check_fn_c (gfc_expr
*a
)
2924 if (!type_check (a
, 0, BT_COMPLEX
))
2931 /* A single real argument. */
2934 gfc_check_fn_r (gfc_expr
*a
)
2936 if (!type_check (a
, 0, BT_REAL
))
2942 /* A single double argument. */
2945 gfc_check_fn_d (gfc_expr
*a
)
2947 if (!double_check (a
, 0))
2953 /* A single real or complex argument. */
2956 gfc_check_fn_rc (gfc_expr
*a
)
2958 if (!real_or_complex_check (a
, 0))
2966 gfc_check_fn_rc2008 (gfc_expr
*a
)
2968 if (!real_or_complex_check (a
, 0))
2971 if (a
->ts
.type
== BT_COMPLEX
2972 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2973 "of %qs intrinsic at %L",
2974 gfc_current_intrinsic_arg
[0]->name
,
2975 gfc_current_intrinsic
, &a
->where
))
2983 gfc_check_fnum (gfc_expr
*unit
)
2985 if (!type_check (unit
, 0, BT_INTEGER
))
2988 if (!scalar_check (unit
, 0))
2996 gfc_check_huge (gfc_expr
*x
)
2998 if (!int_or_real_check (x
, 0))
3006 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
3008 if (!type_check (x
, 0, BT_REAL
))
3010 if (!same_type_check (x
, 0, y
, 1))
3017 /* Check that the single argument is an integer. */
3020 gfc_check_i (gfc_expr
*i
)
3022 if (!type_check (i
, 0, BT_INTEGER
))
3030 gfc_check_iand_ieor_ior (gfc_expr
*i
, gfc_expr
*j
)
3032 /* i and j cannot both be BOZ literal constants. */
3033 if (!boz_args_check (i
, j
))
3036 /* If i is BOZ and j is integer, convert i to type of j. */
3037 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
3038 && !gfc_boz2int (i
, j
->ts
.kind
))
3041 /* If j is BOZ and i is integer, convert j to type of i. */
3042 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
3043 && !gfc_boz2int (j
, i
->ts
.kind
))
3046 if (!type_check (i
, 0, BT_INTEGER
))
3049 if (!type_check (j
, 1, BT_INTEGER
))
3052 if (i
->ts
.kind
!= j
->ts
.kind
)
3054 gfc_error ("Arguments of %qs have different kind type parameters "
3055 "at %L", gfc_current_intrinsic
, &i
->where
);
3064 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
3066 if (!type_check (i
, 0, BT_INTEGER
))
3069 if (!type_check (pos
, 1, BT_INTEGER
))
3072 if (!type_check (len
, 2, BT_INTEGER
))
3075 if (!nonnegative_check ("pos", pos
))
3078 if (!nonnegative_check ("len", len
))
3081 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
3089 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
3093 if (!type_check (c
, 0, BT_CHARACTER
))
3096 if (!kind_check (kind
, 1, BT_INTEGER
))
3099 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3100 "with KIND argument at %L",
3101 gfc_current_intrinsic
, &kind
->where
))
3104 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
3110 /* Substring references don't have the charlength set. */
3112 while (ref
&& ref
->type
!= REF_SUBSTRING
)
3115 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3119 /* Check that the argument is length one. Non-constant lengths
3120 can't be checked here, so assume they are ok. */
3121 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
3123 /* If we already have a length for this expression then use it. */
3124 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3126 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
3133 start
= ref
->u
.ss
.start
;
3134 end
= ref
->u
.ss
.end
;
3137 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3138 || start
->expr_type
!= EXPR_CONSTANT
)
3141 i
= mpz_get_si (end
->value
.integer
) + 1
3142 - mpz_get_si (start
->value
.integer
);
3150 gfc_error ("Argument of %s at %L must be of length one",
3151 gfc_current_intrinsic
, &c
->where
);
3160 gfc_check_idnint (gfc_expr
*a
)
3162 if (!double_check (a
, 0))
3170 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
3173 if (!type_check (string
, 0, BT_CHARACTER
)
3174 || !type_check (substring
, 1, BT_CHARACTER
))
3177 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
3180 if (!kind_check (kind
, 3, BT_INTEGER
))
3182 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3183 "with KIND argument at %L",
3184 gfc_current_intrinsic
, &kind
->where
))
3187 if (string
->ts
.kind
!= substring
->ts
.kind
)
3189 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
3190 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
3191 gfc_current_intrinsic
, &substring
->where
,
3192 gfc_current_intrinsic_arg
[0]->name
);
3201 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
3203 /* BOZ is dealt within simplify_int*. */
3204 if (x
->ts
.type
== BT_BOZ
)
3207 if (!numeric_check (x
, 0))
3210 if (!kind_check (kind
, 1, BT_INTEGER
))
3218 gfc_check_intconv (gfc_expr
*x
)
3220 if (strcmp (gfc_current_intrinsic
, "short") == 0
3221 || strcmp (gfc_current_intrinsic
, "long") == 0)
3223 gfc_error ("%qs intrinsic subprogram at %L has been removed. "
3224 "Use INT intrinsic subprogram.", gfc_current_intrinsic
,
3229 /* BOZ is dealt within simplify_int*. */
3230 if (x
->ts
.type
== BT_BOZ
)
3233 if (!numeric_check (x
, 0))
3240 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
3242 if (!type_check (i
, 0, BT_INTEGER
)
3243 || !type_check (shift
, 1, BT_INTEGER
))
3246 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3254 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
3256 if (!type_check (i
, 0, BT_INTEGER
)
3257 || !type_check (shift
, 1, BT_INTEGER
))
3264 if (!type_check (size
, 2, BT_INTEGER
))
3267 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
3270 if (size
->expr_type
== EXPR_CONSTANT
)
3272 gfc_extract_int (size
, &i3
);
3275 gfc_error ("SIZE at %L must be positive", &size
->where
);
3279 if (shift
->expr_type
== EXPR_CONSTANT
)
3281 gfc_extract_int (shift
, &i2
);
3287 gfc_error ("The absolute value of SHIFT at %L must be less "
3288 "than or equal to SIZE at %L", &shift
->where
,
3295 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3303 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
3305 if (!type_check (pid
, 0, BT_INTEGER
))
3308 if (!scalar_check (pid
, 0))
3311 if (!type_check (sig
, 1, BT_INTEGER
))
3314 if (!scalar_check (sig
, 1))
3322 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
3324 if (!type_check (pid
, 0, BT_INTEGER
))
3327 if (!scalar_check (pid
, 0))
3330 if (!type_check (sig
, 1, BT_INTEGER
))
3333 if (!scalar_check (sig
, 1))
3338 if (!type_check (status
, 2, BT_INTEGER
))
3341 if (!scalar_check (status
, 2))
3344 if (status
->expr_type
!= EXPR_VARIABLE
)
3346 gfc_error ("STATUS at %L shall be an INTENT(OUT) variable",
3351 if (status
->expr_type
== EXPR_VARIABLE
3352 && status
->symtree
&& status
->symtree
->n
.sym
3353 && status
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3355 gfc_error ("%qs at %L shall be an INTENT(OUT) variable",
3356 status
->symtree
->name
, &status
->where
);
3366 gfc_check_kind (gfc_expr
*x
)
3368 if (gfc_invalid_null_arg (x
))
3371 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
3373 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3374 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
3375 gfc_current_intrinsic
, &x
->where
);
3378 if (x
->ts
.type
== BT_PROCEDURE
)
3380 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
3381 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3391 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3393 if (!array_check (array
, 0))
3396 if (!dim_check (dim
, 1, false))
3399 if (!dim_rank_check (dim
, array
, 1))
3402 if (!kind_check (kind
, 2, BT_INTEGER
))
3404 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3405 "with KIND argument at %L",
3406 gfc_current_intrinsic
, &kind
->where
))
3414 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
3416 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3418 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3422 if (!coarray_check (coarray
, 0))
3427 if (!dim_check (dim
, 1, false))
3430 if (!dim_corank_check (dim
, coarray
))
3434 if (!kind_check (kind
, 2, BT_INTEGER
))
3442 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
3444 if (!type_check (s
, 0, BT_CHARACTER
))
3447 if (gfc_invalid_null_arg (s
))
3450 if (!kind_check (kind
, 1, BT_INTEGER
))
3452 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3453 "with KIND argument at %L",
3454 gfc_current_intrinsic
, &kind
->where
))
3462 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
3464 if (!type_check (a
, 0, BT_CHARACTER
))
3466 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
3469 if (!type_check (b
, 1, BT_CHARACTER
))
3471 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
3479 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
3481 if (!type_check (path1
, 0, BT_CHARACTER
))
3483 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3486 if (!type_check (path2
, 1, BT_CHARACTER
))
3488 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3496 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3498 if (!type_check (path1
, 0, BT_CHARACTER
))
3500 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3503 if (!type_check (path2
, 1, BT_CHARACTER
))
3505 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
3511 if (!type_check (status
, 2, BT_INTEGER
))
3514 if (!scalar_check (status
, 2))
3522 gfc_check_loc (gfc_expr
*expr
)
3524 return variable_check (expr
, 0, true);
3529 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
3531 if (!type_check (path1
, 0, BT_CHARACTER
))
3533 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3536 if (!type_check (path2
, 1, BT_CHARACTER
))
3538 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3546 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3548 if (!type_check (path1
, 0, BT_CHARACTER
))
3550 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3553 if (!type_check (path2
, 1, BT_CHARACTER
))
3555 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3561 if (!type_check (status
, 2, BT_INTEGER
))
3564 if (!scalar_check (status
, 2))
3572 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
3574 if (!type_check (a
, 0, BT_LOGICAL
))
3576 if (!kind_check (kind
, 1, BT_LOGICAL
))
3583 /* Min/max family. */
3586 min_max_args (gfc_actual_arglist
*args
)
3588 gfc_actual_arglist
*arg
;
3589 int i
, j
, nargs
, *nlabels
, nlabelless
;
3590 bool a1
= false, a2
= false;
3592 if (args
== NULL
|| args
->next
== NULL
)
3594 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3595 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
3602 if (!args
->next
->name
)
3606 for (arg
= args
; arg
; arg
= arg
->next
)
3613 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3615 nlabels
= XALLOCAVEC (int, nargs
);
3616 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
3622 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
3624 n
= strtol (&arg
->name
[1], &endp
, 10);
3625 if (endp
[0] != '\0')
3629 if (n
<= nlabelless
)
3642 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3643 !a1
? "a1" : "a2", gfc_current_intrinsic
,
3644 gfc_current_intrinsic_where
);
3648 /* Check for duplicates. */
3649 for (i
= 0; i
< nargs
; i
++)
3650 for (j
= i
+ 1; j
< nargs
; j
++)
3651 if (nlabels
[i
] == nlabels
[j
])
3657 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3658 &arg
->expr
->where
, gfc_current_intrinsic
);
3662 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3663 &arg
->expr
->where
, gfc_current_intrinsic
);
3669 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3671 gfc_actual_arglist
*arg
, *tmp
;
3675 if (!min_max_args (arglist
))
3678 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3681 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3683 if (x
->ts
.type
== type
)
3685 if (x
->ts
.type
== BT_CHARACTER
)
3687 gfc_error ("Different character kinds at %L", &x
->where
);
3690 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3691 "kinds at %L", &x
->where
))
3696 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3697 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3698 gfc_basic_typename (type
), kind
);
3703 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3704 if (!gfc_check_conformance (tmp
->expr
, x
,
3705 _("arguments 'a%d' and 'a%d' for "
3706 "intrinsic '%s'"), m
, n
,
3707 gfc_current_intrinsic
))
3716 gfc_check_min_max (gfc_actual_arglist
*arg
)
3720 if (!min_max_args (arg
))
3725 if (x
->ts
.type
== BT_CHARACTER
)
3727 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3728 "with CHARACTER argument at %L",
3729 gfc_current_intrinsic
, &x
->where
))
3732 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3734 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3735 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3739 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3744 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3746 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3751 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3753 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3758 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3760 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3764 /* End of min/max family. */
3767 gfc_check_malloc (gfc_expr
*size
)
3769 if (!type_check (size
, 0, BT_INTEGER
))
3772 if (!scalar_check (size
, 0))
3780 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3782 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3784 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3785 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3786 gfc_current_intrinsic
, &matrix_a
->where
);
3790 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3792 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3793 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3794 gfc_current_intrinsic
, &matrix_b
->where
);
3798 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3799 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3801 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3802 gfc_current_intrinsic
, &matrix_a
->where
,
3803 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3807 switch (matrix_a
->rank
)
3810 if (!rank_check (matrix_b
, 1, 2))
3812 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3813 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3815 gfc_error ("Different shape on dimension 1 for arguments %qs "
3816 "and %qs at %L for intrinsic matmul",
3817 gfc_current_intrinsic_arg
[0]->name
,
3818 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3824 if (matrix_b
->rank
!= 2)
3826 if (!rank_check (matrix_b
, 1, 1))
3829 /* matrix_b has rank 1 or 2 here. Common check for the cases
3830 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3831 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3832 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3834 gfc_error ("Different shape on dimension 2 for argument %qs and "
3835 "dimension 1 for argument %qs at %L for intrinsic "
3836 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3837 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3843 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3844 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3845 gfc_current_intrinsic
, &matrix_a
->where
);
3853 /* Whoever came up with this interface was probably on something.
3854 The possibilities for the occupation of the second and third
3861 NULL MASK minloc(array, mask=m)
3864 I.e. in the case of minloc(array,mask), mask will be in the second
3865 position of the argument list and we'll have to fix that up. Also,
3866 add the BACK argument if that isn't present. */
3869 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3871 gfc_expr
*a
, *m
, *d
, *k
, *b
;
3874 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3878 m
= ap
->next
->next
->expr
;
3879 k
= ap
->next
->next
->next
->expr
;
3880 b
= ap
->next
->next
->next
->next
->expr
;
3884 if (!type_check (b
, 4, BT_LOGICAL
) || !scalar_check (b
,4))
3889 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3890 ap
->next
->next
->next
->next
->expr
= b
;
3893 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3894 && ap
->next
->name
== NULL
)
3898 ap
->next
->expr
= NULL
;
3899 ap
->next
->next
->expr
= m
;
3902 if (!dim_check (d
, 1, false))
3905 if (!dim_rank_check (d
, a
, 0))
3908 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3912 && !gfc_check_conformance (a
, m
,
3913 _("arguments '%s' and '%s' for intrinsic %s"),
3914 gfc_current_intrinsic_arg
[0]->name
,
3915 gfc_current_intrinsic_arg
[2]->name
,
3916 gfc_current_intrinsic
))
3919 if (!kind_check (k
, 1, BT_INTEGER
))
3925 /* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3926 above, with the additional "value" argument. */
3929 gfc_check_findloc (gfc_actual_arglist
*ap
)
3931 gfc_expr
*a
, *v
, *m
, *d
, *k
, *b
;
3935 if (!intrinsic_type_check (a
, 0) || !array_check (a
, 0))
3939 if (!intrinsic_type_check (v
, 1) || !scalar_check (v
,1))
3942 /* Check if the type are both logical. */
3943 a1
= a
->ts
.type
== BT_LOGICAL
;
3944 v1
= v
->ts
.type
== BT_LOGICAL
;
3945 if ((a1
&& !v1
) || (!a1
&& v1
))
3948 /* Check if the type are both character. */
3949 a1
= a
->ts
.type
== BT_CHARACTER
;
3950 v1
= v
->ts
.type
== BT_CHARACTER
;
3951 if ((a1
&& !v1
) || (!a1
&& v1
))
3954 /* Check the kind of the characters argument match. */
3955 if (a1
&& v1
&& a
->ts
.kind
!= v
->ts
.kind
)
3958 d
= ap
->next
->next
->expr
;
3959 m
= ap
->next
->next
->next
->expr
;
3960 k
= ap
->next
->next
->next
->next
->expr
;
3961 b
= ap
->next
->next
->next
->next
->next
->expr
;
3965 if (!type_check (b
, 5, BT_LOGICAL
) || !scalar_check (b
,4))
3970 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3971 ap
->next
->next
->next
->next
->next
->expr
= b
;
3974 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3975 && ap
->next
->name
== NULL
)
3979 ap
->next
->next
->expr
= NULL
;
3980 ap
->next
->next
->next
->expr
= m
;
3983 if (!dim_check (d
, 2, false))
3986 if (!dim_rank_check (d
, a
, 0))
3989 if (m
!= NULL
&& !type_check (m
, 3, BT_LOGICAL
))
3993 && !gfc_check_conformance (a
, m
,
3994 _("arguments '%s' and '%s' for intrinsic %s"),
3995 gfc_current_intrinsic_arg
[0]->name
,
3996 gfc_current_intrinsic_arg
[3]->name
,
3997 gfc_current_intrinsic
))
4000 if (!kind_check (k
, 1, BT_INTEGER
))
4006 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4007 "conformance to argument %qs at %L",
4008 gfc_current_intrinsic_arg
[0]->name
,
4009 gfc_current_intrinsic
, &a
->where
,
4010 gfc_current_intrinsic_arg
[1]->name
, &v
->where
);
4015 /* Similar to minloc/maxloc, the argument list might need to be
4016 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4017 difference is that MINLOC/MAXLOC take an additional KIND argument.
4018 The possibilities are:
4024 NULL MASK minval(array, mask=m)
4027 I.e. in the case of minval(array,mask), mask will be in the second
4028 position of the argument list and we'll have to fix that up. */
4031 check_reduction (gfc_actual_arglist
*ap
)
4033 gfc_expr
*a
, *m
, *d
;
4037 m
= ap
->next
->next
->expr
;
4039 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
4040 && ap
->next
->name
== NULL
)
4044 ap
->next
->expr
= NULL
;
4045 ap
->next
->next
->expr
= m
;
4048 if (!dim_check (d
, 1, false))
4051 if (!dim_rank_check (d
, a
, 0))
4054 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
4058 && !gfc_check_conformance (a
, m
,
4059 _("arguments '%s' and '%s' for intrinsic %s"),
4060 gfc_current_intrinsic_arg
[0]->name
,
4061 gfc_current_intrinsic_arg
[2]->name
,
4062 gfc_current_intrinsic
))
4070 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
4072 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
4073 || !array_check (ap
->expr
, 0))
4076 return check_reduction (ap
);
4081 gfc_check_product_sum (gfc_actual_arglist
*ap
)
4083 if (!numeric_check (ap
->expr
, 0)
4084 || !array_check (ap
->expr
, 0))
4087 return check_reduction (ap
);
4091 /* For IANY, IALL and IPARITY. */
4094 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
4098 if (!type_check (i
, 0, BT_INTEGER
))
4101 if (!nonnegative_check ("I", i
))
4104 if (!kind_check (kind
, 1, BT_INTEGER
))
4108 gfc_extract_int (kind
, &k
);
4110 k
= gfc_default_integer_kind
;
4112 if (!less_than_bitsizekind ("I", i
, k
))
4120 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
4122 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
4124 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4125 gfc_current_intrinsic_arg
[0]->name
,
4126 gfc_current_intrinsic
, &ap
->expr
->where
);
4130 if (!array_check (ap
->expr
, 0))
4133 return check_reduction (ap
);
4138 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4140 if (gfc_invalid_null_arg (tsource
))
4143 if (gfc_invalid_null_arg (fsource
))
4146 if (!same_type_check (tsource
, 0, fsource
, 1))
4149 if (!type_check (mask
, 2, BT_LOGICAL
))
4152 if (tsource
->ts
.type
== BT_CHARACTER
)
4153 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
4160 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
4162 /* i and j cannot both be BOZ literal constants. */
4163 if (!boz_args_check (i
, j
))
4166 /* If i is BOZ and j is integer, convert i to type of j. */
4167 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
4168 && !gfc_boz2int (i
, j
->ts
.kind
))
4171 /* If j is BOZ and i is integer, convert j to type of i. */
4172 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
4173 && !gfc_boz2int (j
, i
->ts
.kind
))
4176 if (!type_check (i
, 0, BT_INTEGER
))
4179 if (!type_check (j
, 1, BT_INTEGER
))
4182 if (!same_type_check (i
, 0, j
, 1))
4185 if (mask
->ts
.type
== BT_BOZ
&& !gfc_boz2int(mask
, i
->ts
.kind
))
4188 if (!type_check (mask
, 2, BT_INTEGER
))
4191 if (!same_type_check (i
, 0, mask
, 2))
4199 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
4201 if (!variable_check (from
, 0, false))
4203 if (!allocatable_check (from
, 0))
4205 if (gfc_is_coindexed (from
))
4207 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4208 "coindexed", &from
->where
);
4212 if (!variable_check (to
, 1, false))
4214 if (!allocatable_check (to
, 1))
4216 if (gfc_is_coindexed (to
))
4218 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4219 "coindexed", &to
->where
);
4223 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
4225 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4226 "polymorphic if FROM is polymorphic",
4231 if (!same_type_check (to
, 1, from
, 0))
4234 if (to
->rank
!= from
->rank
)
4236 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4237 "must have the same rank %d/%d", &to
->where
, from
->rank
,
4242 /* IR F08/0040; cf. 12-006A. */
4243 if (gfc_get_corank (to
) != gfc_get_corank (from
))
4245 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4246 "must have the same corank %d/%d", &to
->where
,
4247 gfc_get_corank (from
), gfc_get_corank (to
));
4251 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
4252 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4253 and cmp2 are allocatable. After the allocation is transferred,
4254 the 'to' chain is broken by the nullification of the 'from'. A bit
4255 of reflection reveals that this can only occur for derived types
4256 with recursive allocatable components. */
4257 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
4258 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
4260 gfc_ref
*to_ref
, *from_ref
;
4262 from_ref
= from
->ref
;
4263 bool aliasing
= true;
4265 for (; from_ref
&& to_ref
;
4266 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
4268 if (to_ref
->type
!= from
->ref
->type
)
4270 else if (to_ref
->type
== REF_ARRAY
4271 && to_ref
->u
.ar
.type
!= AR_FULL
4272 && from_ref
->u
.ar
.type
!= AR_FULL
)
4273 /* Play safe; assume sections and elements are different. */
4275 else if (to_ref
->type
== REF_COMPONENT
4276 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
4285 gfc_error ("The FROM and TO arguments at %L violate aliasing "
4286 "restrictions (F2003 12.4.1.7)", &to
->where
);
4291 /* CLASS arguments: Make sure the vtab of from is present. */
4292 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
4293 gfc_find_vtab (&from
->ts
);
4300 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
4302 if (!type_check (x
, 0, BT_REAL
))
4305 if (!type_check (s
, 1, BT_REAL
))
4308 if (s
->expr_type
== EXPR_CONSTANT
)
4310 if (mpfr_sgn (s
->value
.real
) == 0)
4312 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4323 gfc_check_new_line (gfc_expr
*a
)
4325 if (!type_check (a
, 0, BT_CHARACTER
))
4333 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
4335 if (!type_check (array
, 0, BT_REAL
))
4338 if (!array_check (array
, 0))
4341 if (!dim_check (dim
, 1, false))
4344 if (!dim_rank_check (dim
, array
, false))
4351 gfc_check_null (gfc_expr
*mold
)
4353 symbol_attribute attr
;
4358 if (!variable_check (mold
, 0, true))
4361 attr
= gfc_variable_attr (mold
, NULL
);
4363 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
4365 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4366 "ALLOCATABLE or procedure pointer",
4367 gfc_current_intrinsic_arg
[0]->name
,
4368 gfc_current_intrinsic
, &mold
->where
);
4372 if (attr
.allocatable
4373 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
4374 "allocatable MOLD at %L", &mold
->where
))
4378 if (gfc_is_coindexed (mold
))
4380 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4381 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
4382 gfc_current_intrinsic
, &mold
->where
);
4391 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4393 if (!array_check (array
, 0))
4396 if (!type_check (mask
, 1, BT_LOGICAL
))
4399 if (!gfc_check_conformance (array
, mask
,
4400 _("arguments '%s' and '%s' for intrinsic '%s'"),
4401 gfc_current_intrinsic_arg
[0]->name
,
4402 gfc_current_intrinsic_arg
[1]->name
,
4403 gfc_current_intrinsic
))
4408 mpz_t array_size
, vector_size
;
4409 bool have_array_size
, have_vector_size
;
4411 if (!same_type_check (array
, 0, vector
, 2))
4414 if (!rank_check (vector
, 2, 1))
4417 /* VECTOR requires at least as many elements as MASK
4418 has .TRUE. values. */
4419 have_array_size
= gfc_array_size(array
, &array_size
);
4420 have_vector_size
= gfc_array_size(vector
, &vector_size
);
4422 if (have_vector_size
4423 && (mask
->expr_type
== EXPR_ARRAY
4424 || (mask
->expr_type
== EXPR_CONSTANT
4425 && have_array_size
)))
4427 int mask_true_values
= 0;
4429 if (mask
->expr_type
== EXPR_ARRAY
)
4431 gfc_constructor
*mask_ctor
;
4432 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4435 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4437 mask_true_values
= 0;
4441 if (mask_ctor
->expr
->value
.logical
)
4444 mask_ctor
= gfc_constructor_next (mask_ctor
);
4447 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
4448 mask_true_values
= mpz_get_si (array_size
);
4450 if (mpz_get_si (vector_size
) < mask_true_values
)
4452 gfc_error ("%qs argument of %qs intrinsic at %L must "
4453 "provide at least as many elements as there "
4454 "are .TRUE. values in %qs (%ld/%d)",
4455 gfc_current_intrinsic_arg
[2]->name
,
4456 gfc_current_intrinsic
, &vector
->where
,
4457 gfc_current_intrinsic_arg
[1]->name
,
4458 mpz_get_si (vector_size
), mask_true_values
);
4463 if (have_array_size
)
4464 mpz_clear (array_size
);
4465 if (have_vector_size
)
4466 mpz_clear (vector_size
);
4474 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
4476 if (!type_check (mask
, 0, BT_LOGICAL
))
4479 if (!array_check (mask
, 0))
4482 if (!dim_check (dim
, 1, false))
4485 if (!dim_rank_check (dim
, mask
, false))
4493 gfc_check_precision (gfc_expr
*x
)
4495 if (!real_or_complex_check (x
, 0))
4503 gfc_check_present (gfc_expr
*a
)
4507 if (!variable_check (a
, 0, true))
4510 sym
= a
->symtree
->n
.sym
;
4511 if (!sym
->attr
.dummy
)
4513 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4514 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
4515 gfc_current_intrinsic
, &a
->where
);
4519 /* For CLASS, the optional attribute might be set at either location. */
4520 if ((sym
->ts
.type
!= BT_CLASS
|| !CLASS_DATA (sym
)->attr
.optional
)
4521 && !sym
->attr
.optional
)
4523 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4524 "an OPTIONAL dummy variable",
4525 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4530 /* 13.14.82 PRESENT(A)
4532 Argument. A shall be the name of an optional dummy argument that is
4533 accessible in the subprogram in which the PRESENT function reference
4537 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
4538 && (a
->ref
->u
.ar
.type
== AR_FULL
4539 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
4540 && a
->ref
->u
.ar
.as
->rank
== 0))))
4542 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4543 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
4544 gfc_current_intrinsic
, &a
->where
, sym
->name
);
4553 gfc_check_radix (gfc_expr
*x
)
4555 if (!int_or_real_check (x
, 0))
4563 gfc_check_range (gfc_expr
*x
)
4565 if (!numeric_check (x
, 0))
4573 gfc_check_rank (gfc_expr
*a
)
4575 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4576 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4578 bool is_variable
= true;
4580 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4581 if (a
->expr_type
== EXPR_FUNCTION
)
4582 is_variable
= a
->value
.function
.esym
4583 ? a
->value
.function
.esym
->result
->attr
.pointer
4584 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
4586 if (a
->expr_type
== EXPR_OP
4587 || a
->expr_type
== EXPR_NULL
4588 || a
->expr_type
== EXPR_COMPCALL
4589 || a
->expr_type
== EXPR_PPC
4590 || a
->ts
.type
== BT_PROCEDURE
4593 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4594 "object", &a
->where
);
4603 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
4605 if (!kind_check (kind
, 1, BT_REAL
))
4608 /* BOZ is dealt with in gfc_simplify_real. */
4609 if (a
->ts
.type
== BT_BOZ
)
4612 if (!numeric_check (a
, 0))
4620 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
4622 if (!type_check (path1
, 0, BT_CHARACTER
))
4624 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4627 if (!type_check (path2
, 1, BT_CHARACTER
))
4629 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4637 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
4639 if (!type_check (path1
, 0, BT_CHARACTER
))
4641 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4644 if (!type_check (path2
, 1, BT_CHARACTER
))
4646 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4652 if (!type_check (status
, 2, BT_INTEGER
))
4655 if (!scalar_check (status
, 2))
4663 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
4665 if (!type_check (x
, 0, BT_CHARACTER
))
4668 if (!scalar_check (x
, 0))
4671 if (!type_check (y
, 0, BT_INTEGER
))
4674 if (!scalar_check (y
, 1))
4682 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
4683 gfc_expr
*pad
, gfc_expr
*order
)
4688 bool shape_is_const
;
4690 if (!array_check (source
, 0))
4693 if (!rank_check (shape
, 1, 1))
4696 if (!type_check (shape
, 1, BT_INTEGER
))
4699 if (!gfc_array_size (shape
, &size
))
4701 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4702 "array of constant size", &shape
->where
);
4706 shape_size
= mpz_get_ui (size
);
4709 if (shape_size
<= 0)
4711 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4712 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4716 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4718 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4719 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4723 gfc_simplify_expr (shape
, 0);
4724 shape_is_const
= gfc_is_constant_expr (shape
);
4726 if (shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
)
4730 for (i
= 0; i
< shape_size
; ++i
)
4732 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4733 if (e
->expr_type
!= EXPR_CONSTANT
)
4736 gfc_extract_int (e
, &extent
);
4739 gfc_error ("%qs argument of %qs intrinsic at %L has "
4740 "negative element (%d)",
4741 gfc_current_intrinsic_arg
[1]->name
,
4742 gfc_current_intrinsic
, &shape
->where
, extent
);
4750 if (!same_type_check (source
, 0, pad
, 2))
4753 if (!array_check (pad
, 2))
4759 if (!array_check (order
, 3))
4762 if (!type_check (order
, 3, BT_INTEGER
))
4765 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4767 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4770 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4773 gfc_array_size (order
, &size
);
4774 order_size
= mpz_get_ui (size
);
4777 if (order_size
!= shape_size
)
4779 gfc_error ("%qs argument of %qs intrinsic at %L "
4780 "has wrong number of elements (%d/%d)",
4781 gfc_current_intrinsic_arg
[3]->name
,
4782 gfc_current_intrinsic
, &order
->where
,
4783 order_size
, shape_size
);
4787 for (i
= 1; i
<= order_size
; ++i
)
4789 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4790 if (e
->expr_type
!= EXPR_CONSTANT
)
4793 gfc_extract_int (e
, &dim
);
4795 if (dim
< 1 || dim
> order_size
)
4797 gfc_error ("%qs argument of %qs intrinsic at %L "
4798 "has out-of-range dimension (%d)",
4799 gfc_current_intrinsic_arg
[3]->name
,
4800 gfc_current_intrinsic
, &e
->where
, dim
);
4804 if (perm
[dim
-1] != 0)
4806 gfc_error ("%qs argument of %qs intrinsic at %L has "
4807 "invalid permutation of dimensions (dimension "
4809 gfc_current_intrinsic_arg
[3]->name
,
4810 gfc_current_intrinsic
, &e
->where
, dim
);
4819 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
4820 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4821 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4823 /* Check the match in size between source and destination. */
4824 if (gfc_array_size (source
, &nelems
))
4830 mpz_init_set_ui (size
, 1);
4831 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4832 c
; c
= gfc_constructor_next (c
))
4833 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4835 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4841 gfc_error ("Without padding, there are not enough elements "
4842 "in the intrinsic RESHAPE source at %L to match "
4843 "the shape", &source
->where
);
4854 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4856 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4858 gfc_error ("%qs argument of %qs intrinsic at %L "
4859 "cannot be of type %s",
4860 gfc_current_intrinsic_arg
[0]->name
,
4861 gfc_current_intrinsic
,
4862 &a
->where
, gfc_typename (a
));
4866 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4868 gfc_error ("%qs argument of %qs intrinsic at %L "
4869 "must be of an extensible type",
4870 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4875 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4877 gfc_error ("%qs argument of %qs intrinsic at %L "
4878 "cannot be of type %s",
4879 gfc_current_intrinsic_arg
[0]->name
,
4880 gfc_current_intrinsic
,
4881 &b
->where
, gfc_typename (b
));
4885 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4887 gfc_error ("%qs argument of %qs intrinsic at %L "
4888 "must be of an extensible type",
4889 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4899 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4901 if (!type_check (x
, 0, BT_REAL
))
4904 if (!type_check (i
, 1, BT_INTEGER
))
4912 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4914 if (!type_check (x
, 0, BT_CHARACTER
))
4917 if (!type_check (y
, 1, BT_CHARACTER
))
4920 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4923 if (!kind_check (kind
, 3, BT_INTEGER
))
4925 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4926 "with KIND argument at %L",
4927 gfc_current_intrinsic
, &kind
->where
))
4930 if (!same_type_check (x
, 0, y
, 1))
4938 gfc_check_secnds (gfc_expr
*r
)
4940 if (!type_check (r
, 0, BT_REAL
))
4943 if (!kind_value_check (r
, 0, 4))
4946 if (!scalar_check (r
, 0))
4954 gfc_check_selected_char_kind (gfc_expr
*name
)
4956 if (!type_check (name
, 0, BT_CHARACTER
))
4959 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4962 if (!scalar_check (name
, 0))
4970 gfc_check_selected_int_kind (gfc_expr
*r
)
4972 if (!type_check (r
, 0, BT_INTEGER
))
4975 if (!scalar_check (r
, 0))
4983 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4985 if (p
== NULL
&& r
== NULL
4986 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4987 " neither %<P%> nor %<R%> argument at %L",
4988 gfc_current_intrinsic_where
))
4993 if (!type_check (p
, 0, BT_INTEGER
))
4996 if (!scalar_check (p
, 0))
5002 if (!type_check (r
, 1, BT_INTEGER
))
5005 if (!scalar_check (r
, 1))
5011 if (!type_check (radix
, 1, BT_INTEGER
))
5014 if (!scalar_check (radix
, 1))
5017 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
5018 "RADIX argument at %L", gfc_current_intrinsic
,
5028 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5030 if (!type_check (x
, 0, BT_REAL
))
5033 if (!type_check (i
, 1, BT_INTEGER
))
5041 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
5045 if (gfc_invalid_null_arg (source
))
5048 if (!kind_check (kind
, 1, BT_INTEGER
))
5050 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5051 "with KIND argument at %L",
5052 gfc_current_intrinsic
, &kind
->where
))
5055 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
5058 if (source
->ref
== NULL
)
5061 ar
= gfc_find_array_ref (source
);
5063 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
5065 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5066 "an assumed size array", &source
->where
);
5075 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
5077 if (!type_check (i
, 0, BT_INTEGER
))
5080 if (!type_check (shift
, 0, BT_INTEGER
))
5083 if (!nonnegative_check ("SHIFT", shift
))
5086 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
5094 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
5096 if (!int_or_real_check (a
, 0))
5099 if (!same_type_check (a
, 0, b
, 1))
5107 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5109 if (!array_check (array
, 0))
5112 if (!dim_check (dim
, 1, true))
5115 if (!dim_rank_check (dim
, array
, 0))
5118 if (!kind_check (kind
, 2, BT_INTEGER
))
5120 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5121 "with KIND argument at %L",
5122 gfc_current_intrinsic
, &kind
->where
))
5131 gfc_check_sizeof (gfc_expr
*arg
)
5133 if (gfc_invalid_null_arg (arg
))
5136 if (arg
->ts
.type
== BT_PROCEDURE
)
5138 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5139 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5144 if (illegal_boz_arg (arg
))
5147 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5148 if (arg
->ts
.type
== BT_ASSUMED
5149 && (arg
->symtree
->n
.sym
->as
== NULL
5150 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
5151 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
5152 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
5154 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5155 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5160 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5161 && arg
->symtree
->n
.sym
->as
!= NULL
5162 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5163 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5165 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5166 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5167 gfc_current_intrinsic
, &arg
->where
);
5175 /* Check whether an expression is interoperable. When returning false,
5176 msg is set to a string telling why the expression is not interoperable,
5177 otherwise, it is set to NULL. The msg string can be used in diagnostics.
5178 If c_loc is true, character with len > 1 are allowed (cf. Fortran
5179 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5180 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5184 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
5188 if (expr
->expr_type
== EXPR_NULL
)
5190 *msg
= "NULL() is not interoperable";
5194 if (expr
->ts
.type
== BT_BOZ
)
5196 *msg
= "BOZ literal constant";
5200 if (expr
->ts
.type
== BT_CLASS
)
5202 *msg
= "Expression is polymorphic";
5206 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
5207 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
5209 *msg
= "Expression is a noninteroperable derived type";
5213 if (expr
->ts
.type
== BT_PROCEDURE
)
5215 *msg
= "Procedure unexpected as argument";
5219 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
5222 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
5223 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
5225 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
5229 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
5230 && expr
->ts
.kind
!= 1)
5232 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
5236 if (expr
->ts
.type
== BT_CHARACTER
) {
5237 if (expr
->ts
.deferred
)
5239 /* TS 29113 allows deferred-length strings as dummy arguments,
5240 but it is not an interoperable type. */
5241 *msg
= "Expression shall not be a deferred-length string";
5245 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
5246 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
5247 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5249 if (!c_loc
&& expr
->ts
.u
.cl
5250 && (!expr
->ts
.u
.cl
->length
5251 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5252 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5254 *msg
= "Type shall have a character length of 1";
5259 /* Note: The following checks are about interoperatable variables, Fortran
5260 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5261 is allowed, e.g. assumed-shape arrays with TS 29113. */
5263 if (gfc_is_coarray (expr
))
5265 *msg
= "Coarrays are not interoperable";
5269 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
5271 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
5272 if (ar
->type
!= AR_FULL
)
5274 *msg
= "Only whole-arrays are interoperable";
5277 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
5278 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
5280 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
5290 gfc_check_c_sizeof (gfc_expr
*arg
)
5294 if (!is_c_interoperable (arg
, &msg
, false, false))
5296 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5297 "interoperable data entity: %s",
5298 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5303 if (arg
->ts
.type
== BT_ASSUMED
)
5305 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5307 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5312 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5313 && arg
->symtree
->n
.sym
->as
!= NULL
5314 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5315 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5317 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5318 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5319 gfc_current_intrinsic
, &arg
->where
);
5328 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
5330 if (c_ptr_1
->ts
.type
!= BT_DERIVED
5331 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5332 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
5333 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
5335 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5336 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
5340 if (!scalar_check (c_ptr_1
, 0))
5344 && (c_ptr_2
->ts
.type
!= BT_DERIVED
5345 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5346 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
5347 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
5349 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5350 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
5351 gfc_typename (&c_ptr_1
->ts
),
5352 gfc_typename (&c_ptr_2
->ts
));
5356 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
5364 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
5366 symbol_attribute attr
;
5369 if (cptr
->ts
.type
!= BT_DERIVED
5370 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5371 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
5373 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5374 "type TYPE(C_PTR)", &cptr
->where
);
5378 if (!scalar_check (cptr
, 0))
5381 attr
= gfc_expr_attr (fptr
);
5385 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5390 if (fptr
->ts
.type
== BT_CLASS
)
5392 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5397 if (gfc_is_coindexed (fptr
))
5399 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5400 "coindexed", &fptr
->where
);
5404 if (fptr
->rank
== 0 && shape
)
5406 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5407 "FPTR", &fptr
->where
);
5410 else if (fptr
->rank
&& !shape
)
5412 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5413 "FPTR at %L", &fptr
->where
);
5417 if (shape
&& !rank_check (shape
, 2, 1))
5420 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
5426 if (gfc_array_size (shape
, &size
))
5428 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
5431 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5432 "size as the RANK of FPTR", &shape
->where
);
5439 if (fptr
->ts
.type
== BT_CLASS
)
5441 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
5445 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
5446 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable array FPTR "
5447 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
5454 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
5456 symbol_attribute attr
;
5458 if (cptr
->ts
.type
!= BT_DERIVED
5459 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5460 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
5462 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5463 "type TYPE(C_FUNPTR)", &cptr
->where
);
5467 if (!scalar_check (cptr
, 0))
5470 attr
= gfc_expr_attr (fptr
);
5472 if (!attr
.proc_pointer
)
5474 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5475 "pointer", &fptr
->where
);
5479 if (gfc_is_coindexed (fptr
))
5481 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5482 "coindexed", &fptr
->where
);
5486 if (!attr
.is_bind_c
)
5487 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5488 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
5495 gfc_check_c_funloc (gfc_expr
*x
)
5497 symbol_attribute attr
;
5499 if (gfc_is_coindexed (x
))
5501 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5502 "coindexed", &x
->where
);
5506 attr
= gfc_expr_attr (x
);
5508 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
5509 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
5510 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5511 if (x
->symtree
->n
.sym
== ns
->proc_name
)
5513 gfc_error ("Function result %qs at %L is invalid as X argument "
5514 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
5518 if (attr
.flavor
!= FL_PROCEDURE
)
5520 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5521 "or a procedure pointer", &x
->where
);
5525 if (!attr
.is_bind_c
)
5526 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5527 "at %L to C_FUNLOC", &x
->where
);
5533 gfc_check_c_loc (gfc_expr
*x
)
5535 symbol_attribute attr
;
5538 if (gfc_is_coindexed (x
))
5540 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
5544 if (x
->ts
.type
== BT_CLASS
)
5546 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5551 attr
= gfc_expr_attr (x
);
5554 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
5555 || attr
.flavor
== FL_PARAMETER
))
5557 gfc_error ("Argument X at %L to C_LOC shall have either "
5558 "the POINTER or the TARGET attribute", &x
->where
);
5562 if (x
->ts
.type
== BT_CHARACTER
5563 && gfc_var_strlen (x
) == 0)
5565 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5566 "string", &x
->where
);
5570 if (!is_c_interoperable (x
, &msg
, true, false))
5572 if (x
->ts
.type
== BT_CLASS
)
5574 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5580 && !gfc_notify_std (GFC_STD_F2018
,
5581 "Noninteroperable array at %L as"
5582 " argument to C_LOC: %s", &x
->where
, msg
))
5585 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
5587 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
5589 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
5590 && !attr
.allocatable
5591 && !gfc_notify_std (GFC_STD_F2008
,
5592 "Array of interoperable type at %L "
5593 "to C_LOC which is nonallocatable and neither "
5594 "assumed size nor explicit size", &x
->where
))
5596 else if (ar
->type
!= AR_FULL
5597 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
5598 "to C_LOC", &x
->where
))
5607 gfc_check_sleep_sub (gfc_expr
*seconds
)
5609 if (!type_check (seconds
, 0, BT_INTEGER
))
5612 if (!scalar_check (seconds
, 0))
5619 gfc_check_sngl (gfc_expr
*a
)
5621 if (!type_check (a
, 0, BT_REAL
))
5624 if ((a
->ts
.kind
!= gfc_default_double_kind
)
5625 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
5626 "REAL argument to %s intrinsic at %L",
5627 gfc_current_intrinsic
, &a
->where
))
5634 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
5636 if (gfc_invalid_null_arg (source
))
5639 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
5641 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5642 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
5643 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
5651 if (!dim_check (dim
, 1, false))
5654 /* dim_rank_check() does not apply here. */
5656 && dim
->expr_type
== EXPR_CONSTANT
5657 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
5658 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
5660 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5661 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
5662 gfc_current_intrinsic
, &dim
->where
);
5666 if (!type_check (ncopies
, 2, BT_INTEGER
))
5669 if (!scalar_check (ncopies
, 2))
5676 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5680 arg_strlen_is_zero (gfc_expr
*c
, int n
)
5682 if (gfc_var_strlen (c
) == 0)
5684 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5685 "length at least 1", gfc_current_intrinsic_arg
[n
]->name
,
5686 gfc_current_intrinsic
, &c
->where
);
5693 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
5695 if (!type_check (unit
, 0, BT_INTEGER
))
5698 if (!scalar_check (unit
, 0))
5701 if (!type_check (c
, 1, BT_CHARACTER
))
5703 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5705 if (strcmp (gfc_current_intrinsic
, "fgetc") == 0
5706 && !variable_check (c
, 1, false))
5708 if (arg_strlen_is_zero (c
, 1))
5714 if (!type_check (status
, 2, BT_INTEGER
)
5715 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5716 || !scalar_check (status
, 2)
5717 || !variable_check (status
, 2, false))
5725 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5727 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5732 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5734 if (!type_check (c
, 0, BT_CHARACTER
))
5736 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5738 if (strcmp (gfc_current_intrinsic
, "fget") == 0
5739 && !variable_check (c
, 0, false))
5741 if (arg_strlen_is_zero (c
, 0))
5747 if (!type_check (status
, 1, BT_INTEGER
)
5748 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5749 || !scalar_check (status
, 1)
5750 || !variable_check (status
, 1, false))
5758 gfc_check_fgetput (gfc_expr
*c
)
5760 return gfc_check_fgetput_sub (c
, NULL
);
5765 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5767 if (!type_check (unit
, 0, BT_INTEGER
))
5770 if (!scalar_check (unit
, 0))
5773 if (!type_check (offset
, 1, BT_INTEGER
))
5776 if (!scalar_check (offset
, 1))
5779 if (!type_check (whence
, 2, BT_INTEGER
))
5782 if (!scalar_check (whence
, 2))
5788 if (!type_check (status
, 3, BT_INTEGER
))
5791 if (!kind_value_check (status
, 3, 4))
5794 if (!scalar_check (status
, 3))
5803 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5805 if (!type_check (unit
, 0, BT_INTEGER
))
5808 if (!scalar_check (unit
, 0))
5811 if (!type_check (array
, 1, BT_INTEGER
)
5812 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5815 if (!array_check (array
, 1))
5823 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5825 if (!type_check (unit
, 0, BT_INTEGER
))
5828 if (!scalar_check (unit
, 0))
5831 if (!type_check (array
, 1, BT_INTEGER
)
5832 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5835 if (!array_check (array
, 1))
5841 if (!type_check (status
, 2, BT_INTEGER
)
5842 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5845 if (!scalar_check (status
, 2))
5853 gfc_check_ftell (gfc_expr
*unit
)
5855 if (!type_check (unit
, 0, BT_INTEGER
))
5858 if (!scalar_check (unit
, 0))
5866 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5868 if (!type_check (unit
, 0, BT_INTEGER
))
5871 if (!scalar_check (unit
, 0))
5874 if (!type_check (offset
, 1, BT_INTEGER
))
5877 if (!scalar_check (offset
, 1))
5885 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5887 if (!type_check (name
, 0, BT_CHARACTER
))
5889 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5892 if (!type_check (array
, 1, BT_INTEGER
)
5893 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5896 if (!array_check (array
, 1))
5904 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5906 if (!type_check (name
, 0, BT_CHARACTER
))
5908 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5911 if (!type_check (array
, 1, BT_INTEGER
)
5912 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5915 if (!array_check (array
, 1))
5921 if (!type_check (status
, 2, BT_INTEGER
)
5922 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5925 if (!scalar_check (status
, 2))
5933 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5937 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5939 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5943 if (!coarray_check (coarray
, 0))
5948 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5949 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5953 if (sub
->ts
.type
!= BT_INTEGER
)
5955 gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
5956 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5960 if (gfc_array_size (sub
, &nelems
))
5962 int corank
= gfc_get_corank (coarray
);
5964 if (mpz_cmp_ui (nelems
, corank
) != 0)
5966 gfc_error ("The number of array elements of the SUB argument to "
5967 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5968 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5980 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5982 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5984 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5990 if (!type_check (distance
, 0, BT_INTEGER
))
5993 if (!nonnegative_check ("DISTANCE", distance
))
5996 if (!scalar_check (distance
, 0))
5999 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6000 "NUM_IMAGES at %L", &distance
->where
))
6006 if (!type_check (failed
, 1, BT_LOGICAL
))
6009 if (!scalar_check (failed
, 1))
6012 if (!gfc_notify_std (GFC_STD_F2018
, "FAILED= argument to "
6013 "NUM_IMAGES at %L", &failed
->where
))
6022 gfc_check_team_number (gfc_expr
*team
)
6024 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6026 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6032 if (team
->ts
.type
!= BT_DERIVED
6033 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
6034 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
6036 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
6037 "shall be of type TEAM_TYPE", &team
->where
);
6049 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
6051 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6053 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6057 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
6060 if (dim
!= NULL
&& coarray
== NULL
)
6062 gfc_error ("DIM argument without COARRAY argument not allowed for "
6063 "THIS_IMAGE intrinsic at %L", &dim
->where
);
6067 if (distance
&& (coarray
|| dim
))
6069 gfc_error ("The DISTANCE argument may not be specified together with the "
6070 "COARRAY or DIM argument in intrinsic at %L",
6075 /* Assume that we have "this_image (distance)". */
6076 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
6080 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6089 if (!type_check (distance
, 2, BT_INTEGER
))
6092 if (!nonnegative_check ("DISTANCE", distance
))
6095 if (!scalar_check (distance
, 2))
6098 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6099 "THIS_IMAGE at %L", &distance
->where
))
6105 if (!coarray_check (coarray
, 0))
6110 if (!dim_check (dim
, 1, false))
6113 if (!dim_corank_check (dim
, coarray
))
6120 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6121 by gfc_simplify_transfer. Return false if we cannot do so. */
6124 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
6125 size_t *source_size
, size_t *result_size
,
6126 size_t *result_length_p
)
6128 size_t result_elt_size
;
6130 if (source
->expr_type
== EXPR_FUNCTION
)
6133 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
6136 /* Calculate the size of the source. */
6137 if (!gfc_target_expr_size (source
, source_size
))
6140 /* Determine the size of the element. */
6141 if (!gfc_element_size (mold
, &result_elt_size
))
6144 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6145 * a scalar with the type and type parameters of MOLD shall not have a
6146 * storage size equal to zero.
6147 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6148 * If MOLD is an array and SIZE is absent, the result is an array and of
6149 * rank one. Its size is as small as possible such that its physical
6150 * representation is not shorter than that of SOURCE.
6151 * If SIZE is present, the result is an array of rank one and size SIZE.
6153 if (result_elt_size
== 0 && *source_size
> 0
6154 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6156 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6157 "array and shall not have storage size 0 when %<SOURCE%> "
6158 "argument has size greater than 0", &mold
->where
);
6162 if (result_elt_size
== 0 && *source_size
== 0 && !size
)
6165 if (result_length_p
)
6166 *result_length_p
= 0;
6170 if ((result_elt_size
> 0 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6176 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6179 result_length
= *source_size
/ result_elt_size
;
6180 if (result_length
* result_elt_size
< *source_size
)
6184 *result_size
= result_length
* result_elt_size
;
6185 if (result_length_p
)
6186 *result_length_p
= result_length
;
6189 *result_size
= result_elt_size
;
6196 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6201 if (gfc_invalid_null_arg (source
))
6204 /* SOURCE shall be a scalar or array of any type. */
6205 if (source
->ts
.type
== BT_PROCEDURE
6206 && source
->symtree
->n
.sym
->attr
.subroutine
== 1)
6208 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6209 "must not be a %s", &source
->where
,
6210 gfc_basic_typename (source
->ts
.type
));
6214 if (source
->ts
.type
== BT_BOZ
&& illegal_boz_arg (source
))
6217 if (mold
->ts
.type
== BT_BOZ
&& illegal_boz_arg (mold
))
6220 if (gfc_invalid_null_arg (mold
))
6223 /* MOLD shall be a scalar or array of any type. */
6224 if (mold
->ts
.type
== BT_PROCEDURE
6225 && mold
->symtree
->n
.sym
->attr
.subroutine
== 1)
6227 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6228 "must not be a %s", &mold
->where
,
6229 gfc_basic_typename (mold
->ts
.type
));
6233 if (mold
->ts
.type
== BT_HOLLERITH
)
6235 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6236 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
6240 /* SIZE (optional) shall be an integer scalar. The corresponding actual
6241 argument shall not be an optional dummy argument. */
6244 if (!type_check (size
, 2, BT_INTEGER
))
6246 if (size
->ts
.type
== BT_BOZ
)
6251 if (!scalar_check (size
, 2))
6254 if (!nonoptional_check (size
, 2))
6258 if (!warn_surprising
)
6261 /* If we can't calculate the sizes, we cannot check any more.
6262 Return true for that case. */
6264 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6265 &result_size
, NULL
))
6268 if (source_size
< result_size
)
6269 gfc_warning (OPT_Wsurprising
,
6270 "Intrinsic TRANSFER at %L has partly undefined result: "
6271 "source size %ld < result size %ld", &source
->where
,
6272 (long) source_size
, (long) result_size
);
6279 gfc_check_transpose (gfc_expr
*matrix
)
6281 if (!rank_check (matrix
, 0, 2))
6289 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6291 if (!array_check (array
, 0))
6294 if (!dim_check (dim
, 1, false))
6297 if (!dim_rank_check (dim
, array
, 0))
6300 if (!kind_check (kind
, 2, BT_INTEGER
))
6302 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6303 "with KIND argument at %L",
6304 gfc_current_intrinsic
, &kind
->where
))
6312 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
6314 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6316 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6320 if (!coarray_check (coarray
, 0))
6325 if (!dim_check (dim
, 1, false))
6328 if (!dim_corank_check (dim
, coarray
))
6332 if (!kind_check (kind
, 2, BT_INTEGER
))
6340 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6344 if (!rank_check (vector
, 0, 1))
6347 if (!array_check (mask
, 1))
6350 if (!type_check (mask
, 1, BT_LOGICAL
))
6353 if (!same_type_check (vector
, 0, field
, 2))
6356 gfc_simplify_expr (mask
, 0);
6358 if (mask
->expr_type
== EXPR_ARRAY
6359 && gfc_array_size (vector
, &vector_size
))
6361 int mask_true_count
= 0;
6362 gfc_constructor
*mask_ctor
;
6363 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6366 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
6368 mask_true_count
= 0;
6372 if (mask_ctor
->expr
->value
.logical
)
6375 mask_ctor
= gfc_constructor_next (mask_ctor
);
6378 if (mpz_get_si (vector_size
) < mask_true_count
)
6380 gfc_error ("%qs argument of %qs intrinsic at %L must "
6381 "provide at least as many elements as there "
6382 "are .TRUE. values in %qs (%ld/%d)",
6383 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6384 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
6385 mpz_get_si (vector_size
), mask_true_count
);
6389 mpz_clear (vector_size
);
6392 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
6394 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6395 "the same rank as %qs or be a scalar",
6396 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6397 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
6401 if (mask
->rank
== field
->rank
)
6404 for (i
= 0; i
< field
->rank
; i
++)
6405 if (! identical_dimen_shape (mask
, i
, field
, i
))
6407 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6408 "must have identical shape.",
6409 gfc_current_intrinsic_arg
[2]->name
,
6410 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6420 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
6422 if (!type_check (x
, 0, BT_CHARACTER
))
6425 if (!same_type_check (x
, 0, y
, 1))
6428 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
6431 if (!kind_check (kind
, 3, BT_INTEGER
))
6433 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6434 "with KIND argument at %L",
6435 gfc_current_intrinsic
, &kind
->where
))
6443 gfc_check_trim (gfc_expr
*x
)
6445 if (!type_check (x
, 0, BT_CHARACTER
))
6448 if (gfc_invalid_null_arg (x
))
6451 if (!scalar_check (x
, 0))
6459 gfc_check_ttynam (gfc_expr
*unit
)
6461 if (!scalar_check (unit
, 0))
6464 if (!type_check (unit
, 0, BT_INTEGER
))
6471 /************* Check functions for intrinsic subroutines *************/
6474 gfc_check_cpu_time (gfc_expr
*time
)
6476 if (!scalar_check (time
, 0))
6479 if (!type_check (time
, 0, BT_REAL
))
6482 if (!variable_check (time
, 0, false))
6490 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
6491 gfc_expr
*zone
, gfc_expr
*values
)
6495 if (!type_check (date
, 0, BT_CHARACTER
))
6497 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6499 if (!scalar_check (date
, 0))
6501 if (!variable_check (date
, 0, false))
6507 if (!type_check (time
, 1, BT_CHARACTER
))
6509 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
6511 if (!scalar_check (time
, 1))
6513 if (!variable_check (time
, 1, false))
6519 if (!type_check (zone
, 2, BT_CHARACTER
))
6521 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
6523 if (!scalar_check (zone
, 2))
6525 if (!variable_check (zone
, 2, false))
6531 if (!type_check (values
, 3, BT_INTEGER
))
6533 if (!array_check (values
, 3))
6535 if (!rank_check (values
, 3, 1))
6537 if (!variable_check (values
, 3, false))
6546 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
6547 gfc_expr
*to
, gfc_expr
*topos
)
6549 if (!type_check (from
, 0, BT_INTEGER
))
6552 if (!type_check (frompos
, 1, BT_INTEGER
))
6555 if (!type_check (len
, 2, BT_INTEGER
))
6558 if (!same_type_check (from
, 0, to
, 3))
6561 if (!variable_check (to
, 3, false))
6564 if (!type_check (topos
, 4, BT_INTEGER
))
6567 if (!nonnegative_check ("frompos", frompos
))
6570 if (!nonnegative_check ("topos", topos
))
6573 if (!nonnegative_check ("len", len
))
6576 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
6579 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
6586 /* Check the arguments for RANDOM_INIT. */
6589 gfc_check_random_init (gfc_expr
*repeatable
, gfc_expr
*image_distinct
)
6591 if (!type_check (repeatable
, 0, BT_LOGICAL
))
6594 if (!scalar_check (repeatable
, 0))
6597 if (!type_check (image_distinct
, 1, BT_LOGICAL
))
6600 if (!scalar_check (image_distinct
, 1))
6608 gfc_check_random_number (gfc_expr
*harvest
)
6610 if (!type_check (harvest
, 0, BT_REAL
))
6613 if (!variable_check (harvest
, 0, false))
6621 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
6623 unsigned int nargs
= 0, seed_size
;
6624 locus
*where
= NULL
;
6625 mpz_t put_size
, get_size
;
6627 /* Keep the number of bytes in sync with master_state in
6628 libgfortran/intrinsics/random.c. */
6629 seed_size
= 32 / gfc_default_integer_kind
;
6633 if (size
->expr_type
!= EXPR_VARIABLE
6634 || !size
->symtree
->n
.sym
->attr
.optional
)
6637 if (!scalar_check (size
, 0))
6640 if (!type_check (size
, 0, BT_INTEGER
))
6643 if (!variable_check (size
, 0, false))
6646 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
6652 if (put
->expr_type
!= EXPR_VARIABLE
6653 || !put
->symtree
->n
.sym
->attr
.optional
)
6656 where
= &put
->where
;
6659 if (!array_check (put
, 1))
6662 if (!rank_check (put
, 1, 1))
6665 if (!type_check (put
, 1, BT_INTEGER
))
6668 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
6671 if (gfc_array_size (put
, &put_size
)
6672 && mpz_get_ui (put_size
) < seed_size
)
6673 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6674 "too small (%i/%i)",
6675 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6676 &put
->where
, (int) mpz_get_ui (put_size
), seed_size
);
6681 if (get
->expr_type
!= EXPR_VARIABLE
6682 || !get
->symtree
->n
.sym
->attr
.optional
)
6685 where
= &get
->where
;
6688 if (!array_check (get
, 2))
6691 if (!rank_check (get
, 2, 1))
6694 if (!type_check (get
, 2, BT_INTEGER
))
6697 if (!variable_check (get
, 2, false))
6700 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
6703 if (gfc_array_size (get
, &get_size
)
6704 && mpz_get_ui (get_size
) < seed_size
)
6705 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6706 "too small (%i/%i)",
6707 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6708 &get
->where
, (int) mpz_get_ui (get_size
), seed_size
);
6711 /* RANDOM_SEED may not have more than one non-optional argument. */
6713 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
6719 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
6723 int num_percent
, nargs
;
6726 if (e
->expr_type
!= EXPR_CONSTANT
)
6729 len
= e
->value
.character
.length
;
6730 if (e
->value
.character
.string
[len
-1] != '\0')
6731 gfc_internal_error ("fe_runtime_error string must be null terminated");
6734 for (i
=0; i
<len
-1; i
++)
6735 if (e
->value
.character
.string
[i
] == '%')
6739 for (; a
; a
= a
->next
)
6742 if (nargs
-1 != num_percent
)
6743 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6744 nargs
, num_percent
++);
6750 gfc_check_second_sub (gfc_expr
*time
)
6752 if (!scalar_check (time
, 0))
6755 if (!type_check (time
, 0, BT_REAL
))
6758 if (!kind_value_check (time
, 0, 4))
6765 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6766 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6767 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6768 count_max are all optional arguments */
6771 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
6772 gfc_expr
*count_max
)
6776 if (!scalar_check (count
, 0))
6779 if (!type_check (count
, 0, BT_INTEGER
))
6782 if (count
->ts
.kind
!= gfc_default_integer_kind
6783 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
6784 "SYSTEM_CLOCK at %L has non-default kind",
6788 if (!variable_check (count
, 0, false))
6792 if (count_rate
!= NULL
)
6794 if (!scalar_check (count_rate
, 1))
6797 if (!variable_check (count_rate
, 1, false))
6800 if (count_rate
->ts
.type
== BT_REAL
)
6802 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
6803 "SYSTEM_CLOCK at %L", &count_rate
->where
))
6808 if (!type_check (count_rate
, 1, BT_INTEGER
))
6811 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6812 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6813 "SYSTEM_CLOCK at %L has non-default kind",
6814 &count_rate
->where
))
6820 if (count_max
!= NULL
)
6822 if (!scalar_check (count_max
, 2))
6825 if (!type_check (count_max
, 2, BT_INTEGER
))
6828 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6829 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6830 "SYSTEM_CLOCK at %L has non-default kind",
6834 if (!variable_check (count_max
, 2, false))
6843 gfc_check_irand (gfc_expr
*x
)
6848 if (!scalar_check (x
, 0))
6851 if (!type_check (x
, 0, BT_INTEGER
))
6854 if (!kind_value_check (x
, 0, 4))
6862 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6864 if (!scalar_check (seconds
, 0))
6866 if (!type_check (seconds
, 0, BT_INTEGER
))
6869 if (!int_or_proc_check (handler
, 1))
6871 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6877 if (!scalar_check (status
, 2))
6879 if (!type_check (status
, 2, BT_INTEGER
))
6881 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6889 gfc_check_rand (gfc_expr
*x
)
6894 if (!scalar_check (x
, 0))
6897 if (!type_check (x
, 0, BT_INTEGER
))
6900 if (!kind_value_check (x
, 0, 4))
6908 gfc_check_srand (gfc_expr
*x
)
6910 if (!scalar_check (x
, 0))
6913 if (!type_check (x
, 0, BT_INTEGER
))
6916 if (!kind_value_check (x
, 0, 4))
6924 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6926 if (!scalar_check (time
, 0))
6928 if (!type_check (time
, 0, BT_INTEGER
))
6931 if (!type_check (result
, 1, BT_CHARACTER
))
6933 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6941 gfc_check_dtime_etime (gfc_expr
*x
)
6943 if (!array_check (x
, 0))
6946 if (!rank_check (x
, 0, 1))
6949 if (!variable_check (x
, 0, false))
6952 if (!type_check (x
, 0, BT_REAL
))
6955 if (!kind_value_check (x
, 0, 4))
6963 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6965 if (!array_check (values
, 0))
6968 if (!rank_check (values
, 0, 1))
6971 if (!variable_check (values
, 0, false))
6974 if (!type_check (values
, 0, BT_REAL
))
6977 if (!kind_value_check (values
, 0, 4))
6980 if (!scalar_check (time
, 1))
6983 if (!type_check (time
, 1, BT_REAL
))
6986 if (!kind_value_check (time
, 1, 4))
6994 gfc_check_fdate_sub (gfc_expr
*date
)
6996 if (!type_check (date
, 0, BT_CHARACTER
))
6998 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
7006 gfc_check_gerror (gfc_expr
*msg
)
7008 if (!type_check (msg
, 0, BT_CHARACTER
))
7010 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7018 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
7020 if (!type_check (cwd
, 0, BT_CHARACTER
))
7022 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
7028 if (!scalar_check (status
, 1))
7031 if (!type_check (status
, 1, BT_INTEGER
))
7039 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
7041 if (!type_check (pos
, 0, BT_INTEGER
))
7044 if (pos
->ts
.kind
> gfc_default_integer_kind
)
7046 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
7047 "not wider than the default kind (%d)",
7048 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7049 &pos
->where
, gfc_default_integer_kind
);
7053 if (!type_check (value
, 1, BT_CHARACTER
))
7055 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
7063 gfc_check_getlog (gfc_expr
*msg
)
7065 if (!type_check (msg
, 0, BT_CHARACTER
))
7067 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7075 gfc_check_exit (gfc_expr
*status
)
7080 if (!type_check (status
, 0, BT_INTEGER
))
7083 if (!scalar_check (status
, 0))
7091 gfc_check_flush (gfc_expr
*unit
)
7096 if (!type_check (unit
, 0, BT_INTEGER
))
7099 if (!scalar_check (unit
, 0))
7107 gfc_check_free (gfc_expr
*i
)
7109 if (!type_check (i
, 0, BT_INTEGER
))
7112 if (!scalar_check (i
, 0))
7120 gfc_check_hostnm (gfc_expr
*name
)
7122 if (!type_check (name
, 0, BT_CHARACTER
))
7124 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7132 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
7134 if (!type_check (name
, 0, BT_CHARACTER
))
7136 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7142 if (!scalar_check (status
, 1))
7145 if (!type_check (status
, 1, BT_INTEGER
))
7153 gfc_check_itime_idate (gfc_expr
*values
)
7155 if (!array_check (values
, 0))
7158 if (!rank_check (values
, 0, 1))
7161 if (!variable_check (values
, 0, false))
7164 if (!type_check (values
, 0, BT_INTEGER
))
7167 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
7175 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
7177 if (!type_check (time
, 0, BT_INTEGER
))
7180 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
7183 if (!scalar_check (time
, 0))
7186 if (!array_check (values
, 1))
7189 if (!rank_check (values
, 1, 1))
7192 if (!variable_check (values
, 1, false))
7195 if (!type_check (values
, 1, BT_INTEGER
))
7198 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
7206 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
7208 if (!scalar_check (unit
, 0))
7211 if (!type_check (unit
, 0, BT_INTEGER
))
7214 if (!type_check (name
, 1, BT_CHARACTER
))
7216 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
7224 gfc_check_is_contiguous (gfc_expr
*array
)
7226 if (array
->expr_type
== EXPR_NULL
)
7228 gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7229 "associated pointer", &array
->where
, gfc_current_intrinsic
);
7233 if (!array_check (array
, 0))
7241 gfc_check_isatty (gfc_expr
*unit
)
7246 if (!type_check (unit
, 0, BT_INTEGER
))
7249 if (!scalar_check (unit
, 0))
7257 gfc_check_isnan (gfc_expr
*x
)
7259 if (!type_check (x
, 0, BT_REAL
))
7267 gfc_check_perror (gfc_expr
*string
)
7269 if (!type_check (string
, 0, BT_CHARACTER
))
7271 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
7279 gfc_check_umask (gfc_expr
*mask
)
7281 if (!type_check (mask
, 0, BT_INTEGER
))
7284 if (!scalar_check (mask
, 0))
7292 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
7294 if (!type_check (mask
, 0, BT_INTEGER
))
7297 if (!scalar_check (mask
, 0))
7303 if (!scalar_check (old
, 1))
7306 if (!type_check (old
, 1, BT_INTEGER
))
7314 gfc_check_unlink (gfc_expr
*name
)
7316 if (!type_check (name
, 0, BT_CHARACTER
))
7318 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7326 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
7328 if (!type_check (name
, 0, BT_CHARACTER
))
7330 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7336 if (!scalar_check (status
, 1))
7339 if (!type_check (status
, 1, BT_INTEGER
))
7347 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
7349 if (!scalar_check (number
, 0))
7351 if (!type_check (number
, 0, BT_INTEGER
))
7354 if (!int_or_proc_check (handler
, 1))
7356 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7364 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
7366 if (!scalar_check (number
, 0))
7368 if (!type_check (number
, 0, BT_INTEGER
))
7371 if (!int_or_proc_check (handler
, 1))
7373 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7379 if (!type_check (status
, 2, BT_INTEGER
))
7381 if (!scalar_check (status
, 2))
7389 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
7391 if (!type_check (cmd
, 0, BT_CHARACTER
))
7393 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
7396 if (!scalar_check (status
, 1))
7399 if (!type_check (status
, 1, BT_INTEGER
))
7402 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
7409 /* This is used for the GNU intrinsics AND, OR and XOR. */
7411 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
7413 if (i
->ts
.type
!= BT_INTEGER
7414 && i
->ts
.type
!= BT_LOGICAL
7415 && i
->ts
.type
!= BT_BOZ
)
7417 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7418 "LOGICAL, or a BOZ literal constant",
7419 gfc_current_intrinsic_arg
[0]->name
,
7420 gfc_current_intrinsic
, &i
->where
);
7424 if (j
->ts
.type
!= BT_INTEGER
7425 && j
->ts
.type
!= BT_LOGICAL
7426 && j
->ts
.type
!= BT_BOZ
)
7428 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7429 "LOGICAL, or a BOZ literal constant",
7430 gfc_current_intrinsic_arg
[1]->name
,
7431 gfc_current_intrinsic
, &j
->where
);
7435 /* i and j cannot both be BOZ literal constants. */
7436 if (!boz_args_check (i
, j
))
7439 /* If i is BOZ and j is integer, convert i to type of j. */
7440 if (i
->ts
.type
== BT_BOZ
)
7442 if (j
->ts
.type
!= BT_INTEGER
)
7444 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7445 gfc_current_intrinsic_arg
[1]->name
,
7446 gfc_current_intrinsic
, &j
->where
);
7450 if (!gfc_boz2int (i
, j
->ts
.kind
))
7454 /* If j is BOZ and i is integer, convert j to type of i. */
7455 if (j
->ts
.type
== BT_BOZ
)
7457 if (i
->ts
.type
!= BT_INTEGER
)
7459 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7460 gfc_current_intrinsic_arg
[0]->name
,
7461 gfc_current_intrinsic
, &j
->where
);
7465 if (!gfc_boz2int (j
, i
->ts
.kind
))
7469 if (!same_type_check (i
, 0, j
, 1, false))
7472 if (!scalar_check (i
, 0))
7475 if (!scalar_check (j
, 1))
7483 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
7486 if (a
->expr_type
== EXPR_NULL
)
7488 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7489 "argument to STORAGE_SIZE, because it returns a "
7490 "disassociated pointer", &a
->where
);
7494 if (a
->ts
.type
== BT_ASSUMED
)
7496 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7497 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7502 if (a
->ts
.type
== BT_PROCEDURE
)
7504 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7505 "procedure", gfc_current_intrinsic_arg
[0]->name
,
7506 gfc_current_intrinsic
, &a
->where
);
7510 if (a
->ts
.type
== BT_BOZ
&& illegal_boz_arg (a
))
7516 if (!type_check (kind
, 1, BT_INTEGER
))
7519 if (!scalar_check (kind
, 1))
7522 if (kind
->expr_type
!= EXPR_CONSTANT
)
7524 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7525 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,