2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
30 #include "coretypes.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Reset a BOZ to a zero value. This is used to prevent run-on errors
39 from resolve.cc(resolve_function). */
42 reset_boz (gfc_expr
*x
)
49 x
->ts
.type
= BT_INTEGER
;
50 x
->ts
.kind
= gfc_default_integer_kind
;
51 mpz_init (x
->value
.integer
);
52 mpz_set_ui (x
->value
.integer
, 0);
55 /* A BOZ literal constant can appear in a limited number of contexts.
56 gfc_invalid_boz() is a helper function to simplify error/warning
57 generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran
58 allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz
59 is used, then issue a warning; otherwise issue an error. */
62 gfc_invalid_boz (const char *msg
, locus
*loc
)
64 if (flag_allow_invalid_boz
)
66 gfc_warning (0, msg
, loc
);
70 const char *hint
= _(" [see %<-fno-allow-invalid-boz%>]");
71 size_t len
= strlen (msg
) + strlen (hint
) + 1;
72 char *msg2
= (char *) alloca (len
);
75 gfc_error (msg2
, loc
);
80 /* Issue an error for an illegal BOZ argument. */
83 illegal_boz_arg (gfc_expr
*x
)
85 if (x
->ts
.type
== BT_BOZ
)
87 gfc_error ("BOZ literal constant at %L cannot be an actual argument "
88 "to %qs", &x
->where
, gfc_current_intrinsic
);
96 /* Some procedures take two arguments such that both cannot be BOZ. */
99 boz_args_check(gfc_expr
*i
, gfc_expr
*j
)
101 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_BOZ
)
103 gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
104 "literal constants", gfc_current_intrinsic
, &i
->where
,
116 /* Check that a BOZ is a constant. */
119 is_boz_constant (gfc_expr
*a
)
121 if (a
->expr_type
!= EXPR_CONSTANT
)
123 gfc_error ("Invalid use of BOZ literal constant at %L", &a
->where
);
131 /* Convert a octal string into a binary string. This is used in the
132 fallback conversion of an octal string to a REAL. */
135 oct2bin(int nbits
, char *oct
)
137 const char bits
[8][5] = {
138 "000", "001", "010", "011", "100", "101", "110", "111"};
144 if (nbits
== 64) j
++;
146 bufp
= buf
= XCNEWVEC (char, j
+ 1);
147 memset (bufp
, 0, j
+ 1);
150 for (i
= 0; i
< n
; i
++, oct
++)
153 strcpy (bufp
, &bits
[j
][0]);
157 bufp
= XCNEWVEC (char, nbits
+ 1);
159 strcpy (bufp
, buf
+ 2);
161 strcpy (bufp
, buf
+ 1);
169 /* Convert a hexidecimal string into a binary string. This is used in the
170 fallback conversion of a hexidecimal string to a REAL. */
173 hex2bin(int nbits
, char *hex
)
175 const char bits
[16][5] = {
176 "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111",
177 "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"};
182 bufp
= buf
= XCNEWVEC (char, nbits
+ 1);
183 memset (bufp
, 0, nbits
+ 1);
186 for (i
= 0; i
< n
; i
++, hex
++)
189 if (j
> 47 && j
< 58)
191 else if (j
> 64 && j
< 71)
193 else if (j
> 96 && j
< 103)
198 strcpy (bufp
, &bits
[j
][0]);
206 /* Fallback conversion of a BOZ string to REAL. */
209 bin2real (gfc_expr
*x
, int kind
)
216 i
= gfc_validate_kind (BT_REAL
, kind
, false);
217 t
= gfc_real_kinds
[i
].digits
- 1;
219 /* Number of bits in the exponent. */
220 if (gfc_real_kinds
[i
].max_exponent
== 16384)
222 else if (gfc_real_kinds
[i
].max_exponent
== 1024)
227 if (x
->boz
.rdx
== 16)
228 sp
= hex2bin (gfc_real_kinds
[i
].mode_precision
, x
->boz
.str
);
229 else if (x
->boz
.rdx
== 8)
230 sp
= oct2bin (gfc_real_kinds
[i
].mode_precision
, x
->boz
.str
);
234 /* Extract sign bit. */
237 /* Extract biased exponent. */
238 memset (buf
, 0, 114);
239 strncpy (buf
, ++sp
, w
);
241 mpz_set_str (em
, buf
, 2);
242 ie
= mpz_get_si (em
);
244 mpfr_init2 (x
->value
.real
, t
+ 1);
245 x
->ts
.type
= BT_REAL
;
248 sp
+= w
; /* Set to first digit in significand. */
250 if ((i
== 0 && ie
== b
) || (i
== 1 && ie
== b
)
251 || ((i
== 2 || i
== 3) && ie
== b
))
265 mpfr_set_inf (x
->value
.real
, 1);
267 mpfr_set_nan (x
->value
.real
);
272 strncpy (buf
, sp
, t
+ 1);
275 /* Significand with hidden bit. */
277 strncpy (&buf
[1], sp
, t
);
280 /* Convert to significand to integer. */
281 mpz_set_str (em
, buf
, 2);
282 ie
-= ((1 << (w
- 1)) - 1); /* Unbiased exponent. */
283 mpfr_set_z_2exp (x
->value
.real
, em
, ie
- t
, GFC_RND_MODE
);
286 if (sgn
) mpfr_neg (x
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
292 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
293 converts the string into a REAL of the appropriate kind. The treatment
294 of the sign bit is processor dependent. */
297 gfc_boz2real (gfc_expr
*x
, int kind
)
299 extern int gfc_max_integer_kind
;
304 if (!is_boz_constant (x
))
307 /* Determine the length of the required string. */
309 if (x
->boz
.rdx
== 16) len
/= 4;
310 if (x
->boz
.rdx
== 8) len
= len
/ 3 + 1;
311 buf
= (char *) alloca (len
+ 1); /* +1 for NULL terminator. */
313 if (x
->boz
.len
>= len
) /* Truncate if necessary. */
315 str
= x
->boz
.str
+ (x
->boz
.len
- len
);
318 else /* Copy and pad. */
320 memset (buf
, 48, len
);
321 str
= buf
+ (len
- x
->boz
.len
);
322 strcpy (str
, x
->boz
.str
);
325 /* Need to adjust leading bits in an octal string. */
328 /* Clear first bit. */
329 if (kind
== 4 || kind
== 10 || kind
== 16)
333 else if (buf
[0] == '5')
335 else if (buf
[0] == '6')
337 else if (buf
[0] == '7')
340 /* Clear first two bits. */
343 if (buf
[0] == '2' || buf
[0] == '4' || buf
[0] == '6')
345 else if (buf
[0] == '3' || buf
[0] == '5' || buf
[0] == '7')
350 /* Reset BOZ string to the truncated or padded version. */
353 x
->boz
.str
= XCNEWVEC (char, len
+ 1);
354 strncpy (x
->boz
.str
, buf
, len
);
356 /* For some targets, the largest INTEGER in terms of bits is smaller than
357 the bits needed to hold the REAL. Fortunately, the kind type parameter
358 indicates the number of bytes required to an INTEGER and a REAL. */
359 if (gfc_max_integer_kind
< kind
)
365 /* Convert to widest possible integer. */
366 gfc_boz2int (x
, gfc_max_integer_kind
);
369 if (!gfc_convert_boz (x
, &ts
))
371 gfc_error ("Failure in conversion of BOZ to REAL at %L", &x
->where
);
380 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int ()
381 converts the string into an INTEGER of the appropriate kind. The
382 treatment of the sign bit is processor dependent. If the converted
383 value exceeds the range of the type, then wrap-around semantics are
387 gfc_boz2int (gfc_expr
*x
, int kind
)
393 if (!is_boz_constant (x
))
396 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
397 len
= gfc_integer_kinds
[i
].bit_size
;
398 if (x
->boz
.rdx
== 16) len
/= 4;
399 if (x
->boz
.rdx
== 8) len
= len
/ 3 + 1;
400 buf
= (char *) alloca (len
+ 1); /* +1 for NULL terminator. */
402 if (x
->boz
.len
>= len
) /* Truncate if necessary. */
404 str
= x
->boz
.str
+ (x
->boz
.len
- len
);
407 else /* Copy and pad. */
409 memset (buf
, 48, len
);
410 str
= buf
+ (len
- x
->boz
.len
);
411 strcpy (str
, x
->boz
.str
);
414 /* Need to adjust leading bits in an octal string. */
417 /* Clear first bit. */
418 if (kind
== 1 || kind
== 4 || kind
== 16)
422 else if (buf
[0] == '5')
424 else if (buf
[0] == '6')
426 else if (buf
[0] == '7')
429 /* Clear first two bits. */
432 if (buf
[0] == '2' || buf
[0] == '4' || buf
[0] == '6')
434 else if (buf
[0] == '3' || buf
[0] == '5' || buf
[0] == '7')
439 /* Convert as-if unsigned integer. */
441 mpz_set_str (tmp1
, buf
, x
->boz
.rdx
);
443 /* Check for wrap-around. */
444 if (mpz_cmp (tmp1
, gfc_integer_kinds
[i
].huge
) > 0)
448 mpz_add_ui (tmp2
, gfc_integer_kinds
[i
].huge
, 1);
449 mpz_mod (tmp1
, tmp1
, tmp2
);
450 mpz_sub (tmp1
, tmp1
, tmp2
);
454 /* Clear boz info. */
459 mpz_init (x
->value
.integer
);
460 mpz_set (x
->value
.integer
, tmp1
);
461 x
->ts
.type
= BT_INTEGER
;
469 /* Make sure an expression is a scalar. */
472 scalar_check (gfc_expr
*e
, int n
)
477 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
478 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
485 /* Check the type of an expression. */
488 type_check (gfc_expr
*e
, int n
, bt type
)
490 if (e
->ts
.type
== type
)
493 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
494 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
495 &e
->where
, gfc_basic_typename (type
));
501 /* Check that the expression is a numeric type. */
504 numeric_check (gfc_expr
*e
, int n
)
506 /* Users sometime use a subroutine designator as an actual argument to
507 an intrinsic subprogram that expects an argument with a numeric type. */
508 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
511 if (gfc_numeric_ts (&e
->ts
))
514 /* If the expression has not got a type, check if its namespace can
515 offer a default type. */
516 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
517 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
518 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
519 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
521 e
->ts
= e
->symtree
->n
.sym
->ts
;
527 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
528 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
535 /* Check that an expression is integer or real. */
538 int_or_real_check (gfc_expr
*e
, int n
)
540 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
542 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
543 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
544 gfc_current_intrinsic
, &e
->where
);
551 /* Check that an expression is integer or real; allow character for
555 int_or_real_or_char_check_f2003 (gfc_expr
*e
, int n
)
557 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
559 if (e
->ts
.type
== BT_CHARACTER
)
560 return gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Character for "
561 "%qs argument of %qs intrinsic at %L",
562 gfc_current_intrinsic_arg
[n
]->name
,
563 gfc_current_intrinsic
, &e
->where
);
566 if (gfc_option
.allow_std
& GFC_STD_F2003
)
567 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
568 "or REAL or CHARACTER",
569 gfc_current_intrinsic_arg
[n
]->name
,
570 gfc_current_intrinsic
, &e
->where
);
572 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
573 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
574 gfc_current_intrinsic
, &e
->where
);
582 /* Check that an expression is an intrinsic type. */
584 intrinsic_type_check (gfc_expr
*e
, int n
)
586 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
587 && e
->ts
.type
!= BT_COMPLEX
&& e
->ts
.type
!= BT_CHARACTER
588 && e
->ts
.type
!= BT_LOGICAL
)
590 gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
591 gfc_current_intrinsic_arg
[n
]->name
,
592 gfc_current_intrinsic
, &e
->where
);
598 /* Check that an expression is real or complex. */
601 real_or_complex_check (gfc_expr
*e
, int n
)
603 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
605 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
606 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
607 gfc_current_intrinsic
, &e
->where
);
615 /* Check that an expression is INTEGER or PROCEDURE. */
618 int_or_proc_check (gfc_expr
*e
, int n
)
620 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
622 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
623 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
624 gfc_current_intrinsic
, &e
->where
);
632 /* Check that the expression is an optional constant integer
633 and that it specifies a valid kind for that type. */
636 kind_check (gfc_expr
*k
, int n
, bt type
)
643 if (!type_check (k
, n
, BT_INTEGER
))
646 if (!scalar_check (k
, n
))
649 if (!gfc_check_init_expr (k
))
651 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
652 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
657 if (gfc_extract_int (k
, &kind
)
658 || gfc_validate_kind (type
, kind
, true) < 0)
660 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
669 /* Make sure the expression is a double precision real. */
672 double_check (gfc_expr
*d
, int n
)
674 if (!type_check (d
, n
, BT_REAL
))
677 if (d
->ts
.kind
!= gfc_default_double_kind
)
679 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
680 "precision", gfc_current_intrinsic_arg
[n
]->name
,
681 gfc_current_intrinsic
, &d
->where
);
690 coarray_check (gfc_expr
*e
, int n
)
692 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
693 && CLASS_DATA (e
)->attr
.codimension
694 && CLASS_DATA (e
)->as
->corank
)
696 gfc_add_class_array_ref (e
);
700 if (!gfc_is_coarray (e
))
702 gfc_error ("Expected coarray variable as %qs argument to the %s "
703 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
704 gfc_current_intrinsic
, &e
->where
);
712 /* Make sure the expression is a logical array. */
715 logical_array_check (gfc_expr
*array
, int n
)
717 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
719 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
720 "array", gfc_current_intrinsic_arg
[n
]->name
,
721 gfc_current_intrinsic
, &array
->where
);
729 /* Make sure an expression is an array. */
732 array_check (gfc_expr
*e
, int n
)
734 if (e
->rank
!= 0 && e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
735 && CLASS_DATA (e
)->attr
.dimension
736 && CLASS_DATA (e
)->as
->rank
)
738 gfc_add_class_array_ref (e
);
741 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
744 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
745 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
752 /* If expr is a constant, then check to ensure that it is greater than
756 nonnegative_check (const char *arg
, gfc_expr
*expr
)
760 if (expr
->expr_type
== EXPR_CONSTANT
)
762 gfc_extract_int (expr
, &i
);
765 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
774 /* If expr is a constant, then check to ensure that it is greater than zero. */
777 positive_check (int n
, gfc_expr
*expr
)
781 if (expr
->expr_type
== EXPR_CONSTANT
)
783 gfc_extract_int (expr
, &i
);
786 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
787 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
797 /* If expr2 is constant, then check that the value is less than
798 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
801 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
802 gfc_expr
*expr2
, bool or_equal
)
806 if (expr2
->expr_type
== EXPR_CONSTANT
)
808 gfc_extract_int (expr2
, &i2
);
809 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
811 /* For ISHFT[C], check that |shift| <= bit_size(i). */
817 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
819 gfc_error ("The absolute value of SHIFT at %L must be less "
820 "than or equal to BIT_SIZE(%qs)",
821 &expr2
->where
, arg1
);
828 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
830 gfc_error ("%qs at %L must be less than "
831 "or equal to BIT_SIZE(%qs)",
832 arg2
, &expr2
->where
, arg1
);
838 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
840 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
841 arg2
, &expr2
->where
, arg1
);
851 /* If expr is constant, then check that the value is less than or equal
852 to the bit_size of the kind k. */
855 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
859 if (expr
->expr_type
!= EXPR_CONSTANT
)
862 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
863 gfc_extract_int (expr
, &val
);
865 if (val
> gfc_integer_kinds
[i
].bit_size
)
867 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
868 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
876 /* If expr2 and expr3 are constants, then check that the value is less than
877 or equal to bit_size(expr1). */
880 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
881 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
885 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
887 gfc_extract_int (expr2
, &i2
);
888 gfc_extract_int (expr3
, &i3
);
890 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
891 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
893 gfc_error ("%<%s + %s%> at %L must be less than or equal "
895 arg2
, arg3
, &expr2
->where
, arg1
);
903 /* Make sure two expressions have the same type. */
906 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
, bool assoc
= false)
908 gfc_typespec
*ets
= &e
->ts
;
909 gfc_typespec
*fts
= &f
->ts
;
913 /* Procedure pointer component expressions have the type of the interface
914 procedure. If they are being tested for association with a procedure
915 pointer (ie. not a component), the type of the procedure must be
917 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
918 ets
= &e
->symtree
->n
.sym
->ts
;
919 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
920 fts
= &f
->symtree
->n
.sym
->ts
;
923 if (gfc_compare_types (ets
, fts
))
926 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
927 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
928 gfc_current_intrinsic
, &f
->where
,
929 gfc_current_intrinsic_arg
[n
]->name
);
935 /* Make sure that an expression has a certain (nonzero) rank. */
938 rank_check (gfc_expr
*e
, int n
, int rank
)
943 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
944 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
951 /* Make sure a variable expression is not an optional dummy argument. */
954 nonoptional_check (gfc_expr
*e
, int n
)
956 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
958 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
959 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
963 /* TODO: Recursive check on nonoptional variables? */
969 /* Check for ALLOCATABLE attribute. */
972 allocatable_check (gfc_expr
*e
, int n
)
974 symbol_attribute attr
;
976 attr
= gfc_variable_attr (e
, NULL
);
977 if (!attr
.allocatable
978 || (attr
.associate_var
&& !attr
.select_rank_temporary
))
980 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
981 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
990 /* Check that an expression has a particular kind. */
993 kind_value_check (gfc_expr
*e
, int n
, int k
)
998 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
999 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
1006 /* Make sure an expression is a variable. */
1009 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
1011 if (e
->expr_type
== EXPR_VARIABLE
1012 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
1013 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
1014 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
)
1015 && !gfc_check_vardef_context (e
, false, true, false, NULL
))
1017 gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
1018 gfc_current_intrinsic_arg
[n
]->name
,
1019 gfc_current_intrinsic
, &e
->where
);
1023 if (e
->expr_type
== EXPR_VARIABLE
1024 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
1025 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
1028 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
1029 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
1032 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1033 if (ns
->proc_name
== e
->symtree
->n
.sym
)
1037 /* F2018:R902: function reference having a data pointer result. */
1038 if (e
->expr_type
== EXPR_FUNCTION
1039 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1040 && e
->symtree
->n
.sym
->attr
.function
1041 && e
->symtree
->n
.sym
->attr
.pointer
)
1044 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
1045 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
1051 /* Check the common DIM parameter for correctness. */
1054 dim_check (gfc_expr
*dim
, int n
, bool optional
)
1059 if (!type_check (dim
, n
, BT_INTEGER
))
1062 if (!scalar_check (dim
, n
))
1065 if (!optional
&& !nonoptional_check (dim
, n
))
1072 /* If a coarray DIM parameter is a constant, make sure that it is greater than
1073 zero and less than or equal to the corank of the given array. */
1076 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
1080 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
1082 if (dim
->expr_type
!= EXPR_CONSTANT
)
1085 if (array
->ts
.type
== BT_CLASS
)
1088 corank
= gfc_get_corank (array
);
1090 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1091 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
1093 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1094 "codimension index", gfc_current_intrinsic
, &dim
->where
);
1103 /* If a DIM parameter is a constant, make sure that it is greater than
1104 zero and less than or equal to the rank of the given array. If
1105 allow_assumed is zero then dim must be less than the rank of the array
1106 for assumed size arrays. */
1109 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
1117 if (dim
->expr_type
!= EXPR_CONSTANT
)
1120 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
1121 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
1122 rank
= array
->rank
+ 1;
1126 /* Assumed-rank array. */
1128 rank
= GFC_MAX_DIMENSIONS
;
1130 if (array
->expr_type
== EXPR_VARIABLE
)
1132 ar
= gfc_find_array_ref (array
, true);
1135 if (ar
->as
->type
== AS_ASSUMED_SIZE
1137 && ar
->type
!= AR_ELEMENT
1138 && ar
->type
!= AR_SECTION
)
1142 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1143 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
1145 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1146 "dimension index", gfc_current_intrinsic
, &dim
->where
);
1155 /* Compare the size of a along dimension ai with the size of b along
1156 dimension bi, returning 0 if they are known not to be identical,
1157 and 1 if they are identical, or if this cannot be determined. */
1160 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
1162 mpz_t a_size
, b_size
;
1165 gcc_assert (a
->rank
> ai
);
1166 gcc_assert (b
->rank
> bi
);
1170 if (gfc_array_dimen_size (a
, ai
, &a_size
))
1172 if (gfc_array_dimen_size (b
, bi
, &b_size
))
1174 if (mpz_cmp (a_size
, b_size
) != 0)
1184 /* Calculate the length of a character variable, including substrings.
1185 Strip away parentheses if necessary. Return -1 if no length could
1189 gfc_var_strlen (const gfc_expr
*a
)
1193 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
1194 a
= a
->value
.op
.op1
;
1196 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
1201 long start_a
, end_a
;
1206 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1207 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1209 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
1211 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
1212 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
1214 else if (ra
->u
.ss
.start
1215 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
1221 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
1222 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1223 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
1224 else if (a
->expr_type
== EXPR_CONSTANT
1225 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
1226 return a
->value
.character
.length
;
1232 /* Check whether two character expressions have the same length;
1233 returns true if they have or if the length cannot be determined,
1234 otherwise return false and raise a gfc_error. */
1237 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
1241 len_a
= gfc_var_strlen(a
);
1242 len_b
= gfc_var_strlen(b
);
1244 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
1248 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
1249 len_a
, len_b
, name
, &a
->where
);
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
;
3891 ap
->next
->next
->next
->next
->name
= gfc_get_string ("back");
3894 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3895 && ap
->next
->name
== NULL
)
3899 ap
->next
->expr
= NULL
;
3900 ap
->next
->next
->expr
= m
;
3903 if (!dim_check (d
, 1, false))
3906 if (!dim_rank_check (d
, a
, 0))
3909 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3913 && !gfc_check_conformance (a
, m
,
3914 _("arguments '%s' and '%s' for intrinsic %s"),
3915 gfc_current_intrinsic_arg
[0]->name
,
3916 gfc_current_intrinsic_arg
[2]->name
,
3917 gfc_current_intrinsic
))
3920 if (!kind_check (k
, 1, BT_INTEGER
))
3926 /* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3927 above, with the additional "value" argument. */
3930 gfc_check_findloc (gfc_actual_arglist
*ap
)
3932 gfc_expr
*a
, *v
, *m
, *d
, *k
, *b
;
3936 if (!intrinsic_type_check (a
, 0) || !array_check (a
, 0))
3940 if (!intrinsic_type_check (v
, 1) || !scalar_check (v
,1))
3943 /* Check if the type are both logical. */
3944 a1
= a
->ts
.type
== BT_LOGICAL
;
3945 v1
= v
->ts
.type
== BT_LOGICAL
;
3946 if ((a1
&& !v1
) || (!a1
&& v1
))
3949 /* Check if the type are both character. */
3950 a1
= a
->ts
.type
== BT_CHARACTER
;
3951 v1
= v
->ts
.type
== BT_CHARACTER
;
3952 if ((a1
&& !v1
) || (!a1
&& v1
))
3955 /* Check the kind of the characters argument match. */
3956 if (a1
&& v1
&& a
->ts
.kind
!= v
->ts
.kind
)
3959 d
= ap
->next
->next
->expr
;
3960 m
= ap
->next
->next
->next
->expr
;
3961 k
= ap
->next
->next
->next
->next
->expr
;
3962 b
= ap
->next
->next
->next
->next
->next
->expr
;
3966 if (!type_check (b
, 5, BT_LOGICAL
) || !scalar_check (b
,4))
3971 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3972 ap
->next
->next
->next
->next
->next
->expr
= b
;
3973 ap
->next
->next
->next
->next
->next
->name
= gfc_get_string ("back");
3976 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3977 && ap
->next
->name
== NULL
)
3981 ap
->next
->next
->expr
= NULL
;
3982 ap
->next
->next
->next
->expr
= m
;
3985 if (!dim_check (d
, 2, false))
3988 if (!dim_rank_check (d
, a
, 0))
3991 if (m
!= NULL
&& !type_check (m
, 3, BT_LOGICAL
))
3995 && !gfc_check_conformance (a
, m
,
3996 _("arguments '%s' and '%s' for intrinsic %s"),
3997 gfc_current_intrinsic_arg
[0]->name
,
3998 gfc_current_intrinsic_arg
[3]->name
,
3999 gfc_current_intrinsic
))
4002 if (!kind_check (k
, 1, BT_INTEGER
))
4008 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4009 "conformance to argument %qs at %L",
4010 gfc_current_intrinsic_arg
[0]->name
,
4011 gfc_current_intrinsic
, &a
->where
,
4012 gfc_current_intrinsic_arg
[1]->name
, &v
->where
);
4017 /* Similar to minloc/maxloc, the argument list might need to be
4018 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4019 difference is that MINLOC/MAXLOC take an additional KIND argument.
4020 The possibilities are:
4026 NULL MASK minval(array, mask=m)
4029 I.e. in the case of minval(array,mask), mask will be in the second
4030 position of the argument list and we'll have to fix that up. */
4033 check_reduction (gfc_actual_arglist
*ap
)
4035 gfc_expr
*a
, *m
, *d
;
4039 m
= ap
->next
->next
->expr
;
4041 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
4042 && ap
->next
->name
== NULL
)
4046 ap
->next
->expr
= NULL
;
4047 ap
->next
->next
->expr
= m
;
4050 if (!dim_check (d
, 1, false))
4053 if (!dim_rank_check (d
, a
, 0))
4056 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
4060 && !gfc_check_conformance (a
, m
,
4061 _("arguments '%s' and '%s' for intrinsic %s"),
4062 gfc_current_intrinsic_arg
[0]->name
,
4063 gfc_current_intrinsic_arg
[2]->name
,
4064 gfc_current_intrinsic
))
4072 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
4074 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
4075 || !array_check (ap
->expr
, 0))
4078 return check_reduction (ap
);
4083 gfc_check_product_sum (gfc_actual_arglist
*ap
)
4085 if (!numeric_check (ap
->expr
, 0)
4086 || !array_check (ap
->expr
, 0))
4089 return check_reduction (ap
);
4093 /* For IANY, IALL and IPARITY. */
4096 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
4100 if (!type_check (i
, 0, BT_INTEGER
))
4103 if (!nonnegative_check ("I", i
))
4106 if (!kind_check (kind
, 1, BT_INTEGER
))
4110 gfc_extract_int (kind
, &k
);
4112 k
= gfc_default_integer_kind
;
4114 if (!less_than_bitsizekind ("I", i
, k
))
4122 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
4124 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
4126 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4127 gfc_current_intrinsic_arg
[0]->name
,
4128 gfc_current_intrinsic
, &ap
->expr
->where
);
4132 if (!array_check (ap
->expr
, 0))
4135 return check_reduction (ap
);
4140 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4142 if (gfc_invalid_null_arg (tsource
))
4145 if (gfc_invalid_null_arg (fsource
))
4148 if (!same_type_check (tsource
, 0, fsource
, 1))
4151 if (!type_check (mask
, 2, BT_LOGICAL
))
4154 if (tsource
->ts
.type
== BT_CHARACTER
)
4155 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
4162 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
4164 /* i and j cannot both be BOZ literal constants. */
4165 if (!boz_args_check (i
, j
))
4168 /* If i is BOZ and j is integer, convert i to type of j. */
4169 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
4170 && !gfc_boz2int (i
, j
->ts
.kind
))
4173 /* If j is BOZ and i is integer, convert j to type of i. */
4174 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
4175 && !gfc_boz2int (j
, i
->ts
.kind
))
4178 if (!type_check (i
, 0, BT_INTEGER
))
4181 if (!type_check (j
, 1, BT_INTEGER
))
4184 if (!same_type_check (i
, 0, j
, 1))
4187 if (mask
->ts
.type
== BT_BOZ
&& !gfc_boz2int(mask
, i
->ts
.kind
))
4190 if (!type_check (mask
, 2, BT_INTEGER
))
4193 if (!same_type_check (i
, 0, mask
, 2))
4201 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
4203 if (!variable_check (from
, 0, false))
4205 if (!allocatable_check (from
, 0))
4207 if (gfc_is_coindexed (from
))
4209 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4210 "coindexed", &from
->where
);
4214 if (!variable_check (to
, 1, false))
4216 if (!allocatable_check (to
, 1))
4218 if (gfc_is_coindexed (to
))
4220 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4221 "coindexed", &to
->where
);
4225 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
4227 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4228 "polymorphic if FROM is polymorphic",
4233 if (!same_type_check (to
, 1, from
, 0))
4236 if (to
->rank
!= from
->rank
)
4238 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4239 "must have the same rank %d/%d", &to
->where
, from
->rank
,
4244 /* IR F08/0040; cf. 12-006A. */
4245 if (gfc_get_corank (to
) != gfc_get_corank (from
))
4247 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4248 "must have the same corank %d/%d", &to
->where
,
4249 gfc_get_corank (from
), gfc_get_corank (to
));
4253 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
4254 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4255 and cmp2 are allocatable. After the allocation is transferred,
4256 the 'to' chain is broken by the nullification of the 'from'. A bit
4257 of reflection reveals that this can only occur for derived types
4258 with recursive allocatable components. */
4259 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
4260 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
4262 gfc_ref
*to_ref
, *from_ref
;
4264 from_ref
= from
->ref
;
4265 bool aliasing
= true;
4267 for (; from_ref
&& to_ref
;
4268 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
4270 if (to_ref
->type
!= from
->ref
->type
)
4272 else if (to_ref
->type
== REF_ARRAY
4273 && to_ref
->u
.ar
.type
!= AR_FULL
4274 && from_ref
->u
.ar
.type
!= AR_FULL
)
4275 /* Play safe; assume sections and elements are different. */
4277 else if (to_ref
->type
== REF_COMPONENT
4278 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
4287 gfc_error ("The FROM and TO arguments at %L violate aliasing "
4288 "restrictions (F2003 12.4.1.7)", &to
->where
);
4293 /* CLASS arguments: Make sure the vtab of from is present. */
4294 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
4295 gfc_find_vtab (&from
->ts
);
4302 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
4304 if (!type_check (x
, 0, BT_REAL
))
4307 if (!type_check (s
, 1, BT_REAL
))
4310 if (s
->expr_type
== EXPR_CONSTANT
)
4312 if (mpfr_sgn (s
->value
.real
) == 0)
4314 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4325 gfc_check_new_line (gfc_expr
*a
)
4327 if (!type_check (a
, 0, BT_CHARACTER
))
4335 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
4337 if (!type_check (array
, 0, BT_REAL
))
4340 if (!array_check (array
, 0))
4343 if (!dim_check (dim
, 1, false))
4346 if (!dim_rank_check (dim
, array
, false))
4353 gfc_check_null (gfc_expr
*mold
)
4355 symbol_attribute attr
;
4360 if (!variable_check (mold
, 0, true))
4363 attr
= gfc_variable_attr (mold
, NULL
);
4365 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
4367 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4368 "ALLOCATABLE or procedure pointer",
4369 gfc_current_intrinsic_arg
[0]->name
,
4370 gfc_current_intrinsic
, &mold
->where
);
4374 if (attr
.allocatable
4375 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
4376 "allocatable MOLD at %L", &mold
->where
))
4380 if (gfc_is_coindexed (mold
))
4382 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4383 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
4384 gfc_current_intrinsic
, &mold
->where
);
4393 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4395 if (!array_check (array
, 0))
4398 if (!type_check (mask
, 1, BT_LOGICAL
))
4401 if (!gfc_check_conformance (array
, mask
,
4402 _("arguments '%s' and '%s' for intrinsic '%s'"),
4403 gfc_current_intrinsic_arg
[0]->name
,
4404 gfc_current_intrinsic_arg
[1]->name
,
4405 gfc_current_intrinsic
))
4410 mpz_t array_size
, vector_size
;
4411 bool have_array_size
, have_vector_size
;
4413 if (!same_type_check (array
, 0, vector
, 2))
4416 if (!rank_check (vector
, 2, 1))
4419 /* VECTOR requires at least as many elements as MASK
4420 has .TRUE. values. */
4421 have_array_size
= gfc_array_size(array
, &array_size
);
4422 have_vector_size
= gfc_array_size(vector
, &vector_size
);
4424 if (have_vector_size
4425 && (mask
->expr_type
== EXPR_ARRAY
4426 || (mask
->expr_type
== EXPR_CONSTANT
4427 && have_array_size
)))
4429 int mask_true_values
= 0;
4431 if (mask
->expr_type
== EXPR_ARRAY
)
4433 gfc_constructor
*mask_ctor
;
4434 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4437 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4439 mask_true_values
= 0;
4443 if (mask_ctor
->expr
->value
.logical
)
4446 mask_ctor
= gfc_constructor_next (mask_ctor
);
4449 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
4450 mask_true_values
= mpz_get_si (array_size
);
4452 if (mpz_get_si (vector_size
) < mask_true_values
)
4454 gfc_error ("%qs argument of %qs intrinsic at %L must "
4455 "provide at least as many elements as there "
4456 "are .TRUE. values in %qs (%ld/%d)",
4457 gfc_current_intrinsic_arg
[2]->name
,
4458 gfc_current_intrinsic
, &vector
->where
,
4459 gfc_current_intrinsic_arg
[1]->name
,
4460 mpz_get_si (vector_size
), mask_true_values
);
4465 if (have_array_size
)
4466 mpz_clear (array_size
);
4467 if (have_vector_size
)
4468 mpz_clear (vector_size
);
4476 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
4478 if (!type_check (mask
, 0, BT_LOGICAL
))
4481 if (!array_check (mask
, 0))
4484 if (!dim_check (dim
, 1, false))
4487 if (!dim_rank_check (dim
, mask
, false))
4495 gfc_check_precision (gfc_expr
*x
)
4497 if (!real_or_complex_check (x
, 0))
4505 gfc_check_present (gfc_expr
*a
)
4509 if (!variable_check (a
, 0, true))
4512 sym
= a
->symtree
->n
.sym
;
4513 if (!sym
->attr
.dummy
)
4515 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4516 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
4517 gfc_current_intrinsic
, &a
->where
);
4521 /* For CLASS, the optional attribute might be set at either location. */
4522 if ((sym
->ts
.type
!= BT_CLASS
|| !CLASS_DATA (sym
)->attr
.optional
)
4523 && !sym
->attr
.optional
)
4525 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4526 "an OPTIONAL dummy variable",
4527 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4532 /* 13.14.82 PRESENT(A)
4534 Argument. A shall be the name of an optional dummy argument that is
4535 accessible in the subprogram in which the PRESENT function reference
4539 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
4540 && (a
->ref
->u
.ar
.type
== AR_FULL
4541 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
4542 && a
->ref
->u
.ar
.as
->rank
== 0))))
4544 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4545 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
4546 gfc_current_intrinsic
, &a
->where
, sym
->name
);
4555 gfc_check_radix (gfc_expr
*x
)
4557 if (!int_or_real_check (x
, 0))
4565 gfc_check_range (gfc_expr
*x
)
4567 if (!numeric_check (x
, 0))
4575 gfc_check_rank (gfc_expr
*a
)
4577 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4578 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4580 bool is_variable
= true;
4582 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4583 if (a
->expr_type
== EXPR_FUNCTION
)
4584 is_variable
= a
->value
.function
.esym
4585 ? a
->value
.function
.esym
->result
->attr
.pointer
4586 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
4588 if (a
->expr_type
== EXPR_OP
4589 || a
->expr_type
== EXPR_NULL
4590 || a
->expr_type
== EXPR_COMPCALL
4591 || a
->expr_type
== EXPR_PPC
4592 || a
->ts
.type
== BT_PROCEDURE
4595 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4596 "object", &a
->where
);
4605 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
4607 if (!kind_check (kind
, 1, BT_REAL
))
4610 /* BOZ is dealt with in gfc_simplify_real. */
4611 if (a
->ts
.type
== BT_BOZ
)
4614 if (!numeric_check (a
, 0))
4622 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
4624 if (!type_check (path1
, 0, BT_CHARACTER
))
4626 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4629 if (!type_check (path2
, 1, BT_CHARACTER
))
4631 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4639 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
4641 if (!type_check (path1
, 0, BT_CHARACTER
))
4643 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4646 if (!type_check (path2
, 1, BT_CHARACTER
))
4648 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4654 if (!type_check (status
, 2, BT_INTEGER
))
4657 if (!scalar_check (status
, 2))
4665 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
4667 if (!type_check (x
, 0, BT_CHARACTER
))
4670 if (!scalar_check (x
, 0))
4673 if (!type_check (y
, 0, BT_INTEGER
))
4676 if (!scalar_check (y
, 1))
4684 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
4685 gfc_expr
*pad
, gfc_expr
*order
)
4690 bool shape_is_const
;
4692 if (!array_check (source
, 0))
4695 if (!rank_check (shape
, 1, 1))
4698 if (!type_check (shape
, 1, BT_INTEGER
))
4701 if (!gfc_array_size (shape
, &size
))
4703 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4704 "array of constant size", &shape
->where
);
4708 shape_size
= mpz_get_ui (size
);
4711 if (shape_size
<= 0)
4713 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4714 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4718 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4720 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4721 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4725 gfc_simplify_expr (shape
, 0);
4726 shape_is_const
= gfc_is_constant_array_expr (shape
);
4728 if (shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
)
4732 for (i
= 0; i
< shape_size
; ++i
)
4734 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4737 if (e
->expr_type
!= EXPR_CONSTANT
)
4740 gfc_extract_int (e
, &extent
);
4743 gfc_error ("%qs argument of %qs intrinsic at %L has "
4744 "negative element (%d)",
4745 gfc_current_intrinsic_arg
[1]->name
,
4746 gfc_current_intrinsic
, &shape
->where
, extent
);
4754 if (!same_type_check (source
, 0, pad
, 2))
4757 if (!array_check (pad
, 2))
4763 if (!array_check (order
, 3))
4766 if (!type_check (order
, 3, BT_INTEGER
))
4769 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_array_expr (order
))
4771 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4774 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4777 gfc_array_size (order
, &size
);
4778 order_size
= mpz_get_ui (size
);
4781 if (order_size
!= shape_size
)
4783 gfc_error ("%qs argument of %qs intrinsic at %L "
4784 "has wrong number of elements (%d/%d)",
4785 gfc_current_intrinsic_arg
[3]->name
,
4786 gfc_current_intrinsic
, &order
->where
,
4787 order_size
, shape_size
);
4791 for (i
= 1; i
<= order_size
; ++i
)
4793 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4794 if (e
->expr_type
!= EXPR_CONSTANT
)
4797 gfc_extract_int (e
, &dim
);
4799 if (dim
< 1 || dim
> order_size
)
4801 gfc_error ("%qs argument of %qs intrinsic at %L "
4802 "has out-of-range dimension (%d)",
4803 gfc_current_intrinsic_arg
[3]->name
,
4804 gfc_current_intrinsic
, &e
->where
, dim
);
4808 if (perm
[dim
-1] != 0)
4810 gfc_error ("%qs argument of %qs intrinsic at %L has "
4811 "invalid permutation of dimensions (dimension "
4813 gfc_current_intrinsic_arg
[3]->name
,
4814 gfc_current_intrinsic
, &e
->where
, dim
);
4823 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
&& shape_is_const
4824 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4825 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4827 /* Check the match in size between source and destination. */
4828 if (gfc_array_size (source
, &nelems
))
4834 mpz_init_set_ui (size
, 1);
4835 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4836 c
; c
= gfc_constructor_next (c
))
4837 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4839 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4845 gfc_error ("Without padding, there are not enough elements "
4846 "in the intrinsic RESHAPE source at %L to match "
4847 "the shape", &source
->where
);
4858 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4860 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4862 gfc_error ("%qs argument of %qs intrinsic at %L "
4863 "cannot be of type %s",
4864 gfc_current_intrinsic_arg
[0]->name
,
4865 gfc_current_intrinsic
,
4866 &a
->where
, gfc_typename (a
));
4870 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4872 gfc_error ("%qs argument of %qs intrinsic at %L "
4873 "must be of an extensible type",
4874 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4879 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4881 gfc_error ("%qs argument of %qs intrinsic at %L "
4882 "cannot be of type %s",
4883 gfc_current_intrinsic_arg
[0]->name
,
4884 gfc_current_intrinsic
,
4885 &b
->where
, gfc_typename (b
));
4889 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4891 gfc_error ("%qs argument of %qs intrinsic at %L "
4892 "must be of an extensible type",
4893 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4903 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4905 if (!type_check (x
, 0, BT_REAL
))
4908 if (!type_check (i
, 1, BT_INTEGER
))
4916 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4918 if (!type_check (x
, 0, BT_CHARACTER
))
4921 if (!type_check (y
, 1, BT_CHARACTER
))
4924 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4927 if (!kind_check (kind
, 3, BT_INTEGER
))
4929 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4930 "with KIND argument at %L",
4931 gfc_current_intrinsic
, &kind
->where
))
4934 if (!same_type_check (x
, 0, y
, 1))
4942 gfc_check_secnds (gfc_expr
*r
)
4944 if (!type_check (r
, 0, BT_REAL
))
4947 if (!kind_value_check (r
, 0, 4))
4950 if (!scalar_check (r
, 0))
4958 gfc_check_selected_char_kind (gfc_expr
*name
)
4960 if (!type_check (name
, 0, BT_CHARACTER
))
4963 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4966 if (!scalar_check (name
, 0))
4974 gfc_check_selected_int_kind (gfc_expr
*r
)
4976 if (!type_check (r
, 0, BT_INTEGER
))
4979 if (!scalar_check (r
, 0))
4987 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4989 if (p
== NULL
&& r
== NULL
4990 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4991 " neither %<P%> nor %<R%> argument at %L",
4992 gfc_current_intrinsic_where
))
4997 if (!type_check (p
, 0, BT_INTEGER
))
5000 if (!scalar_check (p
, 0))
5006 if (!type_check (r
, 1, BT_INTEGER
))
5009 if (!scalar_check (r
, 1))
5015 if (!type_check (radix
, 1, BT_INTEGER
))
5018 if (!scalar_check (radix
, 1))
5021 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
5022 "RADIX argument at %L", gfc_current_intrinsic
,
5032 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5034 if (!type_check (x
, 0, BT_REAL
))
5037 if (!type_check (i
, 1, BT_INTEGER
))
5045 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
5049 if (gfc_invalid_null_arg (source
))
5052 if (!kind_check (kind
, 1, BT_INTEGER
))
5054 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5055 "with KIND argument at %L",
5056 gfc_current_intrinsic
, &kind
->where
))
5059 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
5062 if (source
->ref
== NULL
)
5065 ar
= gfc_find_array_ref (source
);
5067 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
5069 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5070 "an assumed size array", &source
->where
);
5079 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
5081 if (!type_check (i
, 0, BT_INTEGER
))
5084 if (!type_check (shift
, 0, BT_INTEGER
))
5087 if (!nonnegative_check ("SHIFT", shift
))
5090 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
5098 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
5100 if (!int_or_real_check (a
, 0))
5103 if (!same_type_check (a
, 0, b
, 1))
5111 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5113 if (!array_check (array
, 0))
5116 if (!dim_check (dim
, 1, true))
5119 if (!dim_rank_check (dim
, array
, 0))
5122 if (!kind_check (kind
, 2, BT_INTEGER
))
5124 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5125 "with KIND argument at %L",
5126 gfc_current_intrinsic
, &kind
->where
))
5135 gfc_check_sizeof (gfc_expr
*arg
)
5137 if (gfc_invalid_null_arg (arg
))
5140 if (arg
->ts
.type
== BT_PROCEDURE
)
5142 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5143 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5148 if (illegal_boz_arg (arg
))
5151 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5152 if (arg
->ts
.type
== BT_ASSUMED
5153 && (arg
->symtree
->n
.sym
->as
== NULL
5154 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
5155 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
5156 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
5158 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5159 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5164 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5165 && arg
->symtree
->n
.sym
->as
!= NULL
5166 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5167 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5169 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5170 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5171 gfc_current_intrinsic
, &arg
->where
);
5179 /* Check whether an expression is interoperable. When returning false,
5180 msg is set to a string telling why the expression is not interoperable,
5181 otherwise, it is set to NULL. The msg string can be used in diagnostics.
5182 If c_loc is true, character with len > 1 are allowed (cf. Fortran
5183 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5184 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5188 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
5192 if (expr
->expr_type
== EXPR_NULL
)
5194 *msg
= "NULL() is not interoperable";
5198 if (expr
->ts
.type
== BT_BOZ
)
5200 *msg
= "BOZ literal constant";
5204 if (expr
->ts
.type
== BT_CLASS
)
5206 *msg
= "Expression is polymorphic";
5210 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
5211 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
5213 *msg
= "Expression is a noninteroperable derived type";
5217 if (expr
->ts
.type
== BT_PROCEDURE
)
5219 *msg
= "Procedure unexpected as argument";
5223 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
5226 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
5227 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
5229 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
5233 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
5234 && expr
->ts
.kind
!= 1)
5236 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
5240 if (expr
->ts
.type
== BT_CHARACTER
) {
5241 if (expr
->ts
.deferred
)
5243 /* TS 29113 allows deferred-length strings as dummy arguments,
5244 but it is not an interoperable type. */
5245 *msg
= "Expression shall not be a deferred-length string";
5249 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
5250 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
5251 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5253 if (!c_loc
&& expr
->ts
.u
.cl
5254 && (!expr
->ts
.u
.cl
->length
5255 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5256 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5258 *msg
= "Type shall have a character length of 1";
5263 /* Note: The following checks are about interoperatable variables, Fortran
5264 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5265 is allowed, e.g. assumed-shape arrays with TS 29113. */
5267 if (gfc_is_coarray (expr
))
5269 *msg
= "Coarrays are not interoperable";
5273 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
5275 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
5276 if (ar
->type
!= AR_FULL
)
5278 *msg
= "Only whole-arrays are interoperable";
5281 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
5282 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
5284 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
5294 gfc_check_c_sizeof (gfc_expr
*arg
)
5298 if (!is_c_interoperable (arg
, &msg
, false, false))
5300 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5301 "interoperable data entity: %s",
5302 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5307 if (arg
->ts
.type
== BT_ASSUMED
)
5309 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5311 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5316 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5317 && arg
->symtree
->n
.sym
->as
!= NULL
5318 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5319 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5321 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5322 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5323 gfc_current_intrinsic
, &arg
->where
);
5332 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
5334 if (c_ptr_1
->ts
.type
!= BT_DERIVED
5335 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5336 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
5337 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
5339 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5340 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
5344 if (!scalar_check (c_ptr_1
, 0))
5348 && (c_ptr_2
->ts
.type
!= BT_DERIVED
5349 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5350 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
5351 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
5353 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5354 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
5355 gfc_typename (&c_ptr_1
->ts
),
5356 gfc_typename (&c_ptr_2
->ts
));
5360 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
5368 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
5370 symbol_attribute attr
;
5373 if (cptr
->ts
.type
!= BT_DERIVED
5374 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5375 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
5377 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5378 "type TYPE(C_PTR)", &cptr
->where
);
5382 if (!scalar_check (cptr
, 0))
5385 attr
= gfc_expr_attr (fptr
);
5389 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5394 if (fptr
->ts
.type
== BT_CLASS
)
5396 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5401 if (gfc_is_coindexed (fptr
))
5403 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5404 "coindexed", &fptr
->where
);
5408 if (fptr
->rank
== 0 && shape
)
5410 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5411 "FPTR", &fptr
->where
);
5414 else if (fptr
->rank
&& !shape
)
5416 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5417 "FPTR at %L", &fptr
->where
);
5421 if (shape
&& !rank_check (shape
, 2, 1))
5424 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
5430 if (gfc_array_size (shape
, &size
))
5432 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
5435 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5436 "size as the RANK of FPTR", &shape
->where
);
5443 if (fptr
->ts
.type
== BT_CLASS
)
5445 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
5449 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
5450 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable array FPTR "
5451 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
5458 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
5460 symbol_attribute attr
;
5462 if (cptr
->ts
.type
!= BT_DERIVED
5463 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5464 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
5466 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5467 "type TYPE(C_FUNPTR)", &cptr
->where
);
5471 if (!scalar_check (cptr
, 0))
5474 attr
= gfc_expr_attr (fptr
);
5476 if (!attr
.proc_pointer
)
5478 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5479 "pointer", &fptr
->where
);
5483 if (gfc_is_coindexed (fptr
))
5485 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5486 "coindexed", &fptr
->where
);
5490 if (!attr
.is_bind_c
)
5491 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5492 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
5499 gfc_check_c_funloc (gfc_expr
*x
)
5501 symbol_attribute attr
;
5503 if (gfc_is_coindexed (x
))
5505 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5506 "coindexed", &x
->where
);
5510 attr
= gfc_expr_attr (x
);
5512 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
5513 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
5514 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5515 if (x
->symtree
->n
.sym
== ns
->proc_name
)
5517 gfc_error ("Function result %qs at %L is invalid as X argument "
5518 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
5522 if (attr
.flavor
!= FL_PROCEDURE
)
5524 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5525 "or a procedure pointer", &x
->where
);
5529 if (!attr
.is_bind_c
)
5530 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5531 "at %L to C_FUNLOC", &x
->where
);
5537 gfc_check_c_loc (gfc_expr
*x
)
5539 symbol_attribute attr
;
5542 if (gfc_is_coindexed (x
))
5544 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
5548 if (x
->ts
.type
== BT_CLASS
)
5550 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5555 attr
= gfc_expr_attr (x
);
5558 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
5559 || attr
.flavor
== FL_PARAMETER
))
5561 gfc_error ("Argument X at %L to C_LOC shall have either "
5562 "the POINTER or the TARGET attribute", &x
->where
);
5566 if (x
->ts
.type
== BT_CHARACTER
5567 && gfc_var_strlen (x
) == 0)
5569 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5570 "string", &x
->where
);
5574 if (!is_c_interoperable (x
, &msg
, true, false))
5576 if (x
->ts
.type
== BT_CLASS
)
5578 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5584 && !gfc_notify_std (GFC_STD_F2018
,
5585 "Noninteroperable array at %L as"
5586 " argument to C_LOC: %s", &x
->where
, msg
))
5589 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
5591 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
5593 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
5594 && !attr
.allocatable
5595 && !gfc_notify_std (GFC_STD_F2008
,
5596 "Array of interoperable type at %L "
5597 "to C_LOC which is nonallocatable and neither "
5598 "assumed size nor explicit size", &x
->where
))
5600 else if (ar
->type
!= AR_FULL
5601 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
5602 "to C_LOC", &x
->where
))
5611 gfc_check_sleep_sub (gfc_expr
*seconds
)
5613 if (!type_check (seconds
, 0, BT_INTEGER
))
5616 if (!scalar_check (seconds
, 0))
5623 gfc_check_sngl (gfc_expr
*a
)
5625 if (!type_check (a
, 0, BT_REAL
))
5628 if ((a
->ts
.kind
!= gfc_default_double_kind
)
5629 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
5630 "REAL argument to %s intrinsic at %L",
5631 gfc_current_intrinsic
, &a
->where
))
5638 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
5640 if (gfc_invalid_null_arg (source
))
5643 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
5645 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5646 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
5647 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
5655 if (!dim_check (dim
, 1, false))
5658 /* dim_rank_check() does not apply here. */
5660 && dim
->expr_type
== EXPR_CONSTANT
5661 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
5662 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
5664 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5665 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
5666 gfc_current_intrinsic
, &dim
->where
);
5670 if (!type_check (ncopies
, 2, BT_INTEGER
))
5673 if (!scalar_check (ncopies
, 2))
5680 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5684 arg_strlen_is_zero (gfc_expr
*c
, int n
)
5686 if (gfc_var_strlen (c
) == 0)
5688 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5689 "length at least 1", gfc_current_intrinsic_arg
[n
]->name
,
5690 gfc_current_intrinsic
, &c
->where
);
5697 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
5699 if (!type_check (unit
, 0, BT_INTEGER
))
5702 if (!scalar_check (unit
, 0))
5705 if (!type_check (c
, 1, BT_CHARACTER
))
5707 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5709 if (strcmp (gfc_current_intrinsic
, "fgetc") == 0
5710 && !variable_check (c
, 1, false))
5712 if (arg_strlen_is_zero (c
, 1))
5718 if (!type_check (status
, 2, BT_INTEGER
)
5719 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5720 || !scalar_check (status
, 2)
5721 || !variable_check (status
, 2, false))
5729 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5731 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5736 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5738 if (!type_check (c
, 0, BT_CHARACTER
))
5740 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5742 if (strcmp (gfc_current_intrinsic
, "fget") == 0
5743 && !variable_check (c
, 0, false))
5745 if (arg_strlen_is_zero (c
, 0))
5751 if (!type_check (status
, 1, BT_INTEGER
)
5752 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5753 || !scalar_check (status
, 1)
5754 || !variable_check (status
, 1, false))
5762 gfc_check_fgetput (gfc_expr
*c
)
5764 return gfc_check_fgetput_sub (c
, NULL
);
5769 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5771 if (!type_check (unit
, 0, BT_INTEGER
))
5774 if (!scalar_check (unit
, 0))
5777 if (!type_check (offset
, 1, BT_INTEGER
))
5780 if (!scalar_check (offset
, 1))
5783 if (!type_check (whence
, 2, BT_INTEGER
))
5786 if (!scalar_check (whence
, 2))
5792 if (!type_check (status
, 3, BT_INTEGER
))
5795 if (!kind_value_check (status
, 3, 4))
5798 if (!scalar_check (status
, 3))
5807 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5809 if (!type_check (unit
, 0, BT_INTEGER
))
5812 if (!scalar_check (unit
, 0))
5815 if (!type_check (array
, 1, BT_INTEGER
)
5816 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5819 if (!array_check (array
, 1))
5827 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5829 if (!type_check (unit
, 0, BT_INTEGER
))
5832 if (!scalar_check (unit
, 0))
5835 if (!type_check (array
, 1, BT_INTEGER
)
5836 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5839 if (!array_check (array
, 1))
5845 if (!type_check (status
, 2, BT_INTEGER
)
5846 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5849 if (!scalar_check (status
, 2))
5857 gfc_check_ftell (gfc_expr
*unit
)
5859 if (!type_check (unit
, 0, BT_INTEGER
))
5862 if (!scalar_check (unit
, 0))
5870 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5872 if (!type_check (unit
, 0, BT_INTEGER
))
5875 if (!scalar_check (unit
, 0))
5878 if (!type_check (offset
, 1, BT_INTEGER
))
5881 if (!scalar_check (offset
, 1))
5889 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5891 if (!type_check (name
, 0, BT_CHARACTER
))
5893 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5896 if (!type_check (array
, 1, BT_INTEGER
)
5897 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5900 if (!array_check (array
, 1))
5908 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5910 if (!type_check (name
, 0, BT_CHARACTER
))
5912 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5915 if (!type_check (array
, 1, BT_INTEGER
)
5916 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5919 if (!array_check (array
, 1))
5925 if (!type_check (status
, 2, BT_INTEGER
)
5926 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5929 if (!scalar_check (status
, 2))
5937 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5941 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5943 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5947 if (!coarray_check (coarray
, 0))
5952 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5953 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5957 if (sub
->ts
.type
!= BT_INTEGER
)
5959 gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
5960 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5964 if (gfc_array_size (sub
, &nelems
))
5966 int corank
= gfc_get_corank (coarray
);
5968 if (mpz_cmp_ui (nelems
, corank
) != 0)
5970 gfc_error ("The number of array elements of the SUB argument to "
5971 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5972 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5984 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5986 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5988 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5994 if (!type_check (distance
, 0, BT_INTEGER
))
5997 if (!nonnegative_check ("DISTANCE", distance
))
6000 if (!scalar_check (distance
, 0))
6003 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6004 "NUM_IMAGES at %L", &distance
->where
))
6010 if (!type_check (failed
, 1, BT_LOGICAL
))
6013 if (!scalar_check (failed
, 1))
6016 if (!gfc_notify_std (GFC_STD_F2018
, "FAILED= argument to "
6017 "NUM_IMAGES at %L", &failed
->where
))
6026 gfc_check_team_number (gfc_expr
*team
)
6028 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6030 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6036 if (team
->ts
.type
!= BT_DERIVED
6037 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
6038 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
6040 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
6041 "shall be of type TEAM_TYPE", &team
->where
);
6053 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
6055 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6057 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6061 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
6064 if (dim
!= NULL
&& coarray
== NULL
)
6066 gfc_error ("DIM argument without COARRAY argument not allowed for "
6067 "THIS_IMAGE intrinsic at %L", &dim
->where
);
6071 if (distance
&& (coarray
|| dim
))
6073 gfc_error ("The DISTANCE argument may not be specified together with the "
6074 "COARRAY or DIM argument in intrinsic at %L",
6079 /* Assume that we have "this_image (distance)". */
6080 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
6084 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6093 if (!type_check (distance
, 2, BT_INTEGER
))
6096 if (!nonnegative_check ("DISTANCE", distance
))
6099 if (!scalar_check (distance
, 2))
6102 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6103 "THIS_IMAGE at %L", &distance
->where
))
6109 if (!coarray_check (coarray
, 0))
6114 if (!dim_check (dim
, 1, false))
6117 if (!dim_corank_check (dim
, coarray
))
6124 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6125 by gfc_simplify_transfer. Return false if we cannot do so. */
6128 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
6129 size_t *source_size
, size_t *result_size
,
6130 size_t *result_length_p
)
6132 size_t result_elt_size
;
6134 if (source
->expr_type
== EXPR_FUNCTION
)
6137 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
6140 /* Calculate the size of the source. */
6141 if (!gfc_target_expr_size (source
, source_size
))
6144 /* Determine the size of the element. */
6145 if (!gfc_element_size (mold
, &result_elt_size
))
6148 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6149 * a scalar with the type and type parameters of MOLD shall not have a
6150 * storage size equal to zero.
6151 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6152 * If MOLD is an array and SIZE is absent, the result is an array and of
6153 * rank one. Its size is as small as possible such that its physical
6154 * representation is not shorter than that of SOURCE.
6155 * If SIZE is present, the result is an array of rank one and size SIZE.
6157 if (result_elt_size
== 0 && *source_size
> 0
6158 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6160 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6161 "array and shall not have storage size 0 when %<SOURCE%> "
6162 "argument has size greater than 0", &mold
->where
);
6166 if (result_elt_size
== 0 && *source_size
== 0 && !size
)
6169 if (result_length_p
)
6170 *result_length_p
= 0;
6174 if ((result_elt_size
> 0 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6180 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6183 result_length
= *source_size
/ result_elt_size
;
6184 if (result_length
* result_elt_size
< *source_size
)
6188 *result_size
= result_length
* result_elt_size
;
6189 if (result_length_p
)
6190 *result_length_p
= result_length
;
6193 *result_size
= result_elt_size
;
6200 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6205 if (gfc_invalid_null_arg (source
))
6208 /* SOURCE shall be a scalar or array of any type. */
6209 if (source
->ts
.type
== BT_PROCEDURE
6210 && source
->symtree
->n
.sym
->attr
.subroutine
== 1)
6212 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6213 "must not be a %s", &source
->where
,
6214 gfc_basic_typename (source
->ts
.type
));
6218 if (source
->ts
.type
== BT_BOZ
&& illegal_boz_arg (source
))
6221 if (mold
->ts
.type
== BT_BOZ
&& illegal_boz_arg (mold
))
6224 if (gfc_invalid_null_arg (mold
))
6227 /* MOLD shall be a scalar or array of any type. */
6228 if (mold
->ts
.type
== BT_PROCEDURE
6229 && mold
->symtree
->n
.sym
->attr
.subroutine
== 1)
6231 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6232 "must not be a %s", &mold
->where
,
6233 gfc_basic_typename (mold
->ts
.type
));
6237 if (mold
->ts
.type
== BT_HOLLERITH
)
6239 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6240 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
6244 /* SIZE (optional) shall be an integer scalar. The corresponding actual
6245 argument shall not be an optional dummy argument. */
6248 if (!type_check (size
, 2, BT_INTEGER
))
6250 if (size
->ts
.type
== BT_BOZ
)
6255 if (!scalar_check (size
, 2))
6258 if (!nonoptional_check (size
, 2))
6262 if (!warn_surprising
)
6265 /* If we can't calculate the sizes, we cannot check any more.
6266 Return true for that case. */
6268 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6269 &result_size
, NULL
))
6272 if (source_size
< result_size
)
6273 gfc_warning (OPT_Wsurprising
,
6274 "Intrinsic TRANSFER at %L has partly undefined result: "
6275 "source size %ld < result size %ld", &source
->where
,
6276 (long) source_size
, (long) result_size
);
6283 gfc_check_transpose (gfc_expr
*matrix
)
6285 if (!rank_check (matrix
, 0, 2))
6293 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6295 if (!array_check (array
, 0))
6298 if (!dim_check (dim
, 1, false))
6301 if (!dim_rank_check (dim
, array
, 0))
6304 if (!kind_check (kind
, 2, BT_INTEGER
))
6306 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6307 "with KIND argument at %L",
6308 gfc_current_intrinsic
, &kind
->where
))
6316 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
6318 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6320 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6324 if (!coarray_check (coarray
, 0))
6329 if (!dim_check (dim
, 1, false))
6332 if (!dim_corank_check (dim
, coarray
))
6336 if (!kind_check (kind
, 2, BT_INTEGER
))
6344 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6348 if (!rank_check (vector
, 0, 1))
6351 if (!array_check (mask
, 1))
6354 if (!type_check (mask
, 1, BT_LOGICAL
))
6357 if (!same_type_check (vector
, 0, field
, 2))
6360 gfc_simplify_expr (mask
, 0);
6362 if (mask
->expr_type
== EXPR_ARRAY
6363 && gfc_array_size (vector
, &vector_size
))
6365 int mask_true_count
= 0;
6366 gfc_constructor
*mask_ctor
;
6367 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6370 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
6372 mask_true_count
= 0;
6376 if (mask_ctor
->expr
->value
.logical
)
6379 mask_ctor
= gfc_constructor_next (mask_ctor
);
6382 if (mpz_get_si (vector_size
) < mask_true_count
)
6384 gfc_error ("%qs argument of %qs intrinsic at %L must "
6385 "provide at least as many elements as there "
6386 "are .TRUE. values in %qs (%ld/%d)",
6387 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6388 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
6389 mpz_get_si (vector_size
), mask_true_count
);
6393 mpz_clear (vector_size
);
6396 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
6398 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6399 "the same rank as %qs or be a scalar",
6400 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6401 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
6405 if (mask
->rank
== field
->rank
)
6408 for (i
= 0; i
< field
->rank
; i
++)
6409 if (! identical_dimen_shape (mask
, i
, field
, i
))
6411 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6412 "must have identical shape.",
6413 gfc_current_intrinsic_arg
[2]->name
,
6414 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6424 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
6426 if (!type_check (x
, 0, BT_CHARACTER
))
6429 if (!same_type_check (x
, 0, y
, 1))
6432 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
6435 if (!kind_check (kind
, 3, BT_INTEGER
))
6437 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6438 "with KIND argument at %L",
6439 gfc_current_intrinsic
, &kind
->where
))
6447 gfc_check_trim (gfc_expr
*x
)
6449 if (!type_check (x
, 0, BT_CHARACTER
))
6452 if (gfc_invalid_null_arg (x
))
6455 if (!scalar_check (x
, 0))
6463 gfc_check_ttynam (gfc_expr
*unit
)
6465 if (!scalar_check (unit
, 0))
6468 if (!type_check (unit
, 0, BT_INTEGER
))
6475 /************* Check functions for intrinsic subroutines *************/
6478 gfc_check_cpu_time (gfc_expr
*time
)
6480 if (!scalar_check (time
, 0))
6483 if (!type_check (time
, 0, BT_REAL
))
6486 if (!variable_check (time
, 0, false))
6494 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
6495 gfc_expr
*zone
, gfc_expr
*values
)
6499 if (!type_check (date
, 0, BT_CHARACTER
))
6501 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6503 if (!scalar_check (date
, 0))
6505 if (!variable_check (date
, 0, false))
6511 if (!type_check (time
, 1, BT_CHARACTER
))
6513 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
6515 if (!scalar_check (time
, 1))
6517 if (!variable_check (time
, 1, false))
6523 if (!type_check (zone
, 2, BT_CHARACTER
))
6525 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
6527 if (!scalar_check (zone
, 2))
6529 if (!variable_check (zone
, 2, false))
6535 if (!type_check (values
, 3, BT_INTEGER
))
6537 if (!array_check (values
, 3))
6539 if (!rank_check (values
, 3, 1))
6541 if (!variable_check (values
, 3, false))
6550 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
6551 gfc_expr
*to
, gfc_expr
*topos
)
6553 if (!type_check (from
, 0, BT_INTEGER
))
6556 if (!type_check (frompos
, 1, BT_INTEGER
))
6559 if (!type_check (len
, 2, BT_INTEGER
))
6562 if (!same_type_check (from
, 0, to
, 3))
6565 if (!variable_check (to
, 3, false))
6568 if (!type_check (topos
, 4, BT_INTEGER
))
6571 if (!nonnegative_check ("frompos", frompos
))
6574 if (!nonnegative_check ("topos", topos
))
6577 if (!nonnegative_check ("len", len
))
6580 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
6583 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
6590 /* Check the arguments for RANDOM_INIT. */
6593 gfc_check_random_init (gfc_expr
*repeatable
, gfc_expr
*image_distinct
)
6595 if (!type_check (repeatable
, 0, BT_LOGICAL
))
6598 if (!scalar_check (repeatable
, 0))
6601 if (!type_check (image_distinct
, 1, BT_LOGICAL
))
6604 if (!scalar_check (image_distinct
, 1))
6612 gfc_check_random_number (gfc_expr
*harvest
)
6614 if (!type_check (harvest
, 0, BT_REAL
))
6617 if (!variable_check (harvest
, 0, false))
6625 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
6627 unsigned int nargs
= 0, seed_size
;
6628 locus
*where
= NULL
;
6629 mpz_t put_size
, get_size
;
6631 /* Keep the number of bytes in sync with master_state in
6632 libgfortran/intrinsics/random.c. */
6633 seed_size
= 32 / gfc_default_integer_kind
;
6637 if (size
->expr_type
!= EXPR_VARIABLE
6638 || !size
->symtree
->n
.sym
->attr
.optional
)
6641 if (!scalar_check (size
, 0))
6644 if (!type_check (size
, 0, BT_INTEGER
))
6647 if (!variable_check (size
, 0, false))
6650 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
6656 if (put
->expr_type
!= EXPR_VARIABLE
6657 || !put
->symtree
->n
.sym
->attr
.optional
)
6660 where
= &put
->where
;
6663 if (!array_check (put
, 1))
6666 if (!rank_check (put
, 1, 1))
6669 if (!type_check (put
, 1, BT_INTEGER
))
6672 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
6675 if (gfc_array_size (put
, &put_size
)
6676 && mpz_get_ui (put_size
) < seed_size
)
6677 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6678 "too small (%i/%i)",
6679 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6680 &put
->where
, (int) mpz_get_ui (put_size
), seed_size
);
6685 if (get
->expr_type
!= EXPR_VARIABLE
6686 || !get
->symtree
->n
.sym
->attr
.optional
)
6689 where
= &get
->where
;
6692 if (!array_check (get
, 2))
6695 if (!rank_check (get
, 2, 1))
6698 if (!type_check (get
, 2, BT_INTEGER
))
6701 if (!variable_check (get
, 2, false))
6704 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
6707 if (gfc_array_size (get
, &get_size
)
6708 && mpz_get_ui (get_size
) < seed_size
)
6709 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6710 "too small (%i/%i)",
6711 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6712 &get
->where
, (int) mpz_get_ui (get_size
), seed_size
);
6715 /* RANDOM_SEED may not have more than one non-optional argument. */
6717 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
6723 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
6727 int num_percent
, nargs
;
6730 if (e
->expr_type
!= EXPR_CONSTANT
)
6733 len
= e
->value
.character
.length
;
6734 if (e
->value
.character
.string
[len
-1] != '\0')
6735 gfc_internal_error ("fe_runtime_error string must be null terminated");
6738 for (i
=0; i
<len
-1; i
++)
6739 if (e
->value
.character
.string
[i
] == '%')
6743 for (; a
; a
= a
->next
)
6746 if (nargs
-1 != num_percent
)
6747 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6748 nargs
, num_percent
++);
6754 gfc_check_second_sub (gfc_expr
*time
)
6756 if (!scalar_check (time
, 0))
6759 if (!type_check (time
, 0, BT_REAL
))
6762 if (!kind_value_check (time
, 0, 4))
6769 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6770 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6771 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6772 count_max are all optional arguments */
6775 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
6776 gfc_expr
*count_max
)
6780 if (!scalar_check (count
, 0))
6783 if (!type_check (count
, 0, BT_INTEGER
))
6786 if (count
->ts
.kind
!= gfc_default_integer_kind
6787 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
6788 "SYSTEM_CLOCK at %L has non-default kind",
6792 if (!variable_check (count
, 0, false))
6796 if (count_rate
!= NULL
)
6798 if (!scalar_check (count_rate
, 1))
6801 if (!variable_check (count_rate
, 1, false))
6804 if (count_rate
->ts
.type
== BT_REAL
)
6806 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
6807 "SYSTEM_CLOCK at %L", &count_rate
->where
))
6812 if (!type_check (count_rate
, 1, BT_INTEGER
))
6815 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6816 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6817 "SYSTEM_CLOCK at %L has non-default kind",
6818 &count_rate
->where
))
6824 if (count_max
!= NULL
)
6826 if (!scalar_check (count_max
, 2))
6829 if (!type_check (count_max
, 2, BT_INTEGER
))
6832 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6833 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6834 "SYSTEM_CLOCK at %L has non-default kind",
6838 if (!variable_check (count_max
, 2, false))
6847 gfc_check_irand (gfc_expr
*x
)
6852 if (!scalar_check (x
, 0))
6855 if (!type_check (x
, 0, BT_INTEGER
))
6858 if (!kind_value_check (x
, 0, 4))
6866 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6868 if (!scalar_check (seconds
, 0))
6870 if (!type_check (seconds
, 0, BT_INTEGER
))
6873 if (!int_or_proc_check (handler
, 1))
6875 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6881 if (!scalar_check (status
, 2))
6883 if (!type_check (status
, 2, BT_INTEGER
))
6885 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6893 gfc_check_rand (gfc_expr
*x
)
6898 if (!scalar_check (x
, 0))
6901 if (!type_check (x
, 0, BT_INTEGER
))
6904 if (!kind_value_check (x
, 0, 4))
6912 gfc_check_srand (gfc_expr
*x
)
6914 if (!scalar_check (x
, 0))
6917 if (!type_check (x
, 0, BT_INTEGER
))
6920 if (!kind_value_check (x
, 0, 4))
6928 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6930 if (!scalar_check (time
, 0))
6932 if (!type_check (time
, 0, BT_INTEGER
))
6935 if (!type_check (result
, 1, BT_CHARACTER
))
6937 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6945 gfc_check_dtime_etime (gfc_expr
*x
)
6947 if (!array_check (x
, 0))
6950 if (!rank_check (x
, 0, 1))
6953 if (!variable_check (x
, 0, false))
6956 if (!type_check (x
, 0, BT_REAL
))
6959 if (!kind_value_check (x
, 0, 4))
6967 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6969 if (!array_check (values
, 0))
6972 if (!rank_check (values
, 0, 1))
6975 if (!variable_check (values
, 0, false))
6978 if (!type_check (values
, 0, BT_REAL
))
6981 if (!kind_value_check (values
, 0, 4))
6984 if (!scalar_check (time
, 1))
6987 if (!type_check (time
, 1, BT_REAL
))
6990 if (!kind_value_check (time
, 1, 4))
6998 gfc_check_fdate_sub (gfc_expr
*date
)
7000 if (!type_check (date
, 0, BT_CHARACTER
))
7002 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
7010 gfc_check_gerror (gfc_expr
*msg
)
7012 if (!type_check (msg
, 0, BT_CHARACTER
))
7014 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7022 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
7024 if (!type_check (cwd
, 0, BT_CHARACTER
))
7026 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
7032 if (!scalar_check (status
, 1))
7035 if (!type_check (status
, 1, BT_INTEGER
))
7043 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
7045 if (!type_check (pos
, 0, BT_INTEGER
))
7048 if (pos
->ts
.kind
> gfc_default_integer_kind
)
7050 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
7051 "not wider than the default kind (%d)",
7052 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7053 &pos
->where
, gfc_default_integer_kind
);
7057 if (!type_check (value
, 1, BT_CHARACTER
))
7059 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
7067 gfc_check_getlog (gfc_expr
*msg
)
7069 if (!type_check (msg
, 0, BT_CHARACTER
))
7071 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7079 gfc_check_exit (gfc_expr
*status
)
7084 if (!type_check (status
, 0, BT_INTEGER
))
7087 if (!scalar_check (status
, 0))
7095 gfc_check_flush (gfc_expr
*unit
)
7100 if (!type_check (unit
, 0, BT_INTEGER
))
7103 if (!scalar_check (unit
, 0))
7111 gfc_check_free (gfc_expr
*i
)
7113 if (!type_check (i
, 0, BT_INTEGER
))
7116 if (!scalar_check (i
, 0))
7124 gfc_check_hostnm (gfc_expr
*name
)
7126 if (!type_check (name
, 0, BT_CHARACTER
))
7128 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7136 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
7138 if (!type_check (name
, 0, BT_CHARACTER
))
7140 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7146 if (!scalar_check (status
, 1))
7149 if (!type_check (status
, 1, BT_INTEGER
))
7157 gfc_check_itime_idate (gfc_expr
*values
)
7159 if (!array_check (values
, 0))
7162 if (!rank_check (values
, 0, 1))
7165 if (!variable_check (values
, 0, false))
7168 if (!type_check (values
, 0, BT_INTEGER
))
7171 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
7179 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
7181 if (!type_check (time
, 0, BT_INTEGER
))
7184 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
7187 if (!scalar_check (time
, 0))
7190 if (!array_check (values
, 1))
7193 if (!rank_check (values
, 1, 1))
7196 if (!variable_check (values
, 1, false))
7199 if (!type_check (values
, 1, BT_INTEGER
))
7202 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
7210 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
7212 if (!scalar_check (unit
, 0))
7215 if (!type_check (unit
, 0, BT_INTEGER
))
7218 if (!type_check (name
, 1, BT_CHARACTER
))
7220 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
7228 gfc_check_is_contiguous (gfc_expr
*array
)
7230 if (array
->expr_type
== EXPR_NULL
)
7232 gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7233 "associated pointer", &array
->where
, gfc_current_intrinsic
);
7237 if (!array_check (array
, 0))
7245 gfc_check_isatty (gfc_expr
*unit
)
7250 if (!type_check (unit
, 0, BT_INTEGER
))
7253 if (!scalar_check (unit
, 0))
7261 gfc_check_isnan (gfc_expr
*x
)
7263 if (!type_check (x
, 0, BT_REAL
))
7271 gfc_check_perror (gfc_expr
*string
)
7273 if (!type_check (string
, 0, BT_CHARACTER
))
7275 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
7283 gfc_check_umask (gfc_expr
*mask
)
7285 if (!type_check (mask
, 0, BT_INTEGER
))
7288 if (!scalar_check (mask
, 0))
7296 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
7298 if (!type_check (mask
, 0, BT_INTEGER
))
7301 if (!scalar_check (mask
, 0))
7307 if (!scalar_check (old
, 1))
7310 if (!type_check (old
, 1, BT_INTEGER
))
7318 gfc_check_unlink (gfc_expr
*name
)
7320 if (!type_check (name
, 0, BT_CHARACTER
))
7322 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7330 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
7332 if (!type_check (name
, 0, BT_CHARACTER
))
7334 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7340 if (!scalar_check (status
, 1))
7343 if (!type_check (status
, 1, BT_INTEGER
))
7351 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
7353 if (!scalar_check (number
, 0))
7355 if (!type_check (number
, 0, BT_INTEGER
))
7358 if (!int_or_proc_check (handler
, 1))
7360 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7368 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
7370 if (!scalar_check (number
, 0))
7372 if (!type_check (number
, 0, BT_INTEGER
))
7375 if (!int_or_proc_check (handler
, 1))
7377 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7383 if (!type_check (status
, 2, BT_INTEGER
))
7385 if (!scalar_check (status
, 2))
7393 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
7395 if (!type_check (cmd
, 0, BT_CHARACTER
))
7397 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
7400 if (!scalar_check (status
, 1))
7403 if (!type_check (status
, 1, BT_INTEGER
))
7406 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
7413 /* This is used for the GNU intrinsics AND, OR and XOR. */
7415 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
7417 if (i
->ts
.type
!= BT_INTEGER
7418 && i
->ts
.type
!= BT_LOGICAL
7419 && i
->ts
.type
!= BT_BOZ
)
7421 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7422 "LOGICAL, or a BOZ literal constant",
7423 gfc_current_intrinsic_arg
[0]->name
,
7424 gfc_current_intrinsic
, &i
->where
);
7428 if (j
->ts
.type
!= BT_INTEGER
7429 && j
->ts
.type
!= BT_LOGICAL
7430 && j
->ts
.type
!= BT_BOZ
)
7432 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7433 "LOGICAL, or a BOZ literal constant",
7434 gfc_current_intrinsic_arg
[1]->name
,
7435 gfc_current_intrinsic
, &j
->where
);
7439 /* i and j cannot both be BOZ literal constants. */
7440 if (!boz_args_check (i
, j
))
7443 /* If i is BOZ and j is integer, convert i to type of j. */
7444 if (i
->ts
.type
== BT_BOZ
)
7446 if (j
->ts
.type
!= BT_INTEGER
)
7448 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7449 gfc_current_intrinsic_arg
[1]->name
,
7450 gfc_current_intrinsic
, &j
->where
);
7454 if (!gfc_boz2int (i
, j
->ts
.kind
))
7458 /* If j is BOZ and i is integer, convert j to type of i. */
7459 if (j
->ts
.type
== BT_BOZ
)
7461 if (i
->ts
.type
!= BT_INTEGER
)
7463 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7464 gfc_current_intrinsic_arg
[0]->name
,
7465 gfc_current_intrinsic
, &j
->where
);
7469 if (!gfc_boz2int (j
, i
->ts
.kind
))
7473 if (!same_type_check (i
, 0, j
, 1, false))
7476 if (!scalar_check (i
, 0))
7479 if (!scalar_check (j
, 1))
7487 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
7490 if (a
->expr_type
== EXPR_NULL
)
7492 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7493 "argument to STORAGE_SIZE, because it returns a "
7494 "disassociated pointer", &a
->where
);
7498 if (a
->ts
.type
== BT_ASSUMED
)
7500 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7501 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7506 if (a
->ts
.type
== BT_PROCEDURE
)
7508 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7509 "procedure", gfc_current_intrinsic_arg
[0]->name
,
7510 gfc_current_intrinsic
, &a
->where
);
7514 if (a
->ts
.type
== BT_BOZ
&& illegal_boz_arg (a
))
7520 if (!type_check (kind
, 1, BT_INTEGER
))
7523 if (!scalar_check (kind
, 1))
7526 if (kind
->expr_type
!= EXPR_CONSTANT
)
7528 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7529 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,