2 Copyright (C) 2002-2021 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.c(resolve_function). */
42 reset_boz (gfc_expr
*x
)
49 x
->ts
.type
= BT_INTEGER
;
50 x
->ts
.kind
= gfc_default_integer_kind
;
51 mpz_init (x
->value
.integer
);
52 mpz_set_ui (x
->value
.integer
, 0);
55 /* A BOZ literal constant can appear in a limited number of contexts.
56 gfc_invalid_boz() is a helper function to simplify error/warning
57 generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran
58 allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz
59 is used, then issue a warning; otherwise issue an error. */
62 gfc_invalid_boz (const char *msg
, locus
*loc
)
64 if (flag_allow_invalid_boz
)
66 gfc_warning (0, msg
, loc
);
70 const char *hint
= _(" [see %<-fno-allow-invalid-boz%>]");
71 size_t len
= strlen (msg
) + strlen (hint
) + 1;
72 char *msg2
= (char *) alloca (len
);
75 gfc_error (msg2
, loc
);
80 /* Issue an error for an illegal BOZ argument. */
83 illegal_boz_arg (gfc_expr
*x
)
85 if (x
->ts
.type
== BT_BOZ
)
87 gfc_error ("BOZ literal constant at %L cannot be an actual argument "
88 "to %qs", &x
->where
, gfc_current_intrinsic
);
96 /* Some precedures take two arguments such that both cannot be BOZ. */
99 boz_args_check(gfc_expr
*i
, gfc_expr
*j
)
101 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_BOZ
)
103 gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
104 "literal constants", gfc_current_intrinsic
, &i
->where
,
116 /* Check that a BOZ is a constant. */
119 is_boz_constant (gfc_expr
*a
)
121 if (a
->expr_type
!= EXPR_CONSTANT
)
123 gfc_error ("Invalid use of BOZ literal constant at %L", &a
->where
);
131 /* Convert a octal string into a binary string. This is used in the
132 fallback conversion of an octal string to a REAL. */
135 oct2bin(int nbits
, char *oct
)
137 const char bits
[8][5] = {
138 "000", "001", "010", "011", "100", "101", "110", "111"};
144 if (nbits
== 64) j
++;
146 bufp
= buf
= XCNEWVEC (char, j
+ 1);
147 memset (bufp
, 0, j
+ 1);
150 for (i
= 0; i
< n
; i
++, oct
++)
153 strcpy (bufp
, &bits
[j
][0]);
157 bufp
= XCNEWVEC (char, nbits
+ 1);
159 strcpy (bufp
, buf
+ 2);
161 strcpy (bufp
, buf
+ 1);
169 /* Convert a hexidecimal string into a binary string. This is used in the
170 fallback conversion of a hexidecimal string to a REAL. */
173 hex2bin(int nbits
, char *hex
)
175 const char bits
[16][5] = {
176 "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111",
177 "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"};
182 bufp
= buf
= XCNEWVEC (char, nbits
+ 1);
183 memset (bufp
, 0, nbits
+ 1);
186 for (i
= 0; i
< n
; i
++, hex
++)
189 if (j
> 47 && j
< 58)
191 else if (j
> 64 && j
< 71)
193 else if (j
> 96 && j
< 103)
198 strcpy (bufp
, &bits
[j
][0]);
206 /* Fallback conversion of a BOZ string to REAL. */
209 bin2real (gfc_expr
*x
, int kind
)
216 i
= gfc_validate_kind (BT_REAL
, kind
, false);
217 t
= gfc_real_kinds
[i
].digits
- 1;
219 /* Number of bits in the exponent. */
220 if (gfc_real_kinds
[i
].max_exponent
== 16384)
222 else if (gfc_real_kinds
[i
].max_exponent
== 1024)
227 if (x
->boz
.rdx
== 16)
228 sp
= hex2bin (gfc_real_kinds
[i
].mode_precision
, x
->boz
.str
);
229 else if (x
->boz
.rdx
== 8)
230 sp
= oct2bin (gfc_real_kinds
[i
].mode_precision
, x
->boz
.str
);
234 /* Extract sign bit. */
237 /* Extract biased exponent. */
238 memset (buf
, 0, 114);
239 strncpy (buf
, ++sp
, w
);
241 mpz_set_str (em
, buf
, 2);
242 ie
= mpz_get_si (em
);
244 mpfr_init2 (x
->value
.real
, t
+ 1);
245 x
->ts
.type
= BT_REAL
;
248 sp
+= w
; /* Set to first digit in significand. */
250 if ((i
== 0 && ie
== b
) || (i
== 1 && ie
== b
)
251 || ((i
== 2 || i
== 3) && ie
== b
))
265 mpfr_set_inf (x
->value
.real
, 1);
267 mpfr_set_nan (x
->value
.real
);
272 strncpy (buf
, sp
, t
+ 1);
275 /* Significand with hidden bit. */
277 strncpy (&buf
[1], sp
, t
);
280 /* Convert to significand to integer. */
281 mpz_set_str (em
, buf
, 2);
282 ie
-= ((1 << (w
- 1)) - 1); /* Unbiased exponent. */
283 mpfr_set_z_2exp (x
->value
.real
, em
, ie
- t
, GFC_RND_MODE
);
286 if (sgn
) mpfr_neg (x
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
292 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
293 converts the string into a REAL of the appropriate kind. The treatment
294 of the sign bit is processor dependent. */
297 gfc_boz2real (gfc_expr
*x
, int kind
)
299 extern int gfc_max_integer_kind
;
304 if (!is_boz_constant (x
))
307 /* Determine the length of the required string. */
309 if (x
->boz
.rdx
== 16) len
/= 4;
310 if (x
->boz
.rdx
== 8) len
= len
/ 3 + 1;
311 buf
= (char *) alloca (len
+ 1); /* +1 for NULL terminator. */
313 if (x
->boz
.len
>= len
) /* Truncate if necessary. */
315 str
= x
->boz
.str
+ (x
->boz
.len
- len
);
318 else /* Copy and pad. */
320 memset (buf
, 48, len
);
321 str
= buf
+ (len
- x
->boz
.len
);
322 strcpy (str
, x
->boz
.str
);
325 /* Need to adjust leading bits in an octal string. */
328 /* Clear first bit. */
329 if (kind
== 4 || kind
== 10 || kind
== 16)
333 else if (buf
[0] == '5')
335 else if (buf
[0] == '6')
337 else if (buf
[0] == '7')
340 /* Clear first two bits. */
343 if (buf
[0] == '2' || buf
[0] == '4' || buf
[0] == '6')
345 else if (buf
[0] == '3' || buf
[0] == '5' || buf
[0] == '7')
350 /* Reset BOZ string to the truncated or padded version. */
353 x
->boz
.str
= XCNEWVEC (char, len
+ 1);
354 strncpy (x
->boz
.str
, buf
, len
);
356 /* For some targets, the largest INTEGER in terms of bits is smaller than
357 the bits needed to hold the REAL. Fortunately, the kind type parameter
358 indicates the number of bytes required to an INTEGER and a REAL. */
359 if (gfc_max_integer_kind
< kind
)
365 /* Convert to widest possible integer. */
366 gfc_boz2int (x
, gfc_max_integer_kind
);
369 if (!gfc_convert_boz (x
, &ts
))
371 gfc_error ("Failure in conversion of BOZ to REAL at %L", &x
->where
);
380 /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int ()
381 converts the string into an INTEGER of the appropriate kind. The
382 treatment of the sign bit is processor dependent. If the converted
383 value exceeds the range of the type, then wrap-around semantics are
387 gfc_boz2int (gfc_expr
*x
, int kind
)
393 if (!is_boz_constant (x
))
396 i
= gfc_validate_kind (BT_INTEGER
, kind
, false);
397 len
= gfc_integer_kinds
[i
].bit_size
;
398 if (x
->boz
.rdx
== 16) len
/= 4;
399 if (x
->boz
.rdx
== 8) len
= len
/ 3 + 1;
400 buf
= (char *) alloca (len
+ 1); /* +1 for NULL terminator. */
402 if (x
->boz
.len
>= len
) /* Truncate if necessary. */
404 str
= x
->boz
.str
+ (x
->boz
.len
- len
);
407 else /* Copy and pad. */
409 memset (buf
, 48, len
);
410 str
= buf
+ (len
- x
->boz
.len
);
411 strcpy (str
, x
->boz
.str
);
414 /* Need to adjust leading bits in an octal string. */
417 /* Clear first bit. */
418 if (kind
== 1 || kind
== 4 || kind
== 16)
422 else if (buf
[0] == '5')
424 else if (buf
[0] == '6')
426 else if (buf
[0] == '7')
429 /* Clear first two bits. */
432 if (buf
[0] == '2' || buf
[0] == '4' || buf
[0] == '6')
434 else if (buf
[0] == '3' || buf
[0] == '5' || buf
[0] == '7')
439 /* Convert as-if unsigned integer. */
441 mpz_set_str (tmp1
, buf
, x
->boz
.rdx
);
443 /* Check for wrap-around. */
444 if (mpz_cmp (tmp1
, gfc_integer_kinds
[i
].huge
) > 0)
448 mpz_add_ui (tmp2
, gfc_integer_kinds
[i
].huge
, 1);
449 mpz_mod (tmp1
, tmp1
, tmp2
);
450 mpz_sub (tmp1
, tmp1
, tmp2
);
454 /* Clear boz info. */
459 mpz_init (x
->value
.integer
);
460 mpz_set (x
->value
.integer
, tmp1
);
461 x
->ts
.type
= BT_INTEGER
;
469 /* Make sure an expression is a scalar. */
472 scalar_check (gfc_expr
*e
, int n
)
477 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
478 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
485 /* Check the type of an expression. */
488 type_check (gfc_expr
*e
, int n
, bt type
)
490 if (e
->ts
.type
== type
)
493 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
494 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
495 &e
->where
, gfc_basic_typename (type
));
501 /* Check that the expression is a numeric type. */
504 numeric_check (gfc_expr
*e
, int n
)
506 /* Users sometime use a subroutine designator as an actual argument to
507 an intrinsic subprogram that expects an argument with a numeric type. */
508 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.subroutine
)
511 if (gfc_numeric_ts (&e
->ts
))
514 /* If the expression has not got a type, check if its namespace can
515 offer a default type. */
516 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
517 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
518 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, e
->symtree
->n
.sym
->ns
)
519 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
521 e
->ts
= e
->symtree
->n
.sym
->ts
;
527 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
528 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
535 /* Check that an expression is integer or real. */
538 int_or_real_check (gfc_expr
*e
, int n
)
540 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
542 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
543 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
544 gfc_current_intrinsic
, &e
->where
);
551 /* Check that an expression is integer or real; allow character for
555 int_or_real_or_char_check_f2003 (gfc_expr
*e
, int n
)
557 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
559 if (e
->ts
.type
== BT_CHARACTER
)
560 return gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Character for "
561 "%qs argument of %qs intrinsic at %L",
562 gfc_current_intrinsic_arg
[n
]->name
,
563 gfc_current_intrinsic
, &e
->where
);
566 if (gfc_option
.allow_std
& GFC_STD_F2003
)
567 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
568 "or REAL or CHARACTER",
569 gfc_current_intrinsic_arg
[n
]->name
,
570 gfc_current_intrinsic
, &e
->where
);
572 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
573 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
574 gfc_current_intrinsic
, &e
->where
);
582 /* Check that an expression is an intrinsic type. */
584 intrinsic_type_check (gfc_expr
*e
, int n
)
586 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
587 && e
->ts
.type
!= BT_COMPLEX
&& e
->ts
.type
!= BT_CHARACTER
588 && e
->ts
.type
!= BT_LOGICAL
)
590 gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
591 gfc_current_intrinsic_arg
[n
]->name
,
592 gfc_current_intrinsic
, &e
->where
);
598 /* Check that an expression is real or complex. */
601 real_or_complex_check (gfc_expr
*e
, int n
)
603 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
605 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
606 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
607 gfc_current_intrinsic
, &e
->where
);
615 /* Check that an expression is INTEGER or PROCEDURE. */
618 int_or_proc_check (gfc_expr
*e
, int n
)
620 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
622 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
623 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
624 gfc_current_intrinsic
, &e
->where
);
632 /* Check that the expression is an optional constant integer
633 and that it specifies a valid kind for that type. */
636 kind_check (gfc_expr
*k
, int n
, bt type
)
643 if (!type_check (k
, n
, BT_INTEGER
))
646 if (!scalar_check (k
, n
))
649 if (!gfc_check_init_expr (k
))
651 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
652 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
657 if (gfc_extract_int (k
, &kind
)
658 || gfc_validate_kind (type
, kind
, true) < 0)
660 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
669 /* Make sure the expression is a double precision real. */
672 double_check (gfc_expr
*d
, int n
)
674 if (!type_check (d
, n
, BT_REAL
))
677 if (d
->ts
.kind
!= gfc_default_double_kind
)
679 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
680 "precision", gfc_current_intrinsic_arg
[n
]->name
,
681 gfc_current_intrinsic
, &d
->where
);
690 coarray_check (gfc_expr
*e
, int n
)
692 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
693 && CLASS_DATA (e
)->attr
.codimension
694 && CLASS_DATA (e
)->as
->corank
)
696 gfc_add_class_array_ref (e
);
700 if (!gfc_is_coarray (e
))
702 gfc_error ("Expected coarray variable as %qs argument to the %s "
703 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
704 gfc_current_intrinsic
, &e
->where
);
712 /* Make sure the expression is a logical array. */
715 logical_array_check (gfc_expr
*array
, int n
)
717 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
719 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
720 "array", gfc_current_intrinsic_arg
[n
]->name
,
721 gfc_current_intrinsic
, &array
->where
);
729 /* Make sure an expression is an array. */
732 array_check (gfc_expr
*e
, int n
)
734 if (e
->rank
!= 0 && e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
735 && CLASS_DATA (e
)->attr
.dimension
736 && CLASS_DATA (e
)->as
->rank
)
738 gfc_add_class_array_ref (e
);
741 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
744 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
745 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
752 /* If expr is a constant, then check to ensure that it is greater than
756 nonnegative_check (const char *arg
, gfc_expr
*expr
)
760 if (expr
->expr_type
== EXPR_CONSTANT
)
762 gfc_extract_int (expr
, &i
);
765 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
774 /* If expr is a constant, then check to ensure that it is greater than zero. */
777 positive_check (int n
, gfc_expr
*expr
)
781 if (expr
->expr_type
== EXPR_CONSTANT
)
783 gfc_extract_int (expr
, &i
);
786 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
787 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
797 /* If expr2 is constant, then check that the value is less than
798 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
801 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
802 gfc_expr
*expr2
, bool or_equal
)
806 if (expr2
->expr_type
== EXPR_CONSTANT
)
808 gfc_extract_int (expr2
, &i2
);
809 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
811 /* For ISHFT[C], check that |shift| <= bit_size(i). */
817 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
819 gfc_error ("The absolute value of SHIFT at %L must be less "
820 "than or equal to BIT_SIZE(%qs)",
821 &expr2
->where
, arg1
);
828 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
830 gfc_error ("%qs at %L must be less than "
831 "or equal to BIT_SIZE(%qs)",
832 arg2
, &expr2
->where
, arg1
);
838 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
840 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
841 arg2
, &expr2
->where
, arg1
);
851 /* If expr is constant, then check that the value is less than or equal
852 to the bit_size of the kind k. */
855 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
859 if (expr
->expr_type
!= EXPR_CONSTANT
)
862 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
863 gfc_extract_int (expr
, &val
);
865 if (val
> gfc_integer_kinds
[i
].bit_size
)
867 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
868 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
876 /* If expr2 and expr3 are constants, then check that the value is less than
877 or equal to bit_size(expr1). */
880 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
881 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
885 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
887 gfc_extract_int (expr2
, &i2
);
888 gfc_extract_int (expr3
, &i3
);
890 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
891 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
893 gfc_error ("%<%s + %s%> at %L must be less than or equal "
895 arg2
, arg3
, &expr2
->where
, arg1
);
903 /* Make sure two expressions have the same type. */
906 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
, bool assoc
= false)
908 gfc_typespec
*ets
= &e
->ts
;
909 gfc_typespec
*fts
= &f
->ts
;
913 /* Procedure pointer component expressions have the type of the interface
914 procedure. If they are being tested for association with a procedure
915 pointer (ie. not a component), the type of the procedure must be
917 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
918 ets
= &e
->symtree
->n
.sym
->ts
;
919 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
920 fts
= &f
->symtree
->n
.sym
->ts
;
923 if (gfc_compare_types (ets
, fts
))
926 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
927 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
928 gfc_current_intrinsic
, &f
->where
,
929 gfc_current_intrinsic_arg
[n
]->name
);
935 /* Make sure that an expression has a certain (nonzero) rank. */
938 rank_check (gfc_expr
*e
, int n
, int rank
)
943 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
944 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
951 /* Make sure a variable expression is not an optional dummy argument. */
954 nonoptional_check (gfc_expr
*e
, int n
)
956 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
958 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
959 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
963 /* TODO: Recursive check on nonoptional variables? */
969 /* Check for ALLOCATABLE attribute. */
972 allocatable_check (gfc_expr
*e
, int n
)
974 symbol_attribute attr
;
976 attr
= gfc_variable_attr (e
, NULL
);
977 if (!attr
.allocatable
978 || (attr
.associate_var
&& !attr
.select_rank_temporary
))
980 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
981 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
990 /* Check that an expression has a particular kind. */
993 kind_value_check (gfc_expr
*e
, int n
, int k
)
998 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
999 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
1006 /* Make sure an expression is a variable. */
1009 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
1011 if (e
->expr_type
== EXPR_VARIABLE
1012 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
1013 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
1014 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
1017 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1018 && CLASS_DATA (e
->symtree
->n
.sym
)
1019 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
1020 : e
->symtree
->n
.sym
->attr
.pointer
;
1022 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1024 if (pointer
&& ref
->type
== REF_COMPONENT
)
1026 if (ref
->type
== REF_COMPONENT
1027 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1028 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
1029 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1030 && ref
->u
.c
.component
->attr
.pointer
)))
1036 gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
1037 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
1038 gfc_current_intrinsic
, &e
->where
);
1043 if (e
->expr_type
== EXPR_VARIABLE
1044 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
1045 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
1048 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
1049 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
1052 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1053 if (ns
->proc_name
== e
->symtree
->n
.sym
)
1057 /* F2018:R902: function reference having a data pointer result. */
1058 if (e
->expr_type
== EXPR_FUNCTION
1059 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1060 && e
->symtree
->n
.sym
->attr
.function
1061 && e
->symtree
->n
.sym
->attr
.pointer
)
1064 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
1065 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
1071 /* Check the common DIM parameter for correctness. */
1074 dim_check (gfc_expr
*dim
, int n
, bool optional
)
1079 if (!type_check (dim
, n
, BT_INTEGER
))
1082 if (!scalar_check (dim
, n
))
1085 if (!optional
&& !nonoptional_check (dim
, n
))
1092 /* If a coarray DIM parameter is a constant, make sure that it is greater than
1093 zero and less than or equal to the corank of the given array. */
1096 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
1100 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
1102 if (dim
->expr_type
!= EXPR_CONSTANT
)
1105 if (array
->ts
.type
== BT_CLASS
)
1108 corank
= gfc_get_corank (array
);
1110 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1111 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
1113 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1114 "codimension index", gfc_current_intrinsic
, &dim
->where
);
1123 /* If a DIM parameter is a constant, make sure that it is greater than
1124 zero and less than or equal to the rank of the given array. If
1125 allow_assumed is zero then dim must be less than the rank of the array
1126 for assumed size arrays. */
1129 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
1137 if (dim
->expr_type
!= EXPR_CONSTANT
)
1140 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
1141 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
1142 rank
= array
->rank
+ 1;
1146 /* Assumed-rank array. */
1148 rank
= GFC_MAX_DIMENSIONS
;
1150 if (array
->expr_type
== EXPR_VARIABLE
)
1152 ar
= gfc_find_array_ref (array
, true);
1155 if (ar
->as
->type
== AS_ASSUMED_SIZE
1157 && ar
->type
!= AR_ELEMENT
1158 && ar
->type
!= AR_SECTION
)
1162 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1163 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
1165 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1166 "dimension index", gfc_current_intrinsic
, &dim
->where
);
1175 /* Compare the size of a along dimension ai with the size of b along
1176 dimension bi, returning 0 if they are known not to be identical,
1177 and 1 if they are identical, or if this cannot be determined. */
1180 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
1182 mpz_t a_size
, b_size
;
1185 gcc_assert (a
->rank
> ai
);
1186 gcc_assert (b
->rank
> bi
);
1190 if (gfc_array_dimen_size (a
, ai
, &a_size
))
1192 if (gfc_array_dimen_size (b
, bi
, &b_size
))
1194 if (mpz_cmp (a_size
, b_size
) != 0)
1204 /* Calculate the length of a character variable, including substrings.
1205 Strip away parentheses if necessary. Return -1 if no length could
1209 gfc_var_strlen (const gfc_expr
*a
)
1213 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
1214 a
= a
->value
.op
.op1
;
1216 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
1221 long start_a
, end_a
;
1226 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1227 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1229 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
1231 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
1232 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
1234 else if (ra
->u
.ss
.start
1235 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
1241 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
1242 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1243 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
1244 else if (a
->expr_type
== EXPR_CONSTANT
1245 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
1246 return a
->value
.character
.length
;
1252 /* Check whether two character expressions have the same length;
1253 returns true if they have or if the length cannot be determined,
1254 otherwise return false and raise a gfc_error. */
1257 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
1261 len_a
= gfc_var_strlen(a
);
1262 len_b
= gfc_var_strlen(b
);
1264 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
1268 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
1269 len_a
, len_b
, name
, &a
->where
);
1275 /***** Check functions *****/
1277 /* Check subroutine suitable for intrinsics taking a real argument and
1278 a kind argument for the result. */
1281 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
1283 if (!type_check (a
, 0, BT_REAL
))
1285 if (!kind_check (kind
, 1, type
))
1292 /* Check subroutine suitable for ceiling, floor and nint. */
1295 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
1297 return check_a_kind (a
, kind
, BT_INTEGER
);
1301 /* Check subroutine suitable for aint, anint. */
1304 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
1306 return check_a_kind (a
, kind
, BT_REAL
);
1311 gfc_check_abs (gfc_expr
*a
)
1313 if (!numeric_check (a
, 0))
1321 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
1323 if (a
->ts
.type
== BT_BOZ
)
1325 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1326 "ACHAR intrinsic subprogram"), &a
->where
))
1329 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
1333 if (!type_check (a
, 0, BT_INTEGER
))
1336 if (!kind_check (kind
, 1, BT_CHARACTER
))
1344 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
1346 if (!type_check (name
, 0, BT_CHARACTER
)
1347 || !scalar_check (name
, 0))
1349 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1352 if (!type_check (mode
, 1, BT_CHARACTER
)
1353 || !scalar_check (mode
, 1))
1355 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1363 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
1365 if (!logical_array_check (mask
, 0))
1368 if (!dim_check (dim
, 1, false))
1371 if (!dim_rank_check (dim
, mask
, 0))
1378 /* Limited checking for ALLOCATED intrinsic. Additional checking
1379 is performed in intrinsic.c(sort_actual), because ALLOCATED
1380 has two mutually exclusive non-optional arguments. */
1383 gfc_check_allocated (gfc_expr
*array
)
1385 /* Tests on allocated components of coarrays need to detour the check to
1386 argument of the _caf_get. */
1387 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
1388 && array
->value
.function
.isym
1389 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1391 array
= array
->value
.function
.actual
->expr
;
1396 if (!variable_check (array
, 0, false))
1398 if (!allocatable_check (array
, 0))
1405 /* Common check function where the first argument must be real or
1406 integer and the second argument must be the same as the first. */
1409 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
1411 if (!int_or_real_check (a
, 0))
1414 if (a
->ts
.type
!= p
->ts
.type
)
1416 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
1417 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
1418 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1423 if (a
->ts
.kind
!= p
->ts
.kind
)
1425 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1435 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
1437 if (!double_check (x
, 0) || !double_check (y
, 1))
1444 gfc_invalid_null_arg (gfc_expr
*x
)
1446 if (x
->expr_type
== EXPR_NULL
)
1448 gfc_error ("NULL at %L is not permitted as actual argument "
1449 "to %qs intrinsic function", &x
->where
,
1450 gfc_current_intrinsic
);
1457 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
1459 symbol_attribute attr1
, attr2
;
1463 if (gfc_invalid_null_arg (pointer
))
1466 attr1
= gfc_expr_attr (pointer
);
1468 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
1470 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
1471 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1477 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
1479 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1480 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
1481 gfc_current_intrinsic
, &pointer
->where
);
1485 /* Target argument is optional. */
1489 if (gfc_invalid_null_arg (target
))
1492 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
1493 attr2
= gfc_expr_attr (target
);
1496 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1497 "or target VARIABLE or FUNCTION",
1498 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1503 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
1505 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1506 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
1507 gfc_current_intrinsic
, &target
->where
);
1512 if (attr1
.pointer
&& gfc_is_coindexed (target
))
1514 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1515 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1516 gfc_current_intrinsic
, &target
->where
);
1521 if (!same_type_check (pointer
, 0, target
, 1, true))
1523 if (!rank_check (target
, 0, pointer
->rank
))
1525 if (target
->rank
> 0)
1527 for (i
= 0; i
< target
->rank
; i
++)
1528 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1530 gfc_error ("Array section with a vector subscript at %L shall not "
1531 "be the target of a pointer",
1542 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1544 /* gfc_notify_std would be a waste of time as the return value
1545 is seemingly used only for the generic resolution. The error
1546 will be: Too many arguments. */
1547 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1550 return gfc_check_atan2 (y
, x
);
1555 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1557 if (!type_check (y
, 0, BT_REAL
))
1559 if (!same_type_check (y
, 0, x
, 1))
1567 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1568 gfc_expr
*stat
, int stat_no
)
1570 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1573 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1574 && !(atom
->ts
.type
== BT_LOGICAL
1575 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1577 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1578 "integer of ATOMIC_INT_KIND or a logical of "
1579 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1583 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1585 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1586 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1590 if (atom
->ts
.type
!= value
->ts
.type
)
1592 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1593 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1594 gfc_current_intrinsic
, &value
->where
,
1595 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1601 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1603 if (!scalar_check (stat
, stat_no
))
1605 if (!variable_check (stat
, stat_no
, false))
1607 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1610 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1611 gfc_current_intrinsic
, &stat
->where
))
1620 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1622 if (atom
->expr_type
== EXPR_FUNCTION
1623 && atom
->value
.function
.isym
1624 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1625 atom
= atom
->value
.function
.actual
->expr
;
1627 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1629 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1630 "definable", gfc_current_intrinsic
, &atom
->where
);
1634 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1639 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1641 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1643 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1644 "integer of ATOMIC_INT_KIND", &atom
->where
,
1645 gfc_current_intrinsic
);
1649 return gfc_check_atomic_def (atom
, value
, stat
);
1654 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1656 if (atom
->expr_type
== EXPR_FUNCTION
1657 && atom
->value
.function
.isym
1658 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1659 atom
= atom
->value
.function
.actual
->expr
;
1661 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1663 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1664 "definable", gfc_current_intrinsic
, &value
->where
);
1668 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1673 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1675 /* IMAGE has to be a positive, scalar integer. */
1676 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1677 || !positive_check (0, image
))
1682 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1683 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1692 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1696 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1697 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1706 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1707 || !positive_check (1, kind
))
1710 /* Get the kind, reporting error on non-constant or overflow. */
1711 gfc_current_locus
= kind
->where
;
1712 if (gfc_extract_int (kind
, &k
, 1))
1714 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1716 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1717 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1718 gfc_current_intrinsic
, &kind
->where
);
1727 gfc_check_get_team (gfc_expr
*level
)
1731 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1732 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1741 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1742 gfc_expr
*new_val
, gfc_expr
*stat
)
1744 if (atom
->expr_type
== EXPR_FUNCTION
1745 && atom
->value
.function
.isym
1746 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1747 atom
= atom
->value
.function
.actual
->expr
;
1749 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1752 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1755 if (!same_type_check (atom
, 0, old
, 1))
1758 if (!same_type_check (atom
, 0, compare
, 2))
1761 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1763 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1764 "definable", gfc_current_intrinsic
, &atom
->where
);
1768 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1770 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1771 "definable", gfc_current_intrinsic
, &old
->where
);
1779 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1781 if (event
->ts
.type
!= BT_DERIVED
1782 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1783 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1785 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1786 "shall be of type EVENT_TYPE", &event
->where
);
1790 if (!scalar_check (event
, 0))
1793 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1795 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1796 "shall be definable", &count
->where
);
1800 if (!type_check (count
, 1, BT_INTEGER
))
1803 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1804 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1806 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1808 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1809 "shall have at least the range of the default integer",
1816 if (!type_check (stat
, 2, BT_INTEGER
))
1818 if (!scalar_check (stat
, 2))
1820 if (!variable_check (stat
, 2, false))
1823 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1824 gfc_current_intrinsic
, &stat
->where
))
1833 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1836 if (atom
->expr_type
== EXPR_FUNCTION
1837 && atom
->value
.function
.isym
1838 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1839 atom
= atom
->value
.function
.actual
->expr
;
1841 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1843 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1844 "integer of ATOMIC_INT_KIND", &atom
->where
,
1845 gfc_current_intrinsic
);
1849 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1852 if (!scalar_check (old
, 2))
1855 if (!same_type_check (atom
, 0, old
, 2))
1858 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1860 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1861 "definable", gfc_current_intrinsic
, &atom
->where
);
1865 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1867 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1868 "definable", gfc_current_intrinsic
, &old
->where
);
1876 /* BESJN and BESYN functions. */
1879 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1881 if (!type_check (n
, 0, BT_INTEGER
))
1883 if (n
->expr_type
== EXPR_CONSTANT
)
1886 gfc_extract_int (n
, &i
);
1887 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1888 "N at %L", &n
->where
))
1892 if (!type_check (x
, 1, BT_REAL
))
1899 /* Transformational version of the Bessel JN and YN functions. */
1902 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1904 if (!type_check (n1
, 0, BT_INTEGER
))
1906 if (!scalar_check (n1
, 0))
1908 if (!nonnegative_check ("N1", n1
))
1911 if (!type_check (n2
, 1, BT_INTEGER
))
1913 if (!scalar_check (n2
, 1))
1915 if (!nonnegative_check ("N2", n2
))
1918 if (!type_check (x
, 2, BT_REAL
))
1920 if (!scalar_check (x
, 2))
1928 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1930 extern int gfc_max_integer_kind
;
1932 /* If i and j are both BOZ, convert to widest INTEGER. */
1933 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_BOZ
)
1935 if (!gfc_boz2int (i
, gfc_max_integer_kind
))
1937 if (!gfc_boz2int (j
, gfc_max_integer_kind
))
1941 /* If i is BOZ and j is integer, convert i to type of j. */
1942 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
1943 && !gfc_boz2int (i
, j
->ts
.kind
))
1946 /* If j is BOZ and i is integer, convert j to type of i. */
1947 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
1948 && !gfc_boz2int (j
, i
->ts
.kind
))
1951 if (!type_check (i
, 0, BT_INTEGER
))
1954 if (!type_check (j
, 1, BT_INTEGER
))
1962 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1964 if (!type_check (i
, 0, BT_INTEGER
))
1967 if (!type_check (pos
, 1, BT_INTEGER
))
1970 if (!nonnegative_check ("pos", pos
))
1973 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1981 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1983 if (i
->ts
.type
== BT_BOZ
)
1985 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1986 "CHAR intrinsic subprogram"), &i
->where
))
1989 if (!gfc_boz2int (i
, gfc_default_integer_kind
))
1993 if (!type_check (i
, 0, BT_INTEGER
))
1996 if (!kind_check (kind
, 1, BT_CHARACTER
))
2004 gfc_check_chdir (gfc_expr
*dir
)
2006 if (!type_check (dir
, 0, BT_CHARACTER
))
2008 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
2016 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
2018 if (!type_check (dir
, 0, BT_CHARACTER
))
2020 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
2026 if (!type_check (status
, 1, BT_INTEGER
))
2028 if (!scalar_check (status
, 1))
2036 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
2038 if (!type_check (name
, 0, BT_CHARACTER
))
2040 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2043 if (!type_check (mode
, 1, BT_CHARACTER
))
2045 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2053 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
2055 if (!type_check (name
, 0, BT_CHARACTER
))
2057 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2060 if (!type_check (mode
, 1, BT_CHARACTER
))
2062 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2068 if (!type_check (status
, 2, BT_INTEGER
))
2071 if (!scalar_check (status
, 2))
2079 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
2083 /* Check kind first, because it may be needed in conversion of a BOZ. */
2086 if (!kind_check (kind
, 2, BT_COMPLEX
))
2088 gfc_extract_int (kind
, &k
);
2091 k
= gfc_default_complex_kind
;
2093 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, k
))
2096 if (!numeric_check (x
, 0))
2101 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, k
))
2104 if (!numeric_check (y
, 1))
2107 if (x
->ts
.type
== BT_COMPLEX
)
2109 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2110 "present if %<x%> is COMPLEX",
2111 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2116 if (y
->ts
.type
== BT_COMPLEX
)
2118 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2119 "of either REAL or INTEGER",
2120 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2126 if (!kind
&& warn_conversion
2127 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
2128 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2129 "COMPLEX(%d) at %L might lose precision, consider using "
2130 "the KIND argument", gfc_typename (&x
->ts
),
2131 gfc_default_real_kind
, &x
->where
);
2132 else if (y
&& !kind
&& warn_conversion
2133 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
2134 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2135 "COMPLEX(%d) at %L might lose precision, consider using "
2136 "the KIND argument", gfc_typename (&y
->ts
),
2137 gfc_default_real_kind
, &y
->where
);
2143 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
2144 gfc_expr
*errmsg
, bool co_reduce
)
2146 if (!variable_check (a
, 0, false))
2149 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
2153 /* Fortran 2008, 12.5.2.4, paragraph 18. */
2154 if (gfc_has_vector_subscript (a
))
2156 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
2157 "subroutine %s shall not have a vector subscript",
2158 &a
->where
, gfc_current_intrinsic
);
2162 if (gfc_is_coindexed (a
))
2164 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
2165 "coindexed", &a
->where
, gfc_current_intrinsic
);
2169 if (image_idx
!= NULL
)
2171 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
2173 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
2179 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
2181 if (!scalar_check (stat
, co_reduce
? 3 : 2))
2183 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
2185 if (stat
->ts
.kind
!= 4)
2187 gfc_error ("The stat= argument at %L must be a kind=4 integer "
2188 "variable", &stat
->where
);
2195 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
2197 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
2199 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
2201 if (errmsg
->ts
.kind
!= 1)
2203 gfc_error ("The errmsg= argument at %L must be a default-kind "
2204 "character variable", &errmsg
->where
);
2209 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2211 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
2221 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
2224 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
2226 gfc_error ("Support for the A argument at %L which is polymorphic A "
2227 "argument or has allocatable components is not yet "
2228 "implemented", &a
->where
);
2231 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
2236 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
2237 gfc_expr
*stat
, gfc_expr
*errmsg
)
2239 symbol_attribute attr
;
2240 gfc_formal_arglist
*formal
;
2243 if (a
->ts
.type
== BT_CLASS
)
2245 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
2250 if (gfc_expr_attr (a
).alloc_comp
)
2252 gfc_error ("Support for the A argument at %L with allocatable components"
2253 " is not yet implemented", &a
->where
);
2257 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
2260 if (!gfc_resolve_expr (op
))
2263 attr
= gfc_expr_attr (op
);
2264 if (!attr
.pure
|| !attr
.function
)
2266 gfc_error ("OPERATOR argument at %L must be a PURE function",
2273 /* None of the intrinsics fulfills the criteria of taking two arguments,
2274 returning the same type and kind as the arguments and being permitted
2275 as actual argument. */
2276 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
2277 op
->symtree
->n
.sym
->name
, &op
->where
);
2281 if (gfc_is_proc_ptr_comp (op
))
2283 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
2284 sym
= comp
->ts
.interface
;
2287 sym
= op
->symtree
->n
.sym
;
2289 formal
= sym
->formal
;
2291 if (!formal
|| !formal
->next
|| formal
->next
->next
)
2293 gfc_error ("The function passed as OPERATOR at %L shall have two "
2294 "arguments", &op
->where
);
2298 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
2299 gfc_set_default_type (sym
->result
, 0, NULL
);
2301 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
2303 gfc_error ("The A argument at %L has type %s but the function passed as "
2304 "OPERATOR at %L returns %s",
2305 &a
->where
, gfc_typename (a
), &op
->where
,
2306 gfc_typename (&sym
->result
->ts
));
2309 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
2310 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
2312 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
2313 "%s and %s but shall have type %s", &op
->where
,
2314 gfc_typename (&formal
->sym
->ts
),
2315 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (a
));
2318 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
2319 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
2320 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
2321 || formal
->next
->sym
->attr
.pointer
)
2323 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
2324 "nonallocatable nonpointer arguments and return a "
2325 "nonallocatable nonpointer scalar", &op
->where
);
2329 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
2331 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
2332 "attribute either for none or both arguments", &op
->where
);
2336 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
2338 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
2339 "attribute either for none or both arguments", &op
->where
);
2343 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
2345 gfc_error ("The function passed as OPERATOR at %L shall have the "
2346 "ASYNCHRONOUS attribute either for none or both arguments",
2351 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
2353 gfc_error ("The function passed as OPERATOR at %L shall not have the "
2354 "OPTIONAL attribute for either of the arguments", &op
->where
);
2358 if (a
->ts
.type
== BT_CHARACTER
)
2361 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
2364 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2365 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2367 cl
= formal
->sym
->ts
.u
.cl
;
2368 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2369 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2371 cl
= formal
->next
->sym
->ts
.u
.cl
;
2372 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2373 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2376 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2377 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2380 && ((formal_size1
&& actual_size
!= formal_size1
)
2381 || (formal_size2
&& actual_size
!= formal_size2
)))
2383 gfc_error ("The character length of the A argument at %L and of the "
2384 "arguments of the OPERATOR at %L shall be the same",
2385 &a
->where
, &op
->where
);
2388 if (actual_size
&& result_size
&& actual_size
!= result_size
)
2390 gfc_error ("The character length of the A argument at %L and of the "
2391 "function result of the OPERATOR at %L shall be the same",
2392 &a
->where
, &op
->where
);
2402 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2405 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
2406 && a
->ts
.type
!= BT_CHARACTER
)
2408 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
2409 "integer, real or character",
2410 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2414 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2419 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2422 if (!numeric_check (a
, 0))
2424 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2429 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
2431 if (!boz_args_check (x
, y
))
2434 if (x
->ts
.type
== BT_BOZ
)
2436 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2437 " intrinsic subprogram"), &x
->where
))
2442 if (y
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (x
, y
->ts
.kind
))
2444 if (y
->ts
.type
== BT_REAL
&& !gfc_boz2real (x
, y
->ts
.kind
))
2448 if (y
->ts
.type
== BT_BOZ
)
2450 if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2451 " intrinsic subprogram"), &y
->where
))
2456 if (x
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (y
, x
->ts
.kind
))
2458 if (x
->ts
.type
== BT_REAL
&& !gfc_boz2real (y
, x
->ts
.kind
))
2462 if (!int_or_real_check (x
, 0))
2464 if (!scalar_check (x
, 0))
2467 if (!int_or_real_check (y
, 1))
2469 if (!scalar_check (y
, 1))
2477 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
2479 if (!logical_array_check (mask
, 0))
2481 if (!dim_check (dim
, 1, false))
2483 if (!dim_rank_check (dim
, mask
, 0))
2485 if (!kind_check (kind
, 2, BT_INTEGER
))
2487 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2488 "with KIND argument at %L",
2489 gfc_current_intrinsic
, &kind
->where
))
2497 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2499 if (!array_check (array
, 0))
2502 if (!type_check (shift
, 1, BT_INTEGER
))
2505 if (!dim_check (dim
, 2, true))
2508 if (!dim_rank_check (dim
, array
, false))
2511 if (array
->rank
== 1 || shift
->rank
== 0)
2513 if (!scalar_check (shift
, 1))
2516 else if (shift
->rank
== array
->rank
- 1)
2521 else if (dim
->expr_type
== EXPR_CONSTANT
)
2522 gfc_extract_int (dim
, &d
);
2529 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2532 if (!identical_dimen_shape (array
, i
, shift
, j
))
2534 gfc_error ("%qs argument of %qs intrinsic at %L has "
2535 "invalid shape in dimension %d (%ld/%ld)",
2536 gfc_current_intrinsic_arg
[1]->name
,
2537 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2538 mpz_get_si (array
->shape
[i
]),
2539 mpz_get_si (shift
->shape
[j
]));
2549 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2550 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2551 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2560 gfc_check_ctime (gfc_expr
*time
)
2562 if (!scalar_check (time
, 0))
2565 if (!type_check (time
, 0, BT_INTEGER
))
2572 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2574 if (!double_check (y
, 0) || !double_check (x
, 1))
2581 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2583 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2586 if (!numeric_check (x
, 0))
2591 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, gfc_default_double_kind
))
2594 if (!numeric_check (y
, 1))
2597 if (x
->ts
.type
== BT_COMPLEX
)
2599 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2600 "present if %<x%> is COMPLEX",
2601 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2606 if (y
->ts
.type
== BT_COMPLEX
)
2608 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2609 "of either REAL or INTEGER",
2610 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2621 gfc_check_dble (gfc_expr
*x
)
2623 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2626 if (!numeric_check (x
, 0))
2634 gfc_check_digits (gfc_expr
*x
)
2636 if (!int_or_real_check (x
, 0))
2644 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2646 switch (vector_a
->ts
.type
)
2649 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2656 if (!numeric_check (vector_b
, 1))
2661 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2662 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2663 gfc_current_intrinsic
, &vector_a
->where
);
2667 if (!rank_check (vector_a
, 0, 1))
2670 if (!rank_check (vector_b
, 1, 1))
2673 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2675 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2676 "intrinsic %<dot_product%>",
2677 gfc_current_intrinsic_arg
[0]->name
,
2678 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2687 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2689 if (!type_check (x
, 0, BT_REAL
)
2690 || !type_check (y
, 1, BT_REAL
))
2693 if (x
->ts
.kind
!= gfc_default_real_kind
)
2695 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2696 "real", gfc_current_intrinsic_arg
[0]->name
,
2697 gfc_current_intrinsic
, &x
->where
);
2701 if (y
->ts
.kind
!= gfc_default_real_kind
)
2703 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2704 "real", gfc_current_intrinsic_arg
[1]->name
,
2705 gfc_current_intrinsic
, &y
->where
);
2713 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2715 /* i and j cannot both be BOZ literal constants. */
2716 if (!boz_args_check (i
, j
))
2719 /* If i is BOZ and j is integer, convert i to type of j. If j is not
2720 an integer, clear the BOZ; otherwise, check that i is an integer. */
2721 if (i
->ts
.type
== BT_BOZ
)
2723 if (j
->ts
.type
!= BT_INTEGER
)
2725 else if (!gfc_boz2int (i
, j
->ts
.kind
))
2728 else if (!type_check (i
, 0, BT_INTEGER
))
2730 if (j
->ts
.type
== BT_BOZ
)
2735 /* If j is BOZ and i is integer, convert j to type of i. If i is not
2736 an integer, clear the BOZ; otherwise, check that i is an integer. */
2737 if (j
->ts
.type
== BT_BOZ
)
2739 if (i
->ts
.type
!= BT_INTEGER
)
2741 else if (!gfc_boz2int (j
, i
->ts
.kind
))
2744 else if (!type_check (j
, 1, BT_INTEGER
))
2747 if (!same_type_check (i
, 0, j
, 1))
2750 if (!type_check (shift
, 2, BT_INTEGER
))
2753 if (!nonnegative_check ("SHIFT", shift
))
2756 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2764 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2769 if (!array_check (array
, 0))
2772 if (!type_check (shift
, 1, BT_INTEGER
))
2775 if (!dim_check (dim
, 3, true))
2778 if (!dim_rank_check (dim
, array
, false))
2783 else if (dim
->expr_type
== EXPR_CONSTANT
)
2784 gfc_extract_int (dim
, &d
);
2788 if (array
->rank
== 1 || shift
->rank
== 0)
2790 if (!scalar_check (shift
, 1))
2793 else if (shift
->rank
== array
->rank
- 1)
2798 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2801 if (!identical_dimen_shape (array
, i
, shift
, j
))
2803 gfc_error ("%qs argument of %qs intrinsic at %L has "
2804 "invalid shape in dimension %d (%ld/%ld)",
2805 gfc_current_intrinsic_arg
[1]->name
,
2806 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2807 mpz_get_si (array
->shape
[i
]),
2808 mpz_get_si (shift
->shape
[j
]));
2818 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2819 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2820 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2824 if (boundary
!= NULL
)
2826 if (!same_type_check (array
, 0, boundary
, 2))
2829 /* Reject unequal string lengths and emit a better error message than
2830 gfc_check_same_strlen would. */
2831 if (array
->ts
.type
== BT_CHARACTER
)
2833 ssize_t len_a
, len_b
;
2835 len_a
= gfc_var_strlen (array
);
2836 len_b
= gfc_var_strlen (boundary
);
2837 if (len_a
!= -1 && len_b
!= -1 && len_a
!= len_b
)
2839 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2840 gfc_current_intrinsic_arg
[2]->name
,
2841 gfc_current_intrinsic_arg
[0]->name
,
2842 &boundary
->where
, gfc_current_intrinsic
);
2847 if (array
->rank
== 1 || boundary
->rank
== 0)
2849 if (!scalar_check (boundary
, 2))
2852 else if (boundary
->rank
== array
->rank
- 1)
2857 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2861 if (!identical_dimen_shape (array
, i
, boundary
, j
))
2863 gfc_error ("%qs argument of %qs intrinsic at %L has "
2864 "invalid shape in dimension %d (%ld/%ld)",
2865 gfc_current_intrinsic_arg
[2]->name
,
2866 gfc_current_intrinsic
, &shift
->where
, i
+1,
2867 mpz_get_si (array
->shape
[i
]),
2868 mpz_get_si (boundary
->shape
[j
]));
2878 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2879 "rank %d or be a scalar",
2880 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2881 &shift
->where
, array
->rank
- 1);
2887 switch (array
->ts
.type
)
2897 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2898 "of type %qs", gfc_current_intrinsic_arg
[2]->name
,
2899 gfc_current_intrinsic
, &array
->where
,
2900 gfc_current_intrinsic_arg
[0]->name
,
2901 gfc_typename (array
));
2911 gfc_check_float (gfc_expr
*a
)
2913 if (a
->ts
.type
== BT_BOZ
)
2915 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the"
2916 " FLOAT intrinsic subprogram"), &a
->where
))
2921 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
2925 if (!type_check (a
, 0, BT_INTEGER
))
2928 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2929 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2930 "kind argument to %s intrinsic at %L",
2931 gfc_current_intrinsic
, &a
->where
))
2937 /* A single complex argument. */
2940 gfc_check_fn_c (gfc_expr
*a
)
2942 if (!type_check (a
, 0, BT_COMPLEX
))
2949 /* A single real argument. */
2952 gfc_check_fn_r (gfc_expr
*a
)
2954 if (!type_check (a
, 0, BT_REAL
))
2960 /* A single double argument. */
2963 gfc_check_fn_d (gfc_expr
*a
)
2965 if (!double_check (a
, 0))
2971 /* A single real or complex argument. */
2974 gfc_check_fn_rc (gfc_expr
*a
)
2976 if (!real_or_complex_check (a
, 0))
2984 gfc_check_fn_rc2008 (gfc_expr
*a
)
2986 if (!real_or_complex_check (a
, 0))
2989 if (a
->ts
.type
== BT_COMPLEX
2990 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2991 "of %qs intrinsic at %L",
2992 gfc_current_intrinsic_arg
[0]->name
,
2993 gfc_current_intrinsic
, &a
->where
))
3001 gfc_check_fnum (gfc_expr
*unit
)
3003 if (!type_check (unit
, 0, BT_INTEGER
))
3006 if (!scalar_check (unit
, 0))
3014 gfc_check_huge (gfc_expr
*x
)
3016 if (!int_or_real_check (x
, 0))
3024 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
3026 if (!type_check (x
, 0, BT_REAL
))
3028 if (!same_type_check (x
, 0, y
, 1))
3035 /* Check that the single argument is an integer. */
3038 gfc_check_i (gfc_expr
*i
)
3040 if (!type_check (i
, 0, BT_INTEGER
))
3048 gfc_check_iand_ieor_ior (gfc_expr
*i
, gfc_expr
*j
)
3050 /* i and j cannot both be BOZ literal constants. */
3051 if (!boz_args_check (i
, j
))
3054 /* If i is BOZ and j is integer, convert i to type of j. */
3055 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
3056 && !gfc_boz2int (i
, j
->ts
.kind
))
3059 /* If j is BOZ and i is integer, convert j to type of i. */
3060 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
3061 && !gfc_boz2int (j
, i
->ts
.kind
))
3064 if (!type_check (i
, 0, BT_INTEGER
))
3067 if (!type_check (j
, 1, BT_INTEGER
))
3070 if (i
->ts
.kind
!= j
->ts
.kind
)
3072 gfc_error ("Arguments of %qs have different kind type parameters "
3073 "at %L", gfc_current_intrinsic
, &i
->where
);
3082 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
3084 if (!type_check (i
, 0, BT_INTEGER
))
3087 if (!type_check (pos
, 1, BT_INTEGER
))
3090 if (!type_check (len
, 2, BT_INTEGER
))
3093 if (!nonnegative_check ("pos", pos
))
3096 if (!nonnegative_check ("len", len
))
3099 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
3107 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
3111 if (!type_check (c
, 0, BT_CHARACTER
))
3114 if (!kind_check (kind
, 1, BT_INTEGER
))
3117 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3118 "with KIND argument at %L",
3119 gfc_current_intrinsic
, &kind
->where
))
3122 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
3128 /* Substring references don't have the charlength set. */
3130 while (ref
&& ref
->type
!= REF_SUBSTRING
)
3133 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3137 /* Check that the argument is length one. Non-constant lengths
3138 can't be checked here, so assume they are ok. */
3139 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
3141 /* If we already have a length for this expression then use it. */
3142 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3144 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
3151 start
= ref
->u
.ss
.start
;
3152 end
= ref
->u
.ss
.end
;
3155 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3156 || start
->expr_type
!= EXPR_CONSTANT
)
3159 i
= mpz_get_si (end
->value
.integer
) + 1
3160 - mpz_get_si (start
->value
.integer
);
3168 gfc_error ("Argument of %s at %L must be of length one",
3169 gfc_current_intrinsic
, &c
->where
);
3178 gfc_check_idnint (gfc_expr
*a
)
3180 if (!double_check (a
, 0))
3188 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
3191 if (!type_check (string
, 0, BT_CHARACTER
)
3192 || !type_check (substring
, 1, BT_CHARACTER
))
3195 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
3198 if (!kind_check (kind
, 3, BT_INTEGER
))
3200 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3201 "with KIND argument at %L",
3202 gfc_current_intrinsic
, &kind
->where
))
3205 if (string
->ts
.kind
!= substring
->ts
.kind
)
3207 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
3208 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
3209 gfc_current_intrinsic
, &substring
->where
,
3210 gfc_current_intrinsic_arg
[0]->name
);
3219 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
3221 /* BOZ is dealt within simplify_int*. */
3222 if (x
->ts
.type
== BT_BOZ
)
3225 if (!numeric_check (x
, 0))
3228 if (!kind_check (kind
, 1, BT_INTEGER
))
3236 gfc_check_intconv (gfc_expr
*x
)
3238 if (strcmp (gfc_current_intrinsic
, "short") == 0
3239 || strcmp (gfc_current_intrinsic
, "long") == 0)
3241 gfc_error ("%qs intrinsic subprogram at %L has been deprecated. "
3242 "Use INT intrinsic subprogram.", gfc_current_intrinsic
,
3247 /* BOZ is dealt within simplify_int*. */
3248 if (x
->ts
.type
== BT_BOZ
)
3251 if (!numeric_check (x
, 0))
3258 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
3260 if (!type_check (i
, 0, BT_INTEGER
)
3261 || !type_check (shift
, 1, BT_INTEGER
))
3264 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3272 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
3274 if (!type_check (i
, 0, BT_INTEGER
)
3275 || !type_check (shift
, 1, BT_INTEGER
))
3282 if (!type_check (size
, 2, BT_INTEGER
))
3285 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
3288 if (size
->expr_type
== EXPR_CONSTANT
)
3290 gfc_extract_int (size
, &i3
);
3293 gfc_error ("SIZE at %L must be positive", &size
->where
);
3297 if (shift
->expr_type
== EXPR_CONSTANT
)
3299 gfc_extract_int (shift
, &i2
);
3305 gfc_error ("The absolute value of SHIFT at %L must be less "
3306 "than or equal to SIZE at %L", &shift
->where
,
3313 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3321 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
3323 if (!type_check (pid
, 0, BT_INTEGER
))
3326 if (!scalar_check (pid
, 0))
3329 if (!type_check (sig
, 1, BT_INTEGER
))
3332 if (!scalar_check (sig
, 1))
3340 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
3342 if (!type_check (pid
, 0, BT_INTEGER
))
3345 if (!scalar_check (pid
, 0))
3348 if (!type_check (sig
, 1, BT_INTEGER
))
3351 if (!scalar_check (sig
, 1))
3356 if (!type_check (status
, 2, BT_INTEGER
))
3359 if (!scalar_check (status
, 2))
3362 if (status
->expr_type
!= EXPR_VARIABLE
)
3364 gfc_error ("STATUS at %L shall be an INTENT(OUT) variable",
3369 if (status
->expr_type
== EXPR_VARIABLE
3370 && status
->symtree
&& status
->symtree
->n
.sym
3371 && status
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3373 gfc_error ("%qs at %L shall be an INTENT(OUT) variable",
3374 status
->symtree
->name
, &status
->where
);
3384 gfc_check_kind (gfc_expr
*x
)
3386 if (gfc_invalid_null_arg (x
))
3389 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
3391 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3392 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
3393 gfc_current_intrinsic
, &x
->where
);
3396 if (x
->ts
.type
== BT_PROCEDURE
)
3398 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
3399 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3409 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3411 if (!array_check (array
, 0))
3414 if (!dim_check (dim
, 1, false))
3417 if (!dim_rank_check (dim
, array
, 1))
3420 if (!kind_check (kind
, 2, BT_INTEGER
))
3422 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3423 "with KIND argument at %L",
3424 gfc_current_intrinsic
, &kind
->where
))
3432 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
3434 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3436 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3440 if (!coarray_check (coarray
, 0))
3445 if (!dim_check (dim
, 1, false))
3448 if (!dim_corank_check (dim
, coarray
))
3452 if (!kind_check (kind
, 2, BT_INTEGER
))
3460 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
3462 if (!type_check (s
, 0, BT_CHARACTER
))
3465 if (gfc_invalid_null_arg (s
))
3468 if (!kind_check (kind
, 1, BT_INTEGER
))
3470 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3471 "with KIND argument at %L",
3472 gfc_current_intrinsic
, &kind
->where
))
3480 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
3482 if (!type_check (a
, 0, BT_CHARACTER
))
3484 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
3487 if (!type_check (b
, 1, BT_CHARACTER
))
3489 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
3497 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
3499 if (!type_check (path1
, 0, BT_CHARACTER
))
3501 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3504 if (!type_check (path2
, 1, BT_CHARACTER
))
3506 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3514 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3516 if (!type_check (path1
, 0, BT_CHARACTER
))
3518 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3521 if (!type_check (path2
, 1, BT_CHARACTER
))
3523 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
3529 if (!type_check (status
, 2, BT_INTEGER
))
3532 if (!scalar_check (status
, 2))
3540 gfc_check_loc (gfc_expr
*expr
)
3542 return variable_check (expr
, 0, true);
3547 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
3549 if (!type_check (path1
, 0, BT_CHARACTER
))
3551 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3554 if (!type_check (path2
, 1, BT_CHARACTER
))
3556 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3564 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3566 if (!type_check (path1
, 0, BT_CHARACTER
))
3568 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3571 if (!type_check (path2
, 1, BT_CHARACTER
))
3573 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3579 if (!type_check (status
, 2, BT_INTEGER
))
3582 if (!scalar_check (status
, 2))
3590 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
3592 if (!type_check (a
, 0, BT_LOGICAL
))
3594 if (!kind_check (kind
, 1, BT_LOGICAL
))
3601 /* Min/max family. */
3604 min_max_args (gfc_actual_arglist
*args
)
3606 gfc_actual_arglist
*arg
;
3607 int i
, j
, nargs
, *nlabels
, nlabelless
;
3608 bool a1
= false, a2
= false;
3610 if (args
== NULL
|| args
->next
== NULL
)
3612 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3613 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
3620 if (!args
->next
->name
)
3624 for (arg
= args
; arg
; arg
= arg
->next
)
3631 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3633 nlabels
= XALLOCAVEC (int, nargs
);
3634 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
3640 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
3642 n
= strtol (&arg
->name
[1], &endp
, 10);
3643 if (endp
[0] != '\0')
3647 if (n
<= nlabelless
)
3660 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3661 !a1
? "a1" : "a2", gfc_current_intrinsic
,
3662 gfc_current_intrinsic_where
);
3666 /* Check for duplicates. */
3667 for (i
= 0; i
< nargs
; i
++)
3668 for (j
= i
+ 1; j
< nargs
; j
++)
3669 if (nlabels
[i
] == nlabels
[j
])
3675 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3676 &arg
->expr
->where
, gfc_current_intrinsic
);
3680 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3681 &arg
->expr
->where
, gfc_current_intrinsic
);
3687 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3689 gfc_actual_arglist
*arg
, *tmp
;
3693 if (!min_max_args (arglist
))
3696 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3699 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3701 if (x
->ts
.type
== type
)
3703 if (x
->ts
.type
== BT_CHARACTER
)
3705 gfc_error ("Different character kinds at %L", &x
->where
);
3708 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3709 "kinds at %L", &x
->where
))
3714 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3715 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3716 gfc_basic_typename (type
), kind
);
3721 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3722 if (!gfc_check_conformance (tmp
->expr
, x
,
3723 _("arguments 'a%d' and 'a%d' for "
3724 "intrinsic '%s'"), m
, n
,
3725 gfc_current_intrinsic
))
3734 gfc_check_min_max (gfc_actual_arglist
*arg
)
3738 if (!min_max_args (arg
))
3743 if (x
->ts
.type
== BT_CHARACTER
)
3745 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3746 "with CHARACTER argument at %L",
3747 gfc_current_intrinsic
, &x
->where
))
3750 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3752 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3753 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3757 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3762 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3764 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3769 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3771 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3776 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3778 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3782 /* End of min/max family. */
3785 gfc_check_malloc (gfc_expr
*size
)
3787 if (!type_check (size
, 0, BT_INTEGER
))
3790 if (!scalar_check (size
, 0))
3798 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3800 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3802 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3803 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3804 gfc_current_intrinsic
, &matrix_a
->where
);
3808 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3810 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3811 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3812 gfc_current_intrinsic
, &matrix_b
->where
);
3816 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3817 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3819 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3820 gfc_current_intrinsic
, &matrix_a
->where
,
3821 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3825 switch (matrix_a
->rank
)
3828 if (!rank_check (matrix_b
, 1, 2))
3830 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3831 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3833 gfc_error ("Different shape on dimension 1 for arguments %qs "
3834 "and %qs at %L for intrinsic matmul",
3835 gfc_current_intrinsic_arg
[0]->name
,
3836 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3842 if (matrix_b
->rank
!= 2)
3844 if (!rank_check (matrix_b
, 1, 1))
3847 /* matrix_b has rank 1 or 2 here. Common check for the cases
3848 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3849 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3850 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3852 gfc_error ("Different shape on dimension 2 for argument %qs and "
3853 "dimension 1 for argument %qs at %L for intrinsic "
3854 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3855 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3861 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3862 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3863 gfc_current_intrinsic
, &matrix_a
->where
);
3871 /* Whoever came up with this interface was probably on something.
3872 The possibilities for the occupation of the second and third
3879 NULL MASK minloc(array, mask=m)
3882 I.e. in the case of minloc(array,mask), mask will be in the second
3883 position of the argument list and we'll have to fix that up. Also,
3884 add the BACK argument if that isn't present. */
3887 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3889 gfc_expr
*a
, *m
, *d
, *k
, *b
;
3892 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3896 m
= ap
->next
->next
->expr
;
3897 k
= ap
->next
->next
->next
->expr
;
3898 b
= ap
->next
->next
->next
->next
->expr
;
3902 if (!type_check (b
, 4, BT_LOGICAL
) || !scalar_check (b
,4))
3907 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3908 ap
->next
->next
->next
->next
->expr
= b
;
3911 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3912 && ap
->next
->name
== NULL
)
3916 ap
->next
->expr
= NULL
;
3917 ap
->next
->next
->expr
= m
;
3920 if (!dim_check (d
, 1, false))
3923 if (!dim_rank_check (d
, a
, 0))
3926 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3930 && !gfc_check_conformance (a
, m
,
3931 _("arguments '%s' and '%s' for intrinsic %s"),
3932 gfc_current_intrinsic_arg
[0]->name
,
3933 gfc_current_intrinsic_arg
[2]->name
,
3934 gfc_current_intrinsic
))
3937 if (!kind_check (k
, 1, BT_INTEGER
))
3943 /* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3944 above, with the additional "value" argument. */
3947 gfc_check_findloc (gfc_actual_arglist
*ap
)
3949 gfc_expr
*a
, *v
, *m
, *d
, *k
, *b
;
3953 if (!intrinsic_type_check (a
, 0) || !array_check (a
, 0))
3957 if (!intrinsic_type_check (v
, 1) || !scalar_check (v
,1))
3960 /* Check if the type are both logical. */
3961 a1
= a
->ts
.type
== BT_LOGICAL
;
3962 v1
= v
->ts
.type
== BT_LOGICAL
;
3963 if ((a1
&& !v1
) || (!a1
&& v1
))
3966 /* Check if the type are both character. */
3967 a1
= a
->ts
.type
== BT_CHARACTER
;
3968 v1
= v
->ts
.type
== BT_CHARACTER
;
3969 if ((a1
&& !v1
) || (!a1
&& v1
))
3972 /* Check the kind of the characters argument match. */
3973 if (a1
&& v1
&& a
->ts
.kind
!= v
->ts
.kind
)
3976 d
= ap
->next
->next
->expr
;
3977 m
= ap
->next
->next
->next
->expr
;
3978 k
= ap
->next
->next
->next
->next
->expr
;
3979 b
= ap
->next
->next
->next
->next
->next
->expr
;
3983 if (!type_check (b
, 5, BT_LOGICAL
) || !scalar_check (b
,4))
3988 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3989 ap
->next
->next
->next
->next
->next
->expr
= b
;
3992 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3993 && ap
->next
->name
== NULL
)
3997 ap
->next
->next
->expr
= NULL
;
3998 ap
->next
->next
->next
->expr
= m
;
4001 if (!dim_check (d
, 2, false))
4004 if (!dim_rank_check (d
, a
, 0))
4007 if (m
!= NULL
&& !type_check (m
, 3, BT_LOGICAL
))
4011 && !gfc_check_conformance (a
, m
,
4012 _("arguments '%s' and '%s' for intrinsic %s"),
4013 gfc_current_intrinsic_arg
[0]->name
,
4014 gfc_current_intrinsic_arg
[3]->name
,
4015 gfc_current_intrinsic
))
4018 if (!kind_check (k
, 1, BT_INTEGER
))
4024 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4025 "conformance to argument %qs at %L",
4026 gfc_current_intrinsic_arg
[0]->name
,
4027 gfc_current_intrinsic
, &a
->where
,
4028 gfc_current_intrinsic_arg
[1]->name
, &v
->where
);
4033 /* Similar to minloc/maxloc, the argument list might need to be
4034 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4035 difference is that MINLOC/MAXLOC take an additional KIND argument.
4036 The possibilities are:
4042 NULL MASK minval(array, mask=m)
4045 I.e. in the case of minval(array,mask), mask will be in the second
4046 position of the argument list and we'll have to fix that up. */
4049 check_reduction (gfc_actual_arglist
*ap
)
4051 gfc_expr
*a
, *m
, *d
;
4055 m
= ap
->next
->next
->expr
;
4057 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
4058 && ap
->next
->name
== NULL
)
4062 ap
->next
->expr
= NULL
;
4063 ap
->next
->next
->expr
= m
;
4066 if (!dim_check (d
, 1, false))
4069 if (!dim_rank_check (d
, a
, 0))
4072 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
4076 && !gfc_check_conformance (a
, m
,
4077 _("arguments '%s' and '%s' for intrinsic %s"),
4078 gfc_current_intrinsic_arg
[0]->name
,
4079 gfc_current_intrinsic_arg
[2]->name
,
4080 gfc_current_intrinsic
))
4088 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
4090 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
4091 || !array_check (ap
->expr
, 0))
4094 return check_reduction (ap
);
4099 gfc_check_product_sum (gfc_actual_arglist
*ap
)
4101 if (!numeric_check (ap
->expr
, 0)
4102 || !array_check (ap
->expr
, 0))
4105 return check_reduction (ap
);
4109 /* For IANY, IALL and IPARITY. */
4112 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
4116 if (!type_check (i
, 0, BT_INTEGER
))
4119 if (!nonnegative_check ("I", i
))
4122 if (!kind_check (kind
, 1, BT_INTEGER
))
4126 gfc_extract_int (kind
, &k
);
4128 k
= gfc_default_integer_kind
;
4130 if (!less_than_bitsizekind ("I", i
, k
))
4138 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
4140 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
4142 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4143 gfc_current_intrinsic_arg
[0]->name
,
4144 gfc_current_intrinsic
, &ap
->expr
->where
);
4148 if (!array_check (ap
->expr
, 0))
4151 return check_reduction (ap
);
4156 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4158 if (gfc_invalid_null_arg (tsource
))
4161 if (gfc_invalid_null_arg (fsource
))
4164 if (!same_type_check (tsource
, 0, fsource
, 1))
4167 if (!type_check (mask
, 2, BT_LOGICAL
))
4170 if (tsource
->ts
.type
== BT_CHARACTER
)
4171 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
4178 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
4180 /* i and j cannot both be BOZ literal constants. */
4181 if (!boz_args_check (i
, j
))
4184 /* If i is BOZ and j is integer, convert i to type of j. */
4185 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
4186 && !gfc_boz2int (i
, j
->ts
.kind
))
4189 /* If j is BOZ and i is integer, convert j to type of i. */
4190 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
4191 && !gfc_boz2int (j
, i
->ts
.kind
))
4194 if (!type_check (i
, 0, BT_INTEGER
))
4197 if (!type_check (j
, 1, BT_INTEGER
))
4200 if (!same_type_check (i
, 0, j
, 1))
4203 if (mask
->ts
.type
== BT_BOZ
&& !gfc_boz2int(mask
, i
->ts
.kind
))
4206 if (!type_check (mask
, 2, BT_INTEGER
))
4209 if (!same_type_check (i
, 0, mask
, 2))
4217 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
4219 if (!variable_check (from
, 0, false))
4221 if (!allocatable_check (from
, 0))
4223 if (gfc_is_coindexed (from
))
4225 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4226 "coindexed", &from
->where
);
4230 if (!variable_check (to
, 1, false))
4232 if (!allocatable_check (to
, 1))
4234 if (gfc_is_coindexed (to
))
4236 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4237 "coindexed", &to
->where
);
4241 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
4243 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4244 "polymorphic if FROM is polymorphic",
4249 if (!same_type_check (to
, 1, from
, 0))
4252 if (to
->rank
!= from
->rank
)
4254 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4255 "must have the same rank %d/%d", &to
->where
, from
->rank
,
4260 /* IR F08/0040; cf. 12-006A. */
4261 if (gfc_get_corank (to
) != gfc_get_corank (from
))
4263 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4264 "must have the same corank %d/%d", &to
->where
,
4265 gfc_get_corank (from
), gfc_get_corank (to
));
4269 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
4270 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4271 and cmp2 are allocatable. After the allocation is transferred,
4272 the 'to' chain is broken by the nullification of the 'from'. A bit
4273 of reflection reveals that this can only occur for derived types
4274 with recursive allocatable components. */
4275 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
4276 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
4278 gfc_ref
*to_ref
, *from_ref
;
4280 from_ref
= from
->ref
;
4281 bool aliasing
= true;
4283 for (; from_ref
&& to_ref
;
4284 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
4286 if (to_ref
->type
!= from
->ref
->type
)
4288 else if (to_ref
->type
== REF_ARRAY
4289 && to_ref
->u
.ar
.type
!= AR_FULL
4290 && from_ref
->u
.ar
.type
!= AR_FULL
)
4291 /* Play safe; assume sections and elements are different. */
4293 else if (to_ref
->type
== REF_COMPONENT
4294 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
4303 gfc_error ("The FROM and TO arguments at %L violate aliasing "
4304 "restrictions (F2003 12.4.1.7)", &to
->where
);
4309 /* CLASS arguments: Make sure the vtab of from is present. */
4310 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
4311 gfc_find_vtab (&from
->ts
);
4318 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
4320 if (!type_check (x
, 0, BT_REAL
))
4323 if (!type_check (s
, 1, BT_REAL
))
4326 if (s
->expr_type
== EXPR_CONSTANT
)
4328 if (mpfr_sgn (s
->value
.real
) == 0)
4330 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4341 gfc_check_new_line (gfc_expr
*a
)
4343 if (!type_check (a
, 0, BT_CHARACTER
))
4351 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
4353 if (!type_check (array
, 0, BT_REAL
))
4356 if (!array_check (array
, 0))
4359 if (!dim_rank_check (dim
, array
, false))
4366 gfc_check_null (gfc_expr
*mold
)
4368 symbol_attribute attr
;
4373 if (!variable_check (mold
, 0, true))
4376 attr
= gfc_variable_attr (mold
, NULL
);
4378 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
4380 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4381 "ALLOCATABLE or procedure pointer",
4382 gfc_current_intrinsic_arg
[0]->name
,
4383 gfc_current_intrinsic
, &mold
->where
);
4387 if (attr
.allocatable
4388 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
4389 "allocatable MOLD at %L", &mold
->where
))
4393 if (gfc_is_coindexed (mold
))
4395 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4396 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
4397 gfc_current_intrinsic
, &mold
->where
);
4406 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4408 if (!array_check (array
, 0))
4411 if (!type_check (mask
, 1, BT_LOGICAL
))
4414 if (!gfc_check_conformance (array
, mask
,
4415 _("arguments '%s' and '%s' for intrinsic '%s'"),
4416 gfc_current_intrinsic_arg
[0]->name
,
4417 gfc_current_intrinsic_arg
[1]->name
,
4418 gfc_current_intrinsic
))
4423 mpz_t array_size
, vector_size
;
4424 bool have_array_size
, have_vector_size
;
4426 if (!same_type_check (array
, 0, vector
, 2))
4429 if (!rank_check (vector
, 2, 1))
4432 /* VECTOR requires at least as many elements as MASK
4433 has .TRUE. values. */
4434 have_array_size
= gfc_array_size(array
, &array_size
);
4435 have_vector_size
= gfc_array_size(vector
, &vector_size
);
4437 if (have_vector_size
4438 && (mask
->expr_type
== EXPR_ARRAY
4439 || (mask
->expr_type
== EXPR_CONSTANT
4440 && have_array_size
)))
4442 int mask_true_values
= 0;
4444 if (mask
->expr_type
== EXPR_ARRAY
)
4446 gfc_constructor
*mask_ctor
;
4447 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4450 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4452 mask_true_values
= 0;
4456 if (mask_ctor
->expr
->value
.logical
)
4459 mask_ctor
= gfc_constructor_next (mask_ctor
);
4462 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
4463 mask_true_values
= mpz_get_si (array_size
);
4465 if (mpz_get_si (vector_size
) < mask_true_values
)
4467 gfc_error ("%qs argument of %qs intrinsic at %L must "
4468 "provide at least as many elements as there "
4469 "are .TRUE. values in %qs (%ld/%d)",
4470 gfc_current_intrinsic_arg
[2]->name
,
4471 gfc_current_intrinsic
, &vector
->where
,
4472 gfc_current_intrinsic_arg
[1]->name
,
4473 mpz_get_si (vector_size
), mask_true_values
);
4478 if (have_array_size
)
4479 mpz_clear (array_size
);
4480 if (have_vector_size
)
4481 mpz_clear (vector_size
);
4489 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
4491 if (!type_check (mask
, 0, BT_LOGICAL
))
4494 if (!array_check (mask
, 0))
4497 if (!dim_rank_check (dim
, mask
, false))
4505 gfc_check_precision (gfc_expr
*x
)
4507 if (!real_or_complex_check (x
, 0))
4515 gfc_check_present (gfc_expr
*a
)
4519 if (!variable_check (a
, 0, true))
4522 sym
= a
->symtree
->n
.sym
;
4523 if (!sym
->attr
.dummy
)
4525 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4526 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
4527 gfc_current_intrinsic
, &a
->where
);
4531 if (!sym
->attr
.optional
)
4533 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4534 "an OPTIONAL dummy variable",
4535 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4540 /* 13.14.82 PRESENT(A)
4542 Argument. A shall be the name of an optional dummy argument that is
4543 accessible in the subprogram in which the PRESENT function reference
4547 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
4548 && (a
->ref
->u
.ar
.type
== AR_FULL
4549 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
4550 && a
->ref
->u
.ar
.as
->rank
== 0))))
4552 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4553 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
4554 gfc_current_intrinsic
, &a
->where
, sym
->name
);
4563 gfc_check_radix (gfc_expr
*x
)
4565 if (!int_or_real_check (x
, 0))
4573 gfc_check_range (gfc_expr
*x
)
4575 if (!numeric_check (x
, 0))
4583 gfc_check_rank (gfc_expr
*a
)
4585 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4586 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4588 bool is_variable
= true;
4590 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4591 if (a
->expr_type
== EXPR_FUNCTION
)
4592 is_variable
= a
->value
.function
.esym
4593 ? a
->value
.function
.esym
->result
->attr
.pointer
4594 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
4596 if (a
->expr_type
== EXPR_OP
4597 || a
->expr_type
== EXPR_NULL
4598 || a
->expr_type
== EXPR_COMPCALL
4599 || a
->expr_type
== EXPR_PPC
4600 || a
->ts
.type
== BT_PROCEDURE
4603 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4604 "object", &a
->where
);
4613 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
4615 if (!kind_check (kind
, 1, BT_REAL
))
4618 /* BOZ is dealt with in gfc_simplify_real. */
4619 if (a
->ts
.type
== BT_BOZ
)
4622 if (!numeric_check (a
, 0))
4630 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
4632 if (!type_check (path1
, 0, BT_CHARACTER
))
4634 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4637 if (!type_check (path2
, 1, BT_CHARACTER
))
4639 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4647 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
4649 if (!type_check (path1
, 0, BT_CHARACTER
))
4651 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4654 if (!type_check (path2
, 1, BT_CHARACTER
))
4656 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4662 if (!type_check (status
, 2, BT_INTEGER
))
4665 if (!scalar_check (status
, 2))
4673 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
4675 if (!type_check (x
, 0, BT_CHARACTER
))
4678 if (!scalar_check (x
, 0))
4681 if (!type_check (y
, 0, BT_INTEGER
))
4684 if (!scalar_check (y
, 1))
4692 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
4693 gfc_expr
*pad
, gfc_expr
*order
)
4699 if (!array_check (source
, 0))
4702 if (!rank_check (shape
, 1, 1))
4705 if (!type_check (shape
, 1, BT_INTEGER
))
4708 if (!gfc_array_size (shape
, &size
))
4710 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4711 "array of constant size", &shape
->where
);
4715 shape_size
= mpz_get_ui (size
);
4718 if (shape_size
<= 0)
4720 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4721 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4725 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4727 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4728 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4731 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
4735 for (i
= 0; i
< shape_size
; ++i
)
4737 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4738 if (e
->expr_type
!= EXPR_CONSTANT
)
4741 gfc_extract_int (e
, &extent
);
4744 gfc_error ("%qs argument of %qs intrinsic at %L has "
4745 "negative element (%d)",
4746 gfc_current_intrinsic_arg
[1]->name
,
4747 gfc_current_intrinsic
, &e
->where
, extent
);
4752 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4753 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4754 && shape
->ref
->u
.ar
.as
4755 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4756 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4757 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4758 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4759 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
4760 && shape
->symtree
->n
.sym
->value
)
4765 v
= shape
->symtree
->n
.sym
->value
;
4767 for (i
= 0; i
< shape_size
; i
++)
4769 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4773 gfc_extract_int (e
, &extent
);
4777 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4778 "cannot be negative", i
+ 1, &shape
->where
);
4786 if (!same_type_check (source
, 0, pad
, 2))
4789 if (!array_check (pad
, 2))
4795 if (!array_check (order
, 3))
4798 if (!type_check (order
, 3, BT_INTEGER
))
4801 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4803 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4806 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4809 gfc_array_size (order
, &size
);
4810 order_size
= mpz_get_ui (size
);
4813 if (order_size
!= shape_size
)
4815 gfc_error ("%qs argument of %qs intrinsic at %L "
4816 "has wrong number of elements (%d/%d)",
4817 gfc_current_intrinsic_arg
[3]->name
,
4818 gfc_current_intrinsic
, &order
->where
,
4819 order_size
, shape_size
);
4823 for (i
= 1; i
<= order_size
; ++i
)
4825 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4826 if (e
->expr_type
!= EXPR_CONSTANT
)
4829 gfc_extract_int (e
, &dim
);
4831 if (dim
< 1 || dim
> order_size
)
4833 gfc_error ("%qs argument of %qs intrinsic at %L "
4834 "has out-of-range dimension (%d)",
4835 gfc_current_intrinsic_arg
[3]->name
,
4836 gfc_current_intrinsic
, &e
->where
, dim
);
4840 if (perm
[dim
-1] != 0)
4842 gfc_error ("%qs argument of %qs intrinsic at %L has "
4843 "invalid permutation of dimensions (dimension "
4845 gfc_current_intrinsic_arg
[3]->name
,
4846 gfc_current_intrinsic
, &e
->where
, dim
);
4855 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4856 && gfc_is_constant_expr (shape
)
4857 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4858 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4860 /* Check the match in size between source and destination. */
4861 if (gfc_array_size (source
, &nelems
))
4867 mpz_init_set_ui (size
, 1);
4868 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4869 c
; c
= gfc_constructor_next (c
))
4870 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4872 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4878 gfc_error ("Without padding, there are not enough elements "
4879 "in the intrinsic RESHAPE source at %L to match "
4880 "the shape", &source
->where
);
4891 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4893 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4895 gfc_error ("%qs argument of %qs intrinsic at %L "
4896 "cannot be of type %s",
4897 gfc_current_intrinsic_arg
[0]->name
,
4898 gfc_current_intrinsic
,
4899 &a
->where
, gfc_typename (a
));
4903 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4905 gfc_error ("%qs argument of %qs intrinsic at %L "
4906 "must be of an extensible type",
4907 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4912 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4914 gfc_error ("%qs argument of %qs intrinsic at %L "
4915 "cannot be of type %s",
4916 gfc_current_intrinsic_arg
[0]->name
,
4917 gfc_current_intrinsic
,
4918 &b
->where
, gfc_typename (b
));
4922 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4924 gfc_error ("%qs argument of %qs intrinsic at %L "
4925 "must be of an extensible type",
4926 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4936 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4938 if (!type_check (x
, 0, BT_REAL
))
4941 if (!type_check (i
, 1, BT_INTEGER
))
4949 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4951 if (!type_check (x
, 0, BT_CHARACTER
))
4954 if (!type_check (y
, 1, BT_CHARACTER
))
4957 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4960 if (!kind_check (kind
, 3, BT_INTEGER
))
4962 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4963 "with KIND argument at %L",
4964 gfc_current_intrinsic
, &kind
->where
))
4967 if (!same_type_check (x
, 0, y
, 1))
4975 gfc_check_secnds (gfc_expr
*r
)
4977 if (!type_check (r
, 0, BT_REAL
))
4980 if (!kind_value_check (r
, 0, 4))
4983 if (!scalar_check (r
, 0))
4991 gfc_check_selected_char_kind (gfc_expr
*name
)
4993 if (!type_check (name
, 0, BT_CHARACTER
))
4996 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4999 if (!scalar_check (name
, 0))
5007 gfc_check_selected_int_kind (gfc_expr
*r
)
5009 if (!type_check (r
, 0, BT_INTEGER
))
5012 if (!scalar_check (r
, 0))
5020 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
5022 if (p
== NULL
&& r
== NULL
5023 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
5024 " neither %<P%> nor %<R%> argument at %L",
5025 gfc_current_intrinsic_where
))
5030 if (!type_check (p
, 0, BT_INTEGER
))
5033 if (!scalar_check (p
, 0))
5039 if (!type_check (r
, 1, BT_INTEGER
))
5042 if (!scalar_check (r
, 1))
5048 if (!type_check (radix
, 1, BT_INTEGER
))
5051 if (!scalar_check (radix
, 1))
5054 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
5055 "RADIX argument at %L", gfc_current_intrinsic
,
5065 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5067 if (!type_check (x
, 0, BT_REAL
))
5070 if (!type_check (i
, 1, BT_INTEGER
))
5078 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
5082 if (gfc_invalid_null_arg (source
))
5085 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
5088 ar
= gfc_find_array_ref (source
);
5090 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
5092 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5093 "an assumed size array", &source
->where
);
5097 if (!kind_check (kind
, 1, BT_INTEGER
))
5099 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5100 "with KIND argument at %L",
5101 gfc_current_intrinsic
, &kind
->where
))
5109 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
5111 if (!type_check (i
, 0, BT_INTEGER
))
5114 if (!type_check (shift
, 0, BT_INTEGER
))
5117 if (!nonnegative_check ("SHIFT", shift
))
5120 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
5128 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
5130 if (!int_or_real_check (a
, 0))
5133 if (!same_type_check (a
, 0, b
, 1))
5141 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5143 if (!array_check (array
, 0))
5146 if (!dim_check (dim
, 1, true))
5149 if (!dim_rank_check (dim
, array
, 0))
5152 if (!kind_check (kind
, 2, BT_INTEGER
))
5154 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5155 "with KIND argument at %L",
5156 gfc_current_intrinsic
, &kind
->where
))
5165 gfc_check_sizeof (gfc_expr
*arg
)
5167 if (gfc_invalid_null_arg (arg
))
5170 if (arg
->ts
.type
== BT_PROCEDURE
)
5172 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5173 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5178 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5179 if (arg
->ts
.type
== BT_ASSUMED
5180 && (arg
->symtree
->n
.sym
->as
== NULL
5181 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
5182 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
5183 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
5185 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5186 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5191 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5192 && arg
->symtree
->n
.sym
->as
!= NULL
5193 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5194 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5196 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5197 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5198 gfc_current_intrinsic
, &arg
->where
);
5206 /* Check whether an expression is interoperable. When returning false,
5207 msg is set to a string telling why the expression is not interoperable,
5208 otherwise, it is set to NULL. The msg string can be used in diagnostics.
5209 If c_loc is true, character with len > 1 are allowed (cf. Fortran
5210 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5211 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5215 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
5219 if (expr
->ts
.type
== BT_CLASS
)
5221 *msg
= "Expression is polymorphic";
5225 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
5226 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
5228 *msg
= "Expression is a noninteroperable derived type";
5232 if (expr
->ts
.type
== BT_PROCEDURE
)
5234 *msg
= "Procedure unexpected as argument";
5238 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
5241 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
5242 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
5244 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
5248 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
5249 && expr
->ts
.kind
!= 1)
5251 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
5255 if (expr
->ts
.type
== BT_CHARACTER
) {
5256 if (expr
->ts
.deferred
)
5258 /* TS 29113 allows deferred-length strings as dummy arguments,
5259 but it is not an interoperable type. */
5260 *msg
= "Expression shall not be a deferred-length string";
5264 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
5265 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
5266 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5268 if (!c_loc
&& expr
->ts
.u
.cl
5269 && (!expr
->ts
.u
.cl
->length
5270 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5271 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5273 *msg
= "Type shall have a character length of 1";
5278 /* Note: The following checks are about interoperatable variables, Fortran
5279 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5280 is allowed, e.g. assumed-shape arrays with TS 29113. */
5282 if (gfc_is_coarray (expr
))
5284 *msg
= "Coarrays are not interoperable";
5288 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
5290 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
5291 if (ar
->type
!= AR_FULL
)
5293 *msg
= "Only whole-arrays are interoperable";
5296 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
5297 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
5299 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
5309 gfc_check_c_sizeof (gfc_expr
*arg
)
5313 if (!is_c_interoperable (arg
, &msg
, false, false))
5315 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5316 "interoperable data entity: %s",
5317 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5322 if (arg
->ts
.type
== BT_ASSUMED
)
5324 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5326 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5331 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5332 && arg
->symtree
->n
.sym
->as
!= NULL
5333 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5334 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5336 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5337 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5338 gfc_current_intrinsic
, &arg
->where
);
5347 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
5349 if (c_ptr_1
->ts
.type
!= BT_DERIVED
5350 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5351 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
5352 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
5354 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5355 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
5359 if (!scalar_check (c_ptr_1
, 0))
5363 && (c_ptr_2
->ts
.type
!= BT_DERIVED
5364 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5365 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
5366 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
5368 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5369 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
5370 gfc_typename (&c_ptr_1
->ts
),
5371 gfc_typename (&c_ptr_2
->ts
));
5375 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
5383 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
5385 symbol_attribute attr
;
5388 if (cptr
->ts
.type
!= BT_DERIVED
5389 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5390 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
5392 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5393 "type TYPE(C_PTR)", &cptr
->where
);
5397 if (!scalar_check (cptr
, 0))
5400 attr
= gfc_expr_attr (fptr
);
5404 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5409 if (fptr
->ts
.type
== BT_CLASS
)
5411 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5416 if (gfc_is_coindexed (fptr
))
5418 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5419 "coindexed", &fptr
->where
);
5423 if (fptr
->rank
== 0 && shape
)
5425 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5426 "FPTR", &fptr
->where
);
5429 else if (fptr
->rank
&& !shape
)
5431 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5432 "FPTR at %L", &fptr
->where
);
5436 if (shape
&& !rank_check (shape
, 2, 1))
5439 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
5445 if (gfc_array_size (shape
, &size
))
5447 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
5450 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5451 "size as the RANK of FPTR", &shape
->where
);
5458 if (fptr
->ts
.type
== BT_CLASS
)
5460 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
5464 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
5465 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable array FPTR "
5466 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
5473 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
5475 symbol_attribute attr
;
5477 if (cptr
->ts
.type
!= BT_DERIVED
5478 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5479 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
5481 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5482 "type TYPE(C_FUNPTR)", &cptr
->where
);
5486 if (!scalar_check (cptr
, 0))
5489 attr
= gfc_expr_attr (fptr
);
5491 if (!attr
.proc_pointer
)
5493 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5494 "pointer", &fptr
->where
);
5498 if (gfc_is_coindexed (fptr
))
5500 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5501 "coindexed", &fptr
->where
);
5505 if (!attr
.is_bind_c
)
5506 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5507 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
5514 gfc_check_c_funloc (gfc_expr
*x
)
5516 symbol_attribute attr
;
5518 if (gfc_is_coindexed (x
))
5520 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5521 "coindexed", &x
->where
);
5525 attr
= gfc_expr_attr (x
);
5527 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
5528 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
5529 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5530 if (x
->symtree
->n
.sym
== ns
->proc_name
)
5532 gfc_error ("Function result %qs at %L is invalid as X argument "
5533 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
5537 if (attr
.flavor
!= FL_PROCEDURE
)
5539 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5540 "or a procedure pointer", &x
->where
);
5544 if (!attr
.is_bind_c
)
5545 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5546 "at %L to C_FUNLOC", &x
->where
);
5552 gfc_check_c_loc (gfc_expr
*x
)
5554 symbol_attribute attr
;
5557 if (gfc_is_coindexed (x
))
5559 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
5563 if (x
->ts
.type
== BT_CLASS
)
5565 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5570 attr
= gfc_expr_attr (x
);
5573 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
5574 || attr
.flavor
== FL_PARAMETER
))
5576 gfc_error ("Argument X at %L to C_LOC shall have either "
5577 "the POINTER or the TARGET attribute", &x
->where
);
5581 if (x
->ts
.type
== BT_CHARACTER
5582 && gfc_var_strlen (x
) == 0)
5584 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5585 "string", &x
->where
);
5589 if (!is_c_interoperable (x
, &msg
, true, false))
5591 if (x
->ts
.type
== BT_CLASS
)
5593 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5599 && !gfc_notify_std (GFC_STD_F2018
,
5600 "Noninteroperable array at %L as"
5601 " argument to C_LOC: %s", &x
->where
, msg
))
5604 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
5606 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
5608 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
5609 && !attr
.allocatable
5610 && !gfc_notify_std (GFC_STD_F2008
,
5611 "Array of interoperable type at %L "
5612 "to C_LOC which is nonallocatable and neither "
5613 "assumed size nor explicit size", &x
->where
))
5615 else if (ar
->type
!= AR_FULL
5616 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
5617 "to C_LOC", &x
->where
))
5626 gfc_check_sleep_sub (gfc_expr
*seconds
)
5628 if (!type_check (seconds
, 0, BT_INTEGER
))
5631 if (!scalar_check (seconds
, 0))
5638 gfc_check_sngl (gfc_expr
*a
)
5640 if (!type_check (a
, 0, BT_REAL
))
5643 if ((a
->ts
.kind
!= gfc_default_double_kind
)
5644 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
5645 "REAL argument to %s intrinsic at %L",
5646 gfc_current_intrinsic
, &a
->where
))
5653 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
5655 if (gfc_invalid_null_arg (source
))
5658 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
5660 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5661 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
5662 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
5670 if (!dim_check (dim
, 1, false))
5673 /* dim_rank_check() does not apply here. */
5675 && dim
->expr_type
== EXPR_CONSTANT
5676 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
5677 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
5679 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5680 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
5681 gfc_current_intrinsic
, &dim
->where
);
5685 if (!type_check (ncopies
, 2, BT_INTEGER
))
5688 if (!scalar_check (ncopies
, 2))
5695 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5699 arg_strlen_is_zero (gfc_expr
*c
, int n
)
5701 if (gfc_var_strlen (c
) == 0)
5703 gfc_error ("%qs argument of %qs intrinsic at %L must have "
5704 "length at least 1", gfc_current_intrinsic_arg
[n
]->name
,
5705 gfc_current_intrinsic
, &c
->where
);
5712 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
5714 if (!type_check (unit
, 0, BT_INTEGER
))
5717 if (!scalar_check (unit
, 0))
5720 if (!type_check (c
, 1, BT_CHARACTER
))
5722 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5724 if (strcmp (gfc_current_intrinsic
, "fgetc") == 0
5725 && !variable_check (c
, 1, false))
5727 if (arg_strlen_is_zero (c
, 1))
5733 if (!type_check (status
, 2, BT_INTEGER
)
5734 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5735 || !scalar_check (status
, 2)
5736 || !variable_check (status
, 2, false))
5744 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5746 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5751 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5753 if (!type_check (c
, 0, BT_CHARACTER
))
5755 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5757 if (strcmp (gfc_current_intrinsic
, "fget") == 0
5758 && !variable_check (c
, 0, false))
5760 if (arg_strlen_is_zero (c
, 0))
5766 if (!type_check (status
, 1, BT_INTEGER
)
5767 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5768 || !scalar_check (status
, 1)
5769 || !variable_check (status
, 1, false))
5777 gfc_check_fgetput (gfc_expr
*c
)
5779 return gfc_check_fgetput_sub (c
, NULL
);
5784 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5786 if (!type_check (unit
, 0, BT_INTEGER
))
5789 if (!scalar_check (unit
, 0))
5792 if (!type_check (offset
, 1, BT_INTEGER
))
5795 if (!scalar_check (offset
, 1))
5798 if (!type_check (whence
, 2, BT_INTEGER
))
5801 if (!scalar_check (whence
, 2))
5807 if (!type_check (status
, 3, BT_INTEGER
))
5810 if (!kind_value_check (status
, 3, 4))
5813 if (!scalar_check (status
, 3))
5822 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5824 if (!type_check (unit
, 0, BT_INTEGER
))
5827 if (!scalar_check (unit
, 0))
5830 if (!type_check (array
, 1, BT_INTEGER
)
5831 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5834 if (!array_check (array
, 1))
5842 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5844 if (!type_check (unit
, 0, BT_INTEGER
))
5847 if (!scalar_check (unit
, 0))
5850 if (!type_check (array
, 1, BT_INTEGER
)
5851 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5854 if (!array_check (array
, 1))
5860 if (!type_check (status
, 2, BT_INTEGER
)
5861 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5864 if (!scalar_check (status
, 2))
5872 gfc_check_ftell (gfc_expr
*unit
)
5874 if (!type_check (unit
, 0, BT_INTEGER
))
5877 if (!scalar_check (unit
, 0))
5885 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5887 if (!type_check (unit
, 0, BT_INTEGER
))
5890 if (!scalar_check (unit
, 0))
5893 if (!type_check (offset
, 1, BT_INTEGER
))
5896 if (!scalar_check (offset
, 1))
5904 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5906 if (!type_check (name
, 0, BT_CHARACTER
))
5908 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5911 if (!type_check (array
, 1, BT_INTEGER
)
5912 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5915 if (!array_check (array
, 1))
5923 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5925 if (!type_check (name
, 0, BT_CHARACTER
))
5927 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5930 if (!type_check (array
, 1, BT_INTEGER
)
5931 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5934 if (!array_check (array
, 1))
5940 if (!type_check (status
, 2, BT_INTEGER
)
5941 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5944 if (!scalar_check (status
, 2))
5952 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5956 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5958 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5962 if (!coarray_check (coarray
, 0))
5967 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5968 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5972 if (gfc_array_size (sub
, &nelems
))
5974 int corank
= gfc_get_corank (coarray
);
5976 if (mpz_cmp_ui (nelems
, corank
) != 0)
5978 gfc_error ("The number of array elements of the SUB argument to "
5979 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5980 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5992 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5994 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5996 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6002 if (!type_check (distance
, 0, BT_INTEGER
))
6005 if (!nonnegative_check ("DISTANCE", distance
))
6008 if (!scalar_check (distance
, 0))
6011 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6012 "NUM_IMAGES at %L", &distance
->where
))
6018 if (!type_check (failed
, 1, BT_LOGICAL
))
6021 if (!scalar_check (failed
, 1))
6024 if (!gfc_notify_std (GFC_STD_F2018
, "FAILED= argument to "
6025 "NUM_IMAGES at %L", &failed
->where
))
6034 gfc_check_team_number (gfc_expr
*team
)
6036 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6038 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6044 if (team
->ts
.type
!= BT_DERIVED
6045 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
6046 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
6048 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
6049 "shall be of type TEAM_TYPE", &team
->where
);
6061 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
6063 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6065 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6069 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
6072 if (dim
!= NULL
&& coarray
== NULL
)
6074 gfc_error ("DIM argument without COARRAY argument not allowed for "
6075 "THIS_IMAGE intrinsic at %L", &dim
->where
);
6079 if (distance
&& (coarray
|| dim
))
6081 gfc_error ("The DISTANCE argument may not be specified together with the "
6082 "COARRAY or DIM argument in intrinsic at %L",
6087 /* Assume that we have "this_image (distance)". */
6088 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
6092 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6101 if (!type_check (distance
, 2, BT_INTEGER
))
6104 if (!nonnegative_check ("DISTANCE", distance
))
6107 if (!scalar_check (distance
, 2))
6110 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6111 "THIS_IMAGE at %L", &distance
->where
))
6117 if (!coarray_check (coarray
, 0))
6122 if (!dim_check (dim
, 1, false))
6125 if (!dim_corank_check (dim
, coarray
))
6132 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6133 by gfc_simplify_transfer. Return false if we cannot do so. */
6136 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
6137 size_t *source_size
, size_t *result_size
,
6138 size_t *result_length_p
)
6140 size_t result_elt_size
;
6142 if (source
->expr_type
== EXPR_FUNCTION
)
6145 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
6148 /* Calculate the size of the source. */
6149 if (!gfc_target_expr_size (source
, source_size
))
6152 /* Determine the size of the element. */
6153 if (!gfc_element_size (mold
, &result_elt_size
))
6156 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6157 * a scalar with the type and type parameters of MOLD shall not have a
6158 * storage size equal to zero.
6159 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6160 * If MOLD is an array and SIZE is absent, the result is an array and of
6161 * rank one. Its size is as small as possible such that its physical
6162 * representation is not shorter than that of SOURCE.
6163 * If SIZE is present, the result is an array of rank one and size SIZE.
6165 if (result_elt_size
== 0 && *source_size
> 0 && !size
6166 && mold
->expr_type
== EXPR_ARRAY
)
6168 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6169 "array and shall not have storage size 0 when %<SOURCE%> "
6170 "argument has size greater than 0", &mold
->where
);
6174 if (result_elt_size
== 0 && *source_size
== 0 && !size
)
6177 if (result_length_p
)
6178 *result_length_p
= 0;
6182 if ((result_elt_size
> 0 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6188 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6191 result_length
= *source_size
/ result_elt_size
;
6192 if (result_length
* result_elt_size
< *source_size
)
6196 *result_size
= result_length
* result_elt_size
;
6197 if (result_length_p
)
6198 *result_length_p
= result_length
;
6201 *result_size
= result_elt_size
;
6208 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6213 if (gfc_invalid_null_arg (source
))
6216 /* SOURCE shall be a scalar or array of any type. */
6217 if (source
->ts
.type
== BT_PROCEDURE
6218 && source
->symtree
->n
.sym
->attr
.subroutine
== 1)
6220 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6221 "must not be a %s", &source
->where
,
6222 gfc_basic_typename (source
->ts
.type
));
6226 if (source
->ts
.type
== BT_BOZ
&& illegal_boz_arg (source
))
6229 if (mold
->ts
.type
== BT_BOZ
&& illegal_boz_arg (mold
))
6232 if (gfc_invalid_null_arg (mold
))
6235 /* MOLD shall be a scalar or array of any type. */
6236 if (mold
->ts
.type
== BT_PROCEDURE
6237 && mold
->symtree
->n
.sym
->attr
.subroutine
== 1)
6239 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6240 "must not be a %s", &mold
->where
,
6241 gfc_basic_typename (mold
->ts
.type
));
6245 if (mold
->ts
.type
== BT_HOLLERITH
)
6247 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6248 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
6252 /* SIZE (optional) shall be an integer scalar. The corresponding actual
6253 argument shall not be an optional dummy argument. */
6256 if (!type_check (size
, 2, BT_INTEGER
))
6258 if (size
->ts
.type
== BT_BOZ
)
6263 if (!scalar_check (size
, 2))
6266 if (!nonoptional_check (size
, 2))
6270 if (!warn_surprising
)
6273 /* If we can't calculate the sizes, we cannot check any more.
6274 Return true for that case. */
6276 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6277 &result_size
, NULL
))
6280 if (source_size
< result_size
)
6281 gfc_warning (OPT_Wsurprising
,
6282 "Intrinsic TRANSFER at %L has partly undefined result: "
6283 "source size %ld < result size %ld", &source
->where
,
6284 (long) source_size
, (long) result_size
);
6291 gfc_check_transpose (gfc_expr
*matrix
)
6293 if (!rank_check (matrix
, 0, 2))
6301 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6303 if (!array_check (array
, 0))
6306 if (!dim_check (dim
, 1, false))
6309 if (!dim_rank_check (dim
, array
, 0))
6312 if (!kind_check (kind
, 2, BT_INTEGER
))
6314 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6315 "with KIND argument at %L",
6316 gfc_current_intrinsic
, &kind
->where
))
6324 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
6326 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6328 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6332 if (!coarray_check (coarray
, 0))
6337 if (!dim_check (dim
, 1, false))
6340 if (!dim_corank_check (dim
, coarray
))
6344 if (!kind_check (kind
, 2, BT_INTEGER
))
6352 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6356 if (!rank_check (vector
, 0, 1))
6359 if (!array_check (mask
, 1))
6362 if (!type_check (mask
, 1, BT_LOGICAL
))
6365 if (!same_type_check (vector
, 0, field
, 2))
6368 if (mask
->expr_type
== EXPR_ARRAY
6369 && gfc_array_size (vector
, &vector_size
))
6371 int mask_true_count
= 0;
6372 gfc_constructor
*mask_ctor
;
6373 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6376 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
6378 mask_true_count
= 0;
6382 if (mask_ctor
->expr
->value
.logical
)
6385 mask_ctor
= gfc_constructor_next (mask_ctor
);
6388 if (mpz_get_si (vector_size
) < mask_true_count
)
6390 gfc_error ("%qs argument of %qs intrinsic at %L must "
6391 "provide at least as many elements as there "
6392 "are .TRUE. values in %qs (%ld/%d)",
6393 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6394 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
6395 mpz_get_si (vector_size
), mask_true_count
);
6399 mpz_clear (vector_size
);
6402 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
6404 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6405 "the same rank as %qs or be a scalar",
6406 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6407 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
6411 if (mask
->rank
== field
->rank
)
6414 for (i
= 0; i
< field
->rank
; i
++)
6415 if (! identical_dimen_shape (mask
, i
, field
, i
))
6417 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6418 "must have identical shape.",
6419 gfc_current_intrinsic_arg
[2]->name
,
6420 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6430 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
6432 if (!type_check (x
, 0, BT_CHARACTER
))
6435 if (!same_type_check (x
, 0, y
, 1))
6438 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
6441 if (!kind_check (kind
, 3, BT_INTEGER
))
6443 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6444 "with KIND argument at %L",
6445 gfc_current_intrinsic
, &kind
->where
))
6453 gfc_check_trim (gfc_expr
*x
)
6455 if (!type_check (x
, 0, BT_CHARACTER
))
6458 if (gfc_invalid_null_arg (x
))
6461 if (!scalar_check (x
, 0))
6469 gfc_check_ttynam (gfc_expr
*unit
)
6471 if (!scalar_check (unit
, 0))
6474 if (!type_check (unit
, 0, BT_INTEGER
))
6481 /************* Check functions for intrinsic subroutines *************/
6484 gfc_check_cpu_time (gfc_expr
*time
)
6486 if (!scalar_check (time
, 0))
6489 if (!type_check (time
, 0, BT_REAL
))
6492 if (!variable_check (time
, 0, false))
6500 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
6501 gfc_expr
*zone
, gfc_expr
*values
)
6505 if (!type_check (date
, 0, BT_CHARACTER
))
6507 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6509 if (!scalar_check (date
, 0))
6511 if (!variable_check (date
, 0, false))
6517 if (!type_check (time
, 1, BT_CHARACTER
))
6519 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
6521 if (!scalar_check (time
, 1))
6523 if (!variable_check (time
, 1, false))
6529 if (!type_check (zone
, 2, BT_CHARACTER
))
6531 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
6533 if (!scalar_check (zone
, 2))
6535 if (!variable_check (zone
, 2, false))
6541 if (!type_check (values
, 3, BT_INTEGER
))
6543 if (!array_check (values
, 3))
6545 if (!rank_check (values
, 3, 1))
6547 if (!variable_check (values
, 3, false))
6556 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
6557 gfc_expr
*to
, gfc_expr
*topos
)
6559 if (!type_check (from
, 0, BT_INTEGER
))
6562 if (!type_check (frompos
, 1, BT_INTEGER
))
6565 if (!type_check (len
, 2, BT_INTEGER
))
6568 if (!same_type_check (from
, 0, to
, 3))
6571 if (!variable_check (to
, 3, false))
6574 if (!type_check (topos
, 4, BT_INTEGER
))
6577 if (!nonnegative_check ("frompos", frompos
))
6580 if (!nonnegative_check ("topos", topos
))
6583 if (!nonnegative_check ("len", len
))
6586 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
6589 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
6596 /* Check the arguments for RANDOM_INIT. */
6599 gfc_check_random_init (gfc_expr
*repeatable
, gfc_expr
*image_distinct
)
6601 if (!type_check (repeatable
, 0, BT_LOGICAL
))
6604 if (!scalar_check (repeatable
, 0))
6607 if (!type_check (image_distinct
, 1, BT_LOGICAL
))
6610 if (!scalar_check (image_distinct
, 1))
6618 gfc_check_random_number (gfc_expr
*harvest
)
6620 if (!type_check (harvest
, 0, BT_REAL
))
6623 if (!variable_check (harvest
, 0, false))
6631 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
6633 unsigned int nargs
= 0, seed_size
;
6634 locus
*where
= NULL
;
6635 mpz_t put_size
, get_size
;
6637 /* Keep the number of bytes in sync with master_state in
6638 libgfortran/intrinsics/random.c. */
6639 seed_size
= 32 / gfc_default_integer_kind
;
6643 if (size
->expr_type
!= EXPR_VARIABLE
6644 || !size
->symtree
->n
.sym
->attr
.optional
)
6647 if (!scalar_check (size
, 0))
6650 if (!type_check (size
, 0, BT_INTEGER
))
6653 if (!variable_check (size
, 0, false))
6656 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
6662 if (put
->expr_type
!= EXPR_VARIABLE
6663 || !put
->symtree
->n
.sym
->attr
.optional
)
6666 where
= &put
->where
;
6669 if (!array_check (put
, 1))
6672 if (!rank_check (put
, 1, 1))
6675 if (!type_check (put
, 1, BT_INTEGER
))
6678 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
6681 if (gfc_array_size (put
, &put_size
)
6682 && mpz_get_ui (put_size
) < seed_size
)
6683 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6684 "too small (%i/%i)",
6685 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6686 &put
->where
, (int) mpz_get_ui (put_size
), seed_size
);
6691 if (get
->expr_type
!= EXPR_VARIABLE
6692 || !get
->symtree
->n
.sym
->attr
.optional
)
6695 where
= &get
->where
;
6698 if (!array_check (get
, 2))
6701 if (!rank_check (get
, 2, 1))
6704 if (!type_check (get
, 2, BT_INTEGER
))
6707 if (!variable_check (get
, 2, false))
6710 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
6713 if (gfc_array_size (get
, &get_size
)
6714 && mpz_get_ui (get_size
) < seed_size
)
6715 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6716 "too small (%i/%i)",
6717 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6718 &get
->where
, (int) mpz_get_ui (get_size
), seed_size
);
6721 /* RANDOM_SEED may not have more than one non-optional argument. */
6723 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
6729 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
6733 int num_percent
, nargs
;
6736 if (e
->expr_type
!= EXPR_CONSTANT
)
6739 len
= e
->value
.character
.length
;
6740 if (e
->value
.character
.string
[len
-1] != '\0')
6741 gfc_internal_error ("fe_runtime_error string must be null terminated");
6744 for (i
=0; i
<len
-1; i
++)
6745 if (e
->value
.character
.string
[i
] == '%')
6749 for (; a
; a
= a
->next
)
6752 if (nargs
-1 != num_percent
)
6753 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6754 nargs
, num_percent
++);
6760 gfc_check_second_sub (gfc_expr
*time
)
6762 if (!scalar_check (time
, 0))
6765 if (!type_check (time
, 0, BT_REAL
))
6768 if (!kind_value_check (time
, 0, 4))
6775 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6776 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6777 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6778 count_max are all optional arguments */
6781 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
6782 gfc_expr
*count_max
)
6786 if (!scalar_check (count
, 0))
6789 if (!type_check (count
, 0, BT_INTEGER
))
6792 if (count
->ts
.kind
!= gfc_default_integer_kind
6793 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
6794 "SYSTEM_CLOCK at %L has non-default kind",
6798 if (!variable_check (count
, 0, false))
6802 if (count_rate
!= NULL
)
6804 if (!scalar_check (count_rate
, 1))
6807 if (!variable_check (count_rate
, 1, false))
6810 if (count_rate
->ts
.type
== BT_REAL
)
6812 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
6813 "SYSTEM_CLOCK at %L", &count_rate
->where
))
6818 if (!type_check (count_rate
, 1, BT_INTEGER
))
6821 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6822 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6823 "SYSTEM_CLOCK at %L has non-default kind",
6824 &count_rate
->where
))
6830 if (count_max
!= NULL
)
6832 if (!scalar_check (count_max
, 2))
6835 if (!type_check (count_max
, 2, BT_INTEGER
))
6838 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6839 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6840 "SYSTEM_CLOCK at %L has non-default kind",
6844 if (!variable_check (count_max
, 2, false))
6853 gfc_check_irand (gfc_expr
*x
)
6858 if (!scalar_check (x
, 0))
6861 if (!type_check (x
, 0, BT_INTEGER
))
6864 if (!kind_value_check (x
, 0, 4))
6872 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6874 if (!scalar_check (seconds
, 0))
6876 if (!type_check (seconds
, 0, BT_INTEGER
))
6879 if (!int_or_proc_check (handler
, 1))
6881 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6887 if (!scalar_check (status
, 2))
6889 if (!type_check (status
, 2, BT_INTEGER
))
6891 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6899 gfc_check_rand (gfc_expr
*x
)
6904 if (!scalar_check (x
, 0))
6907 if (!type_check (x
, 0, BT_INTEGER
))
6910 if (!kind_value_check (x
, 0, 4))
6918 gfc_check_srand (gfc_expr
*x
)
6920 if (!scalar_check (x
, 0))
6923 if (!type_check (x
, 0, BT_INTEGER
))
6926 if (!kind_value_check (x
, 0, 4))
6934 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6936 if (!scalar_check (time
, 0))
6938 if (!type_check (time
, 0, BT_INTEGER
))
6941 if (!type_check (result
, 1, BT_CHARACTER
))
6943 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6951 gfc_check_dtime_etime (gfc_expr
*x
)
6953 if (!array_check (x
, 0))
6956 if (!rank_check (x
, 0, 1))
6959 if (!variable_check (x
, 0, false))
6962 if (!type_check (x
, 0, BT_REAL
))
6965 if (!kind_value_check (x
, 0, 4))
6973 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6975 if (!array_check (values
, 0))
6978 if (!rank_check (values
, 0, 1))
6981 if (!variable_check (values
, 0, false))
6984 if (!type_check (values
, 0, BT_REAL
))
6987 if (!kind_value_check (values
, 0, 4))
6990 if (!scalar_check (time
, 1))
6993 if (!type_check (time
, 1, BT_REAL
))
6996 if (!kind_value_check (time
, 1, 4))
7004 gfc_check_fdate_sub (gfc_expr
*date
)
7006 if (!type_check (date
, 0, BT_CHARACTER
))
7008 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
7016 gfc_check_gerror (gfc_expr
*msg
)
7018 if (!type_check (msg
, 0, BT_CHARACTER
))
7020 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7028 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
7030 if (!type_check (cwd
, 0, BT_CHARACTER
))
7032 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
7038 if (!scalar_check (status
, 1))
7041 if (!type_check (status
, 1, BT_INTEGER
))
7049 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
7051 if (!type_check (pos
, 0, BT_INTEGER
))
7054 if (pos
->ts
.kind
> gfc_default_integer_kind
)
7056 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
7057 "not wider than the default kind (%d)",
7058 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7059 &pos
->where
, gfc_default_integer_kind
);
7063 if (!type_check (value
, 1, BT_CHARACTER
))
7065 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
7073 gfc_check_getlog (gfc_expr
*msg
)
7075 if (!type_check (msg
, 0, BT_CHARACTER
))
7077 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7085 gfc_check_exit (gfc_expr
*status
)
7090 if (!type_check (status
, 0, BT_INTEGER
))
7093 if (!scalar_check (status
, 0))
7101 gfc_check_flush (gfc_expr
*unit
)
7106 if (!type_check (unit
, 0, BT_INTEGER
))
7109 if (!scalar_check (unit
, 0))
7117 gfc_check_free (gfc_expr
*i
)
7119 if (!type_check (i
, 0, BT_INTEGER
))
7122 if (!scalar_check (i
, 0))
7130 gfc_check_hostnm (gfc_expr
*name
)
7132 if (!type_check (name
, 0, BT_CHARACTER
))
7134 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7142 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
7144 if (!type_check (name
, 0, BT_CHARACTER
))
7146 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7152 if (!scalar_check (status
, 1))
7155 if (!type_check (status
, 1, BT_INTEGER
))
7163 gfc_check_itime_idate (gfc_expr
*values
)
7165 if (!array_check (values
, 0))
7168 if (!rank_check (values
, 0, 1))
7171 if (!variable_check (values
, 0, false))
7174 if (!type_check (values
, 0, BT_INTEGER
))
7177 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
7185 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
7187 if (!type_check (time
, 0, BT_INTEGER
))
7190 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
7193 if (!scalar_check (time
, 0))
7196 if (!array_check (values
, 1))
7199 if (!rank_check (values
, 1, 1))
7202 if (!variable_check (values
, 1, false))
7205 if (!type_check (values
, 1, BT_INTEGER
))
7208 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
7216 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
7218 if (!scalar_check (unit
, 0))
7221 if (!type_check (unit
, 0, BT_INTEGER
))
7224 if (!type_check (name
, 1, BT_CHARACTER
))
7226 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
7234 gfc_check_is_contiguous (gfc_expr
*array
)
7236 if (array
->expr_type
== EXPR_NULL
)
7238 gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7239 "associated pointer", &array
->where
, gfc_current_intrinsic
);
7243 if (!array_check (array
, 0))
7251 gfc_check_isatty (gfc_expr
*unit
)
7256 if (!type_check (unit
, 0, BT_INTEGER
))
7259 if (!scalar_check (unit
, 0))
7267 gfc_check_isnan (gfc_expr
*x
)
7269 if (!type_check (x
, 0, BT_REAL
))
7277 gfc_check_perror (gfc_expr
*string
)
7279 if (!type_check (string
, 0, BT_CHARACTER
))
7281 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
7289 gfc_check_umask (gfc_expr
*mask
)
7291 if (!type_check (mask
, 0, BT_INTEGER
))
7294 if (!scalar_check (mask
, 0))
7302 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
7304 if (!type_check (mask
, 0, BT_INTEGER
))
7307 if (!scalar_check (mask
, 0))
7313 if (!scalar_check (old
, 1))
7316 if (!type_check (old
, 1, BT_INTEGER
))
7324 gfc_check_unlink (gfc_expr
*name
)
7326 if (!type_check (name
, 0, BT_CHARACTER
))
7328 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7336 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
7338 if (!type_check (name
, 0, BT_CHARACTER
))
7340 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7346 if (!scalar_check (status
, 1))
7349 if (!type_check (status
, 1, BT_INTEGER
))
7357 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
7359 if (!scalar_check (number
, 0))
7361 if (!type_check (number
, 0, BT_INTEGER
))
7364 if (!int_or_proc_check (handler
, 1))
7366 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7374 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
7376 if (!scalar_check (number
, 0))
7378 if (!type_check (number
, 0, BT_INTEGER
))
7381 if (!int_or_proc_check (handler
, 1))
7383 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7389 if (!type_check (status
, 2, BT_INTEGER
))
7391 if (!scalar_check (status
, 2))
7399 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
7401 if (!type_check (cmd
, 0, BT_CHARACTER
))
7403 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
7406 if (!scalar_check (status
, 1))
7409 if (!type_check (status
, 1, BT_INTEGER
))
7412 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
7419 /* This is used for the GNU intrinsics AND, OR and XOR. */
7421 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
7423 if (i
->ts
.type
!= BT_INTEGER
7424 && i
->ts
.type
!= BT_LOGICAL
7425 && i
->ts
.type
!= BT_BOZ
)
7427 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7428 "LOGICAL, or a BOZ literal constant",
7429 gfc_current_intrinsic_arg
[0]->name
,
7430 gfc_current_intrinsic
, &i
->where
);
7434 if (j
->ts
.type
!= BT_INTEGER
7435 && j
->ts
.type
!= BT_LOGICAL
7436 && j
->ts
.type
!= BT_BOZ
)
7438 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7439 "LOGICAL, or a BOZ literal constant",
7440 gfc_current_intrinsic_arg
[1]->name
,
7441 gfc_current_intrinsic
, &j
->where
);
7445 /* i and j cannot both be BOZ literal constants. */
7446 if (!boz_args_check (i
, j
))
7449 /* If i is BOZ and j is integer, convert i to type of j. */
7450 if (i
->ts
.type
== BT_BOZ
)
7452 if (j
->ts
.type
!= BT_INTEGER
)
7454 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7455 gfc_current_intrinsic_arg
[1]->name
,
7456 gfc_current_intrinsic
, &j
->where
);
7460 if (!gfc_boz2int (i
, j
->ts
.kind
))
7464 /* If j is BOZ and i is integer, convert j to type of i. */
7465 if (j
->ts
.type
== BT_BOZ
)
7467 if (i
->ts
.type
!= BT_INTEGER
)
7469 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7470 gfc_current_intrinsic_arg
[0]->name
,
7471 gfc_current_intrinsic
, &j
->where
);
7475 if (!gfc_boz2int (j
, i
->ts
.kind
))
7479 if (!same_type_check (i
, 0, j
, 1, false))
7482 if (!scalar_check (i
, 0))
7485 if (!scalar_check (j
, 1))
7493 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
7496 if (a
->expr_type
== EXPR_NULL
)
7498 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7499 "argument to STORAGE_SIZE, because it returns a "
7500 "disassociated pointer", &a
->where
);
7504 if (a
->ts
.type
== BT_ASSUMED
)
7506 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7507 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7512 if (a
->ts
.type
== BT_PROCEDURE
)
7514 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7515 "procedure", gfc_current_intrinsic_arg
[0]->name
,
7516 gfc_current_intrinsic
, &a
->where
);
7520 if (a
->ts
.type
== BT_BOZ
&& illegal_boz_arg (a
))
7526 if (!type_check (kind
, 1, BT_INTEGER
))
7529 if (!scalar_check (kind
, 1))
7532 if (kind
->expr_type
!= EXPR_CONSTANT
)
7534 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7535 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,