2 Copyright (C) 2002-2020 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] == '4' || buf
[0] == '6')
345 else if (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] == '4' || buf
[0] == '6')
434 else if (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
->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
);
742 if (e
->rank
!= 0 && e
->ts
.type
!= BT_PROCEDURE
)
745 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
746 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
753 /* If expr is a constant, then check to ensure that it is greater than
757 nonnegative_check (const char *arg
, gfc_expr
*expr
)
761 if (expr
->expr_type
== EXPR_CONSTANT
)
763 gfc_extract_int (expr
, &i
);
766 gfc_error ("%qs at %L must be nonnegative", arg
, &expr
->where
);
775 /* If expr is a constant, then check to ensure that it is greater than zero. */
778 positive_check (int n
, gfc_expr
*expr
)
782 if (expr
->expr_type
== EXPR_CONSTANT
)
784 gfc_extract_int (expr
, &i
);
787 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
788 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
798 /* If expr2 is constant, then check that the value is less than
799 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
802 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
803 gfc_expr
*expr2
, bool or_equal
)
807 if (expr2
->expr_type
== EXPR_CONSTANT
)
809 gfc_extract_int (expr2
, &i2
);
810 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
812 /* For ISHFT[C], check that |shift| <= bit_size(i). */
818 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
820 gfc_error ("The absolute value of SHIFT at %L must be less "
821 "than or equal to BIT_SIZE(%qs)",
822 &expr2
->where
, arg1
);
829 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
831 gfc_error ("%qs at %L must be less than "
832 "or equal to BIT_SIZE(%qs)",
833 arg2
, &expr2
->where
, arg1
);
839 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
841 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
842 arg2
, &expr2
->where
, arg1
);
852 /* If expr is constant, then check that the value is less than or equal
853 to the bit_size of the kind k. */
856 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
860 if (expr
->expr_type
!= EXPR_CONSTANT
)
863 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
864 gfc_extract_int (expr
, &val
);
866 if (val
> gfc_integer_kinds
[i
].bit_size
)
868 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
869 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
877 /* If expr2 and expr3 are constants, then check that the value is less than
878 or equal to bit_size(expr1). */
881 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
882 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
886 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
888 gfc_extract_int (expr2
, &i2
);
889 gfc_extract_int (expr3
, &i3
);
891 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
892 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
894 gfc_error ("%<%s + %s%> at %L must be less than or equal "
896 arg2
, arg3
, &expr2
->where
, arg1
);
904 /* Make sure two expressions have the same type. */
907 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
, bool assoc
= false)
909 gfc_typespec
*ets
= &e
->ts
;
910 gfc_typespec
*fts
= &f
->ts
;
914 /* Procedure pointer component expressions have the type of the interface
915 procedure. If they are being tested for association with a procedure
916 pointer (ie. not a component), the type of the procedure must be
918 if (e
->ts
.type
== BT_PROCEDURE
&& e
->symtree
->n
.sym
)
919 ets
= &e
->symtree
->n
.sym
->ts
;
920 if (f
->ts
.type
== BT_PROCEDURE
&& f
->symtree
->n
.sym
)
921 fts
= &f
->symtree
->n
.sym
->ts
;
924 if (gfc_compare_types (ets
, fts
))
927 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
928 "and kind as %qs", gfc_current_intrinsic_arg
[m
]->name
,
929 gfc_current_intrinsic
, &f
->where
,
930 gfc_current_intrinsic_arg
[n
]->name
);
936 /* Make sure that an expression has a certain (nonzero) rank. */
939 rank_check (gfc_expr
*e
, int n
, int rank
)
944 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
945 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
952 /* Make sure a variable expression is not an optional dummy argument. */
955 nonoptional_check (gfc_expr
*e
, int n
)
957 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
959 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
960 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
964 /* TODO: Recursive check on nonoptional variables? */
970 /* Check for ALLOCATABLE attribute. */
973 allocatable_check (gfc_expr
*e
, int n
)
975 symbol_attribute attr
;
977 attr
= gfc_variable_attr (e
, NULL
);
978 if (!attr
.allocatable
|| attr
.associate_var
)
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 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
1058 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
1064 /* Check the common DIM parameter for correctness. */
1067 dim_check (gfc_expr
*dim
, int n
, bool optional
)
1072 if (!type_check (dim
, n
, BT_INTEGER
))
1075 if (!scalar_check (dim
, n
))
1078 if (!optional
&& !nonoptional_check (dim
, n
))
1085 /* If a coarray DIM parameter is a constant, make sure that it is greater than
1086 zero and less than or equal to the corank of the given array. */
1089 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
1093 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
1095 if (dim
->expr_type
!= EXPR_CONSTANT
)
1098 if (array
->ts
.type
== BT_CLASS
)
1101 corank
= gfc_get_corank (array
);
1103 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1104 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
1106 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1107 "codimension index", gfc_current_intrinsic
, &dim
->where
);
1116 /* If a DIM parameter is a constant, make sure that it is greater than
1117 zero and less than or equal to the rank of the given array. If
1118 allow_assumed is zero then dim must be less than the rank of the array
1119 for assumed size arrays. */
1122 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
1130 if (dim
->expr_type
!= EXPR_CONSTANT
)
1133 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
1134 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
1135 rank
= array
->rank
+ 1;
1139 /* Assumed-rank array. */
1141 rank
= GFC_MAX_DIMENSIONS
;
1143 if (array
->expr_type
== EXPR_VARIABLE
)
1145 ar
= gfc_find_array_ref (array
);
1146 if (ar
->as
->type
== AS_ASSUMED_SIZE
1148 && ar
->type
!= AR_ELEMENT
1149 && ar
->type
!= AR_SECTION
)
1153 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
1154 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
1156 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1157 "dimension index", gfc_current_intrinsic
, &dim
->where
);
1166 /* Compare the size of a along dimension ai with the size of b along
1167 dimension bi, returning 0 if they are known not to be identical,
1168 and 1 if they are identical, or if this cannot be determined. */
1171 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
1173 mpz_t a_size
, b_size
;
1176 gcc_assert (a
->rank
> ai
);
1177 gcc_assert (b
->rank
> bi
);
1181 if (gfc_array_dimen_size (a
, ai
, &a_size
))
1183 if (gfc_array_dimen_size (b
, bi
, &b_size
))
1185 if (mpz_cmp (a_size
, b_size
) != 0)
1195 /* Calculate the length of a character variable, including substrings.
1196 Strip away parentheses if necessary. Return -1 if no length could
1200 gfc_var_strlen (const gfc_expr
*a
)
1204 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
1205 a
= a
->value
.op
.op1
;
1207 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
1212 long start_a
, end_a
;
1217 if ((!ra
->u
.ss
.start
|| ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1218 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1220 start_a
= ra
->u
.ss
.start
? mpz_get_si (ra
->u
.ss
.start
->value
.integer
)
1222 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
1223 return (end_a
< start_a
) ? 0 : end_a
- start_a
+ 1;
1225 else if (ra
->u
.ss
.start
1226 && gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
1232 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
1233 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1234 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
1235 else if (a
->expr_type
== EXPR_CONSTANT
1236 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
1237 return a
->value
.character
.length
;
1243 /* Check whether two character expressions have the same length;
1244 returns true if they have or if the length cannot be determined,
1245 otherwise return false and raise a gfc_error. */
1248 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
1252 len_a
= gfc_var_strlen(a
);
1253 len_b
= gfc_var_strlen(b
);
1255 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
1259 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
1260 len_a
, len_b
, name
, &a
->where
);
1266 /***** Check functions *****/
1268 /* Check subroutine suitable for intrinsics taking a real argument and
1269 a kind argument for the result. */
1272 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
1274 if (!type_check (a
, 0, BT_REAL
))
1276 if (!kind_check (kind
, 1, type
))
1283 /* Check subroutine suitable for ceiling, floor and nint. */
1286 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
1288 return check_a_kind (a
, kind
, BT_INTEGER
);
1292 /* Check subroutine suitable for aint, anint. */
1295 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
1297 return check_a_kind (a
, kind
, BT_REAL
);
1302 gfc_check_abs (gfc_expr
*a
)
1304 if (!numeric_check (a
, 0))
1312 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
1314 if (a
->ts
.type
== BT_BOZ
)
1316 if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
1317 "ACHAR intrinsic subprogram", &a
->where
))
1320 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
1324 if (!type_check (a
, 0, BT_INTEGER
))
1327 if (!kind_check (kind
, 1, BT_CHARACTER
))
1335 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
1337 if (!type_check (name
, 0, BT_CHARACTER
)
1338 || !scalar_check (name
, 0))
1340 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
1343 if (!type_check (mode
, 1, BT_CHARACTER
)
1344 || !scalar_check (mode
, 1))
1346 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
1354 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
1356 if (!logical_array_check (mask
, 0))
1359 if (!dim_check (dim
, 1, false))
1362 if (!dim_rank_check (dim
, mask
, 0))
1369 /* Limited checking for ALLOCATED intrinsic. Additional checking
1370 is performed in intrinsic.c(sort_actual), because ALLOCATED
1371 has two mutually exclusive non-optional arguments. */
1374 gfc_check_allocated (gfc_expr
*array
)
1376 /* Tests on allocated components of coarrays need to detour the check to
1377 argument of the _caf_get. */
1378 if (flag_coarray
== GFC_FCOARRAY_LIB
&& array
->expr_type
== EXPR_FUNCTION
1379 && array
->value
.function
.isym
1380 && array
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1382 array
= array
->value
.function
.actual
->expr
;
1387 if (!variable_check (array
, 0, false))
1389 if (!allocatable_check (array
, 0))
1396 /* Common check function where the first argument must be real or
1397 integer and the second argument must be the same as the first. */
1400 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
1402 if (!int_or_real_check (a
, 0))
1405 if (a
->ts
.type
!= p
->ts
.type
)
1407 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
1408 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
1409 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1414 if (a
->ts
.kind
!= p
->ts
.kind
)
1416 if (!gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1426 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
1428 if (!double_check (x
, 0) || !double_check (y
, 1))
1436 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
1438 symbol_attribute attr1
, attr2
;
1443 where
= &pointer
->where
;
1445 if (pointer
->expr_type
== EXPR_NULL
)
1448 attr1
= gfc_expr_attr (pointer
);
1450 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
1452 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
1453 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1459 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
1461 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1462 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
1463 gfc_current_intrinsic
, &pointer
->where
);
1467 /* Target argument is optional. */
1471 where
= &target
->where
;
1472 if (target
->expr_type
== EXPR_NULL
)
1475 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
1476 attr2
= gfc_expr_attr (target
);
1479 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1480 "or target VARIABLE or FUNCTION",
1481 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1486 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
1488 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1489 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
1490 gfc_current_intrinsic
, &target
->where
);
1495 if (attr1
.pointer
&& gfc_is_coindexed (target
))
1497 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1498 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
1499 gfc_current_intrinsic
, &target
->where
);
1504 if (!same_type_check (pointer
, 0, target
, 1, true))
1506 if (!rank_check (target
, 0, pointer
->rank
))
1508 if (target
->rank
> 0)
1510 for (i
= 0; i
< target
->rank
; i
++)
1511 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1513 gfc_error ("Array section with a vector subscript at %L shall not "
1514 "be the target of a pointer",
1524 gfc_error ("NULL pointer at %L is not permitted as actual argument "
1525 "of %qs intrinsic function", where
, gfc_current_intrinsic
);
1532 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
1534 /* gfc_notify_std would be a waste of time as the return value
1535 is seemingly used only for the generic resolution. The error
1536 will be: Too many arguments. */
1537 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
1540 return gfc_check_atan2 (y
, x
);
1545 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1547 if (!type_check (y
, 0, BT_REAL
))
1549 if (!same_type_check (y
, 0, x
, 1))
1557 gfc_check_atomic (gfc_expr
*atom
, int atom_no
, gfc_expr
*value
, int val_no
,
1558 gfc_expr
*stat
, int stat_no
)
1560 if (!scalar_check (atom
, atom_no
) || !scalar_check (value
, val_no
))
1563 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1564 && !(atom
->ts
.type
== BT_LOGICAL
1565 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1567 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1568 "integer of ATOMIC_INT_KIND or a logical of "
1569 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1573 if (!gfc_is_coarray (atom
) && !gfc_is_coindexed (atom
))
1575 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1576 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1580 if (atom
->ts
.type
!= value
->ts
.type
)
1582 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1583 "type as %qs at %L", gfc_current_intrinsic_arg
[val_no
]->name
,
1584 gfc_current_intrinsic
, &value
->where
,
1585 gfc_current_intrinsic_arg
[atom_no
]->name
, &atom
->where
);
1591 if (!type_check (stat
, stat_no
, BT_INTEGER
))
1593 if (!scalar_check (stat
, stat_no
))
1595 if (!variable_check (stat
, stat_no
, false))
1597 if (!kind_value_check (stat
, stat_no
, gfc_default_integer_kind
))
1600 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1601 gfc_current_intrinsic
, &stat
->where
))
1610 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1612 if (atom
->expr_type
== EXPR_FUNCTION
1613 && atom
->value
.function
.isym
1614 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1615 atom
= atom
->value
.function
.actual
->expr
;
1617 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1619 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1620 "definable", gfc_current_intrinsic
, &atom
->where
);
1624 return gfc_check_atomic (atom
, 0, value
, 1, stat
, 2);
1629 gfc_check_atomic_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*stat
)
1631 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1633 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1634 "integer of ATOMIC_INT_KIND", &atom
->where
,
1635 gfc_current_intrinsic
);
1639 return gfc_check_atomic_def (atom
, value
, stat
);
1644 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
, gfc_expr
*stat
)
1646 if (atom
->expr_type
== EXPR_FUNCTION
1647 && atom
->value
.function
.isym
1648 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1649 atom
= atom
->value
.function
.actual
->expr
;
1651 if (!gfc_check_vardef_context (value
, false, false, false, NULL
))
1653 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1654 "definable", gfc_current_intrinsic
, &value
->where
);
1658 return gfc_check_atomic (atom
, 1, value
, 0, stat
, 2);
1663 gfc_check_image_status (gfc_expr
*image
, gfc_expr
*team
)
1665 /* IMAGE has to be a positive, scalar integer. */
1666 if (!type_check (image
, 0, BT_INTEGER
) || !scalar_check (image
, 0)
1667 || !positive_check (0, image
))
1672 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1673 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1682 gfc_check_failed_or_stopped_images (gfc_expr
*team
, gfc_expr
*kind
)
1686 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1687 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1696 if (!type_check (kind
, 1, BT_INTEGER
) || !scalar_check (kind
, 1)
1697 || !positive_check (1, kind
))
1700 /* Get the kind, reporting error on non-constant or overflow. */
1701 gfc_current_locus
= kind
->where
;
1702 if (gfc_extract_int (kind
, &k
, 1))
1704 if (gfc_validate_kind (BT_INTEGER
, k
, true) == -1)
1706 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1707 "valid integer kind", gfc_current_intrinsic_arg
[1]->name
,
1708 gfc_current_intrinsic
, &kind
->where
);
1717 gfc_check_get_team (gfc_expr
*level
)
1721 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1722 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
1731 gfc_check_atomic_cas (gfc_expr
*atom
, gfc_expr
*old
, gfc_expr
*compare
,
1732 gfc_expr
*new_val
, gfc_expr
*stat
)
1734 if (atom
->expr_type
== EXPR_FUNCTION
1735 && atom
->value
.function
.isym
1736 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1737 atom
= atom
->value
.function
.actual
->expr
;
1739 if (!gfc_check_atomic (atom
, 0, new_val
, 3, stat
, 4))
1742 if (!scalar_check (old
, 1) || !scalar_check (compare
, 2))
1745 if (!same_type_check (atom
, 0, old
, 1))
1748 if (!same_type_check (atom
, 0, compare
, 2))
1751 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1753 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1754 "definable", gfc_current_intrinsic
, &atom
->where
);
1758 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1760 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1761 "definable", gfc_current_intrinsic
, &old
->where
);
1769 gfc_check_event_query (gfc_expr
*event
, gfc_expr
*count
, gfc_expr
*stat
)
1771 if (event
->ts
.type
!= BT_DERIVED
1772 || event
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
1773 || event
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
)
1775 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1776 "shall be of type EVENT_TYPE", &event
->where
);
1780 if (!scalar_check (event
, 0))
1783 if (!gfc_check_vardef_context (count
, false, false, false, NULL
))
1785 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1786 "shall be definable", &count
->where
);
1790 if (!type_check (count
, 1, BT_INTEGER
))
1793 int i
= gfc_validate_kind (BT_INTEGER
, count
->ts
.kind
, false);
1794 int j
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
1796 if (gfc_integer_kinds
[i
].range
< gfc_integer_kinds
[j
].range
)
1798 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1799 "shall have at least the range of the default integer",
1806 if (!type_check (stat
, 2, BT_INTEGER
))
1808 if (!scalar_check (stat
, 2))
1810 if (!variable_check (stat
, 2, false))
1813 if (!gfc_notify_std (GFC_STD_F2018
, "STAT= argument to %s at %L",
1814 gfc_current_intrinsic
, &stat
->where
))
1823 gfc_check_atomic_fetch_op (gfc_expr
*atom
, gfc_expr
*value
, gfc_expr
*old
,
1826 if (atom
->expr_type
== EXPR_FUNCTION
1827 && atom
->value
.function
.isym
1828 && atom
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
1829 atom
= atom
->value
.function
.actual
->expr
;
1831 if (atom
->ts
.type
!= BT_INTEGER
|| atom
->ts
.kind
!= gfc_atomic_int_kind
)
1833 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1834 "integer of ATOMIC_INT_KIND", &atom
->where
,
1835 gfc_current_intrinsic
);
1839 if (!gfc_check_atomic (atom
, 0, value
, 1, stat
, 3))
1842 if (!scalar_check (old
, 2))
1845 if (!same_type_check (atom
, 0, old
, 2))
1848 if (!gfc_check_vardef_context (atom
, false, false, false, NULL
))
1850 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1851 "definable", gfc_current_intrinsic
, &atom
->where
);
1855 if (!gfc_check_vardef_context (old
, false, false, false, NULL
))
1857 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1858 "definable", gfc_current_intrinsic
, &old
->where
);
1866 /* BESJN and BESYN functions. */
1869 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1871 if (!type_check (n
, 0, BT_INTEGER
))
1873 if (n
->expr_type
== EXPR_CONSTANT
)
1876 gfc_extract_int (n
, &i
);
1877 if (i
< 0 && !gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1878 "N at %L", &n
->where
))
1882 if (!type_check (x
, 1, BT_REAL
))
1889 /* Transformational version of the Bessel JN and YN functions. */
1892 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1894 if (!type_check (n1
, 0, BT_INTEGER
))
1896 if (!scalar_check (n1
, 0))
1898 if (!nonnegative_check ("N1", n1
))
1901 if (!type_check (n2
, 1, BT_INTEGER
))
1903 if (!scalar_check (n2
, 1))
1905 if (!nonnegative_check ("N2", n2
))
1908 if (!type_check (x
, 2, BT_REAL
))
1910 if (!scalar_check (x
, 2))
1918 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1920 extern int gfc_max_integer_kind
;
1922 /* If i and j are both BOZ, convert to widest INTEGER. */
1923 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_BOZ
)
1925 if (!gfc_boz2int (i
, gfc_max_integer_kind
))
1927 if (!gfc_boz2int (j
, gfc_max_integer_kind
))
1931 /* If i is BOZ and j is integer, convert i to type of j. */
1932 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
1933 && !gfc_boz2int (i
, j
->ts
.kind
))
1936 /* If j is BOZ and i is integer, convert j to type of i. */
1937 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
1938 && !gfc_boz2int (j
, i
->ts
.kind
))
1941 if (!type_check (i
, 0, BT_INTEGER
))
1944 if (!type_check (j
, 1, BT_INTEGER
))
1952 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1954 if (!type_check (i
, 0, BT_INTEGER
))
1957 if (!type_check (pos
, 1, BT_INTEGER
))
1960 if (!nonnegative_check ("pos", pos
))
1963 if (!less_than_bitsize1 ("i", i
, "pos", pos
, false))
1971 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1973 if (i
->ts
.type
== BT_BOZ
)
1975 if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
1976 "CHAR intrinsic subprogram", &i
->where
))
1979 if (!gfc_boz2int (i
, gfc_default_integer_kind
))
1983 if (!type_check (i
, 0, BT_INTEGER
))
1986 if (!kind_check (kind
, 1, BT_CHARACTER
))
1994 gfc_check_chdir (gfc_expr
*dir
)
1996 if (!type_check (dir
, 0, BT_CHARACTER
))
1998 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
2006 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
2008 if (!type_check (dir
, 0, BT_CHARACTER
))
2010 if (!kind_value_check (dir
, 0, gfc_default_character_kind
))
2016 if (!type_check (status
, 1, BT_INTEGER
))
2018 if (!scalar_check (status
, 1))
2026 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
2028 if (!type_check (name
, 0, BT_CHARACTER
))
2030 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2033 if (!type_check (mode
, 1, BT_CHARACTER
))
2035 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2043 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
2045 if (!type_check (name
, 0, BT_CHARACTER
))
2047 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
2050 if (!type_check (mode
, 1, BT_CHARACTER
))
2052 if (!kind_value_check (mode
, 1, gfc_default_character_kind
))
2058 if (!type_check (status
, 2, BT_INTEGER
))
2061 if (!scalar_check (status
, 2))
2069 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
2073 /* Check kind first, because it may be needed in conversion of a BOZ. */
2076 if (!kind_check (kind
, 2, BT_COMPLEX
))
2078 gfc_extract_int (kind
, &k
);
2081 k
= gfc_default_complex_kind
;
2083 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, k
))
2086 if (!numeric_check (x
, 0))
2091 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, k
))
2094 if (!numeric_check (y
, 1))
2097 if (x
->ts
.type
== BT_COMPLEX
)
2099 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2100 "present if %<x%> is COMPLEX",
2101 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2106 if (y
->ts
.type
== BT_COMPLEX
)
2108 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2109 "of either REAL or INTEGER",
2110 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2116 if (!kind
&& warn_conversion
2117 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
2118 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2119 "COMPLEX(%d) at %L might lose precision, consider using "
2120 "the KIND argument", gfc_typename (&x
->ts
),
2121 gfc_default_real_kind
, &x
->where
);
2122 else if (y
&& !kind
&& warn_conversion
2123 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
2124 gfc_warning_now (OPT_Wconversion
, "Conversion from %s to default-kind "
2125 "COMPLEX(%d) at %L might lose precision, consider using "
2126 "the KIND argument", gfc_typename (&y
->ts
),
2127 gfc_default_real_kind
, &y
->where
);
2133 check_co_collective (gfc_expr
*a
, gfc_expr
*image_idx
, gfc_expr
*stat
,
2134 gfc_expr
*errmsg
, bool co_reduce
)
2136 if (!variable_check (a
, 0, false))
2139 if (!gfc_check_vardef_context (a
, false, false, false, "argument 'A' with "
2143 /* Fortran 2008, 12.5.2.4, paragraph 18. */
2144 if (gfc_has_vector_subscript (a
))
2146 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
2147 "subroutine %s shall not have a vector subscript",
2148 &a
->where
, gfc_current_intrinsic
);
2152 if (gfc_is_coindexed (a
))
2154 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
2155 "coindexed", &a
->where
, gfc_current_intrinsic
);
2159 if (image_idx
!= NULL
)
2161 if (!type_check (image_idx
, co_reduce
? 2 : 1, BT_INTEGER
))
2163 if (!scalar_check (image_idx
, co_reduce
? 2 : 1))
2169 if (!type_check (stat
, co_reduce
? 3 : 2, BT_INTEGER
))
2171 if (!scalar_check (stat
, co_reduce
? 3 : 2))
2173 if (!variable_check (stat
, co_reduce
? 3 : 2, false))
2175 if (stat
->ts
.kind
!= 4)
2177 gfc_error ("The stat= argument at %L must be a kind=4 integer "
2178 "variable", &stat
->where
);
2185 if (!type_check (errmsg
, co_reduce
? 4 : 3, BT_CHARACTER
))
2187 if (!scalar_check (errmsg
, co_reduce
? 4 : 3))
2189 if (!variable_check (errmsg
, co_reduce
? 4 : 3, false))
2191 if (errmsg
->ts
.kind
!= 1)
2193 gfc_error ("The errmsg= argument at %L must be a default-kind "
2194 "character variable", &errmsg
->where
);
2199 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2201 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
2211 gfc_check_co_broadcast (gfc_expr
*a
, gfc_expr
*source_image
, gfc_expr
*stat
,
2214 if (a
->ts
.type
== BT_CLASS
|| gfc_expr_attr (a
).alloc_comp
)
2216 gfc_error ("Support for the A argument at %L which is polymorphic A "
2217 "argument or has allocatable components is not yet "
2218 "implemented", &a
->where
);
2221 return check_co_collective (a
, source_image
, stat
, errmsg
, false);
2226 gfc_check_co_reduce (gfc_expr
*a
, gfc_expr
*op
, gfc_expr
*result_image
,
2227 gfc_expr
*stat
, gfc_expr
*errmsg
)
2229 symbol_attribute attr
;
2230 gfc_formal_arglist
*formal
;
2233 if (a
->ts
.type
== BT_CLASS
)
2235 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
2240 if (gfc_expr_attr (a
).alloc_comp
)
2242 gfc_error ("Support for the A argument at %L with allocatable components"
2243 " is not yet implemented", &a
->where
);
2247 if (!check_co_collective (a
, result_image
, stat
, errmsg
, true))
2250 if (!gfc_resolve_expr (op
))
2253 attr
= gfc_expr_attr (op
);
2254 if (!attr
.pure
|| !attr
.function
)
2256 gfc_error ("OPERATOR argument at %L must be a PURE function",
2263 /* None of the intrinsics fulfills the criteria of taking two arguments,
2264 returning the same type and kind as the arguments and being permitted
2265 as actual argument. */
2266 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
2267 op
->symtree
->n
.sym
->name
, &op
->where
);
2271 if (gfc_is_proc_ptr_comp (op
))
2273 gfc_component
*comp
= gfc_get_proc_ptr_comp (op
);
2274 sym
= comp
->ts
.interface
;
2277 sym
= op
->symtree
->n
.sym
;
2279 formal
= sym
->formal
;
2281 if (!formal
|| !formal
->next
|| formal
->next
->next
)
2283 gfc_error ("The function passed as OPERATOR at %L shall have two "
2284 "arguments", &op
->where
);
2288 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
2289 gfc_set_default_type (sym
->result
, 0, NULL
);
2291 if (!gfc_compare_types (&a
->ts
, &sym
->result
->ts
))
2293 gfc_error ("The A argument at %L has type %s but the function passed as "
2294 "OPERATOR at %L returns %s",
2295 &a
->where
, gfc_typename (a
), &op
->where
,
2296 gfc_typename (&sym
->result
->ts
));
2299 if (!gfc_compare_types (&a
->ts
, &formal
->sym
->ts
)
2300 || !gfc_compare_types (&a
->ts
, &formal
->next
->sym
->ts
))
2302 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
2303 "%s and %s but shall have type %s", &op
->where
,
2304 gfc_typename (&formal
->sym
->ts
),
2305 gfc_typename (&formal
->next
->sym
->ts
), gfc_typename (a
));
2308 if (op
->rank
|| attr
.allocatable
|| attr
.pointer
|| formal
->sym
->as
2309 || formal
->next
->sym
->as
|| formal
->sym
->attr
.allocatable
2310 || formal
->next
->sym
->attr
.allocatable
|| formal
->sym
->attr
.pointer
2311 || formal
->next
->sym
->attr
.pointer
)
2313 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
2314 "nonallocatable nonpointer arguments and return a "
2315 "nonallocatable nonpointer scalar", &op
->where
);
2319 if (formal
->sym
->attr
.value
!= formal
->next
->sym
->attr
.value
)
2321 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
2322 "attribute either for none or both arguments", &op
->where
);
2326 if (formal
->sym
->attr
.target
!= formal
->next
->sym
->attr
.target
)
2328 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
2329 "attribute either for none or both arguments", &op
->where
);
2333 if (formal
->sym
->attr
.asynchronous
!= formal
->next
->sym
->attr
.asynchronous
)
2335 gfc_error ("The function passed as OPERATOR at %L shall have the "
2336 "ASYNCHRONOUS attribute either for none or both arguments",
2341 if (formal
->sym
->attr
.optional
|| formal
->next
->sym
->attr
.optional
)
2343 gfc_error ("The function passed as OPERATOR at %L shall not have the "
2344 "OPTIONAL attribute for either of the arguments", &op
->where
);
2348 if (a
->ts
.type
== BT_CHARACTER
)
2351 unsigned long actual_size
, formal_size1
, formal_size2
, result_size
;
2354 actual_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2355 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2357 cl
= formal
->sym
->ts
.u
.cl
;
2358 formal_size1
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2359 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2361 cl
= formal
->next
->sym
->ts
.u
.cl
;
2362 formal_size2
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2363 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2366 result_size
= cl
&& cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
2367 ? mpz_get_ui (cl
->length
->value
.integer
) : 0;
2370 && ((formal_size1
&& actual_size
!= formal_size1
)
2371 || (formal_size2
&& actual_size
!= formal_size2
)))
2373 gfc_error ("The character length of the A argument at %L and of the "
2374 "arguments of the OPERATOR at %L shall be the same",
2375 &a
->where
, &op
->where
);
2378 if (actual_size
&& result_size
&& actual_size
!= result_size
)
2380 gfc_error ("The character length of the A argument at %L and of the "
2381 "function result of the OPERATOR at %L shall be the same",
2382 &a
->where
, &op
->where
);
2392 gfc_check_co_minmax (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2395 if (a
->ts
.type
!= BT_INTEGER
&& a
->ts
.type
!= BT_REAL
2396 && a
->ts
.type
!= BT_CHARACTER
)
2398 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
2399 "integer, real or character",
2400 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2404 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2409 gfc_check_co_sum (gfc_expr
*a
, gfc_expr
*result_image
, gfc_expr
*stat
,
2412 if (!numeric_check (a
, 0))
2414 return check_co_collective (a
, result_image
, stat
, errmsg
, false);
2419 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
2421 if (!boz_args_check (x
, y
))
2424 if (x
->ts
.type
== BT_BOZ
)
2426 if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
2427 "intrinsic subprogram", &x
->where
))
2432 if (y
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (x
, y
->ts
.kind
))
2434 if (y
->ts
.type
== BT_REAL
&& !gfc_boz2real (x
, y
->ts
.kind
))
2438 if (y
->ts
.type
== BT_BOZ
)
2440 if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
2441 "intrinsic subprogram", &y
->where
))
2446 if (x
->ts
.type
== BT_INTEGER
&& !gfc_boz2int (y
, x
->ts
.kind
))
2448 if (x
->ts
.type
== BT_REAL
&& !gfc_boz2real (y
, x
->ts
.kind
))
2452 if (!int_or_real_check (x
, 0))
2454 if (!scalar_check (x
, 0))
2457 if (!int_or_real_check (y
, 1))
2459 if (!scalar_check (y
, 1))
2467 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
2469 if (!logical_array_check (mask
, 0))
2471 if (!dim_check (dim
, 1, false))
2473 if (!dim_rank_check (dim
, mask
, 0))
2475 if (!kind_check (kind
, 2, BT_INTEGER
))
2477 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
2478 "with KIND argument at %L",
2479 gfc_current_intrinsic
, &kind
->where
))
2487 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2489 if (!array_check (array
, 0))
2492 if (!type_check (shift
, 1, BT_INTEGER
))
2495 if (!dim_check (dim
, 2, true))
2498 if (!dim_rank_check (dim
, array
, false))
2501 if (array
->rank
== 1 || shift
->rank
== 0)
2503 if (!scalar_check (shift
, 1))
2506 else if (shift
->rank
== array
->rank
- 1)
2511 else if (dim
->expr_type
== EXPR_CONSTANT
)
2512 gfc_extract_int (dim
, &d
);
2519 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2522 if (!identical_dimen_shape (array
, i
, shift
, j
))
2524 gfc_error ("%qs argument of %qs intrinsic at %L has "
2525 "invalid shape in dimension %d (%ld/%ld)",
2526 gfc_current_intrinsic_arg
[1]->name
,
2527 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2528 mpz_get_si (array
->shape
[i
]),
2529 mpz_get_si (shift
->shape
[j
]));
2539 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2540 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2541 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2550 gfc_check_ctime (gfc_expr
*time
)
2552 if (!scalar_check (time
, 0))
2555 if (!type_check (time
, 0, BT_INTEGER
))
2562 bool gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
2564 if (!double_check (y
, 0) || !double_check (x
, 1))
2571 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2573 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2576 if (!numeric_check (x
, 0))
2581 if (y
->ts
.type
== BT_BOZ
&& !gfc_boz2real (y
, gfc_default_double_kind
))
2584 if (!numeric_check (y
, 1))
2587 if (x
->ts
.type
== BT_COMPLEX
)
2589 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2590 "present if %<x%> is COMPLEX",
2591 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2596 if (y
->ts
.type
== BT_COMPLEX
)
2598 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2599 "of either REAL or INTEGER",
2600 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2611 gfc_check_dble (gfc_expr
*x
)
2613 if (x
->ts
.type
== BT_BOZ
&& !gfc_boz2real (x
, gfc_default_double_kind
))
2616 if (!numeric_check (x
, 0))
2624 gfc_check_digits (gfc_expr
*x
)
2626 if (!int_or_real_check (x
, 0))
2634 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2636 switch (vector_a
->ts
.type
)
2639 if (!type_check (vector_b
, 1, BT_LOGICAL
))
2646 if (!numeric_check (vector_b
, 1))
2651 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2652 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2653 gfc_current_intrinsic
, &vector_a
->where
);
2657 if (!rank_check (vector_a
, 0, 1))
2660 if (!rank_check (vector_b
, 1, 1))
2663 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
2665 gfc_error ("Different shape for arguments %qs and %qs at %L for "
2666 "intrinsic %<dot_product%>",
2667 gfc_current_intrinsic_arg
[0]->name
,
2668 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
2677 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
2679 if (!type_check (x
, 0, BT_REAL
)
2680 || !type_check (y
, 1, BT_REAL
))
2683 if (x
->ts
.kind
!= gfc_default_real_kind
)
2685 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2686 "real", gfc_current_intrinsic_arg
[0]->name
,
2687 gfc_current_intrinsic
, &x
->where
);
2691 if (y
->ts
.kind
!= gfc_default_real_kind
)
2693 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2694 "real", gfc_current_intrinsic_arg
[1]->name
,
2695 gfc_current_intrinsic
, &y
->where
);
2703 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
2705 /* i and j cannot both be BOZ literal constants. */
2706 if (!boz_args_check (i
, j
))
2709 /* If i is BOZ and j is integer, convert i to type of j. If j is not
2710 an integer, clear the BOZ; otherwise, check that i is an integer. */
2711 if (i
->ts
.type
== BT_BOZ
)
2713 if (j
->ts
.type
!= BT_INTEGER
)
2715 else if (!gfc_boz2int (i
, j
->ts
.kind
))
2718 else if (!type_check (i
, 0, BT_INTEGER
))
2720 if (j
->ts
.type
== BT_BOZ
)
2725 /* If j is BOZ and i is integer, convert j to type of i. If i is not
2726 an integer, clear the BOZ; otherwise, check that i is an integer. */
2727 if (j
->ts
.type
== BT_BOZ
)
2729 if (i
->ts
.type
!= BT_INTEGER
)
2731 else if (!gfc_boz2int (j
, i
->ts
.kind
))
2734 else if (!type_check (j
, 1, BT_INTEGER
))
2737 if (!same_type_check (i
, 0, j
, 1))
2740 if (!type_check (shift
, 2, BT_INTEGER
))
2743 if (!nonnegative_check ("SHIFT", shift
))
2746 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
2754 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2759 if (!array_check (array
, 0))
2762 if (!type_check (shift
, 1, BT_INTEGER
))
2765 if (!dim_check (dim
, 3, true))
2768 if (!dim_rank_check (dim
, array
, false))
2773 else if (dim
->expr_type
== EXPR_CONSTANT
)
2774 gfc_extract_int (dim
, &d
);
2778 if (array
->rank
== 1 || shift
->rank
== 0)
2780 if (!scalar_check (shift
, 1))
2783 else if (shift
->rank
== array
->rank
- 1)
2788 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2791 if (!identical_dimen_shape (array
, i
, shift
, j
))
2793 gfc_error ("%qs argument of %qs intrinsic at %L has "
2794 "invalid shape in dimension %d (%ld/%ld)",
2795 gfc_current_intrinsic_arg
[1]->name
,
2796 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
2797 mpz_get_si (array
->shape
[i
]),
2798 mpz_get_si (shift
->shape
[j
]));
2808 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2809 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
2810 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
2814 if (boundary
!= NULL
)
2816 if (!same_type_check (array
, 0, boundary
, 2))
2819 /* Reject unequal string lengths and emit a better error message than
2820 gfc_check_same_strlen would. */
2821 if (array
->ts
.type
== BT_CHARACTER
)
2823 ssize_t len_a
, len_b
;
2825 len_a
= gfc_var_strlen (array
);
2826 len_b
= gfc_var_strlen (boundary
);
2827 if (len_a
!= -1 && len_b
!= -1 && len_a
!= len_b
)
2829 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2830 gfc_current_intrinsic_arg
[2]->name
,
2831 gfc_current_intrinsic_arg
[0]->name
,
2832 &boundary
->where
, gfc_current_intrinsic
);
2837 if (array
->rank
== 1 || boundary
->rank
== 0)
2839 if (!scalar_check (boundary
, 2))
2842 else if (boundary
->rank
== array
->rank
- 1)
2847 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
2851 if (!identical_dimen_shape (array
, i
, boundary
, j
))
2853 gfc_error ("%qs argument of %qs intrinsic at %L has "
2854 "invalid shape in dimension %d (%ld/%ld)",
2855 gfc_current_intrinsic_arg
[2]->name
,
2856 gfc_current_intrinsic
, &shift
->where
, i
+1,
2857 mpz_get_si (array
->shape
[i
]),
2858 mpz_get_si (boundary
->shape
[j
]));
2868 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2869 "rank %d or be a scalar",
2870 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2871 &shift
->where
, array
->rank
- 1);
2877 switch (array
->ts
.type
)
2887 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2888 "of type %qs", gfc_current_intrinsic_arg
[2]->name
,
2889 gfc_current_intrinsic
, &array
->where
,
2890 gfc_current_intrinsic_arg
[0]->name
,
2891 gfc_typename (array
));
2901 gfc_check_float (gfc_expr
*a
)
2903 if (a
->ts
.type
== BT_BOZ
)
2905 if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in the "
2906 "FLOAT intrinsic subprogram", &a
->where
))
2911 if (!gfc_boz2int (a
, gfc_default_integer_kind
))
2915 if (!type_check (a
, 0, BT_INTEGER
))
2918 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
2919 && !gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
2920 "kind argument to %s intrinsic at %L",
2921 gfc_current_intrinsic
, &a
->where
))
2927 /* A single complex argument. */
2930 gfc_check_fn_c (gfc_expr
*a
)
2932 if (!type_check (a
, 0, BT_COMPLEX
))
2939 /* A single real argument. */
2942 gfc_check_fn_r (gfc_expr
*a
)
2944 if (!type_check (a
, 0, BT_REAL
))
2950 /* A single double argument. */
2953 gfc_check_fn_d (gfc_expr
*a
)
2955 if (!double_check (a
, 0))
2961 /* A single real or complex argument. */
2964 gfc_check_fn_rc (gfc_expr
*a
)
2966 if (!real_or_complex_check (a
, 0))
2974 gfc_check_fn_rc2008 (gfc_expr
*a
)
2976 if (!real_or_complex_check (a
, 0))
2979 if (a
->ts
.type
== BT_COMPLEX
2980 && !gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument %qs "
2981 "of %qs intrinsic at %L",
2982 gfc_current_intrinsic_arg
[0]->name
,
2983 gfc_current_intrinsic
, &a
->where
))
2991 gfc_check_fnum (gfc_expr
*unit
)
2993 if (!type_check (unit
, 0, BT_INTEGER
))
2996 if (!scalar_check (unit
, 0))
3004 gfc_check_huge (gfc_expr
*x
)
3006 if (!int_or_real_check (x
, 0))
3014 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
3016 if (!type_check (x
, 0, BT_REAL
))
3018 if (!same_type_check (x
, 0, y
, 1))
3025 /* Check that the single argument is an integer. */
3028 gfc_check_i (gfc_expr
*i
)
3030 if (!type_check (i
, 0, BT_INTEGER
))
3038 gfc_check_iand_ieor_ior (gfc_expr
*i
, gfc_expr
*j
)
3040 /* i and j cannot both be BOZ literal constants. */
3041 if (!boz_args_check (i
, j
))
3044 /* If i is BOZ and j is integer, convert i to type of j. */
3045 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
3046 && !gfc_boz2int (i
, j
->ts
.kind
))
3049 /* If j is BOZ and i is integer, convert j to type of i. */
3050 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
3051 && !gfc_boz2int (j
, i
->ts
.kind
))
3054 if (!type_check (i
, 0, BT_INTEGER
))
3057 if (!type_check (j
, 1, BT_INTEGER
))
3060 if (i
->ts
.kind
!= j
->ts
.kind
)
3062 gfc_error ("Arguments of %qs have different kind type parameters "
3063 "at %L", gfc_current_intrinsic
, &i
->where
);
3072 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
3074 if (!type_check (i
, 0, BT_INTEGER
))
3077 if (!type_check (pos
, 1, BT_INTEGER
))
3080 if (!type_check (len
, 2, BT_INTEGER
))
3083 if (!nonnegative_check ("pos", pos
))
3086 if (!nonnegative_check ("len", len
))
3089 if (!less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
))
3097 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
3101 if (!type_check (c
, 0, BT_CHARACTER
))
3104 if (!kind_check (kind
, 1, BT_INTEGER
))
3107 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3108 "with KIND argument at %L",
3109 gfc_current_intrinsic
, &kind
->where
))
3112 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
3118 /* Substring references don't have the charlength set. */
3120 while (ref
&& ref
->type
!= REF_SUBSTRING
)
3123 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3127 /* Check that the argument is length one. Non-constant lengths
3128 can't be checked here, so assume they are ok. */
3129 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
3131 /* If we already have a length for this expression then use it. */
3132 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3134 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
3141 start
= ref
->u
.ss
.start
;
3142 end
= ref
->u
.ss
.end
;
3145 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3146 || start
->expr_type
!= EXPR_CONSTANT
)
3149 i
= mpz_get_si (end
->value
.integer
) + 1
3150 - mpz_get_si (start
->value
.integer
);
3158 gfc_error ("Argument of %s at %L must be of length one",
3159 gfc_current_intrinsic
, &c
->where
);
3168 gfc_check_idnint (gfc_expr
*a
)
3170 if (!double_check (a
, 0))
3178 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
3181 if (!type_check (string
, 0, BT_CHARACTER
)
3182 || !type_check (substring
, 1, BT_CHARACTER
))
3185 if (back
!= NULL
&& !type_check (back
, 2, BT_LOGICAL
))
3188 if (!kind_check (kind
, 3, BT_INTEGER
))
3190 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3191 "with KIND argument at %L",
3192 gfc_current_intrinsic
, &kind
->where
))
3195 if (string
->ts
.kind
!= substring
->ts
.kind
)
3197 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
3198 "kind as %qs", gfc_current_intrinsic_arg
[1]->name
,
3199 gfc_current_intrinsic
, &substring
->where
,
3200 gfc_current_intrinsic_arg
[0]->name
);
3209 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
3211 /* BOZ is dealt within simplify_int*. */
3212 if (x
->ts
.type
== BT_BOZ
)
3215 if (!numeric_check (x
, 0))
3218 if (!kind_check (kind
, 1, BT_INTEGER
))
3226 gfc_check_intconv (gfc_expr
*x
)
3228 if (strcmp (gfc_current_intrinsic
, "short") == 0
3229 || strcmp (gfc_current_intrinsic
, "long") == 0)
3231 gfc_error ("%qs intrinsic subprogram at %L has been deprecated. "
3232 "Use INT intrinsic subprogram.", gfc_current_intrinsic
,
3237 /* BOZ is dealt within simplify_int*. */
3238 if (x
->ts
.type
== BT_BOZ
)
3241 if (!numeric_check (x
, 0))
3248 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
3250 if (!type_check (i
, 0, BT_INTEGER
)
3251 || !type_check (shift
, 1, BT_INTEGER
))
3254 if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3262 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
3264 if (!type_check (i
, 0, BT_INTEGER
)
3265 || !type_check (shift
, 1, BT_INTEGER
))
3272 if (!type_check (size
, 2, BT_INTEGER
))
3275 if (!less_than_bitsize1 ("I", i
, "SIZE", size
, true))
3278 if (size
->expr_type
== EXPR_CONSTANT
)
3280 gfc_extract_int (size
, &i3
);
3283 gfc_error ("SIZE at %L must be positive", &size
->where
);
3287 if (shift
->expr_type
== EXPR_CONSTANT
)
3289 gfc_extract_int (shift
, &i2
);
3295 gfc_error ("The absolute value of SHIFT at %L must be less "
3296 "than or equal to SIZE at %L", &shift
->where
,
3303 else if (!less_than_bitsize1 ("I", i
, NULL
, shift
, true))
3311 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
3313 if (!type_check (pid
, 0, BT_INTEGER
))
3316 if (!scalar_check (pid
, 0))
3319 if (!type_check (sig
, 1, BT_INTEGER
))
3322 if (!scalar_check (sig
, 1))
3330 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
3332 if (!type_check (pid
, 0, BT_INTEGER
))
3335 if (!scalar_check (pid
, 0))
3338 if (!type_check (sig
, 1, BT_INTEGER
))
3341 if (!scalar_check (sig
, 1))
3346 if (!type_check (status
, 2, BT_INTEGER
))
3349 if (!scalar_check (status
, 2))
3352 if (status
->expr_type
!= EXPR_VARIABLE
)
3354 gfc_error ("STATUS at %L shall be an INTENT(OUT) variable",
3359 if (status
->expr_type
== EXPR_VARIABLE
3360 && status
->symtree
&& status
->symtree
->n
.sym
3361 && status
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3363 gfc_error ("%qs at %L shall be an INTENT(OUT) variable",
3364 status
->symtree
->name
, &status
->where
);
3374 gfc_check_kind (gfc_expr
*x
)
3376 if (gfc_bt_struct (x
->ts
.type
) || x
->ts
.type
== BT_CLASS
)
3378 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3379 "intrinsic type", gfc_current_intrinsic_arg
[0]->name
,
3380 gfc_current_intrinsic
, &x
->where
);
3383 if (x
->ts
.type
== BT_PROCEDURE
)
3385 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
3386 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3396 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3398 if (!array_check (array
, 0))
3401 if (!dim_check (dim
, 1, false))
3404 if (!dim_rank_check (dim
, array
, 1))
3407 if (!kind_check (kind
, 2, BT_INTEGER
))
3409 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3410 "with KIND argument at %L",
3411 gfc_current_intrinsic
, &kind
->where
))
3419 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
3421 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3423 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3427 if (!coarray_check (coarray
, 0))
3432 if (!dim_check (dim
, 1, false))
3435 if (!dim_corank_check (dim
, coarray
))
3439 if (!kind_check (kind
, 2, BT_INTEGER
))
3447 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
3449 if (!type_check (s
, 0, BT_CHARACTER
))
3452 if (!kind_check (kind
, 1, BT_INTEGER
))
3454 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3455 "with KIND argument at %L",
3456 gfc_current_intrinsic
, &kind
->where
))
3464 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
3466 if (!type_check (a
, 0, BT_CHARACTER
))
3468 if (!kind_value_check (a
, 0, gfc_default_character_kind
))
3471 if (!type_check (b
, 1, BT_CHARACTER
))
3473 if (!kind_value_check (b
, 1, gfc_default_character_kind
))
3481 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
3483 if (!type_check (path1
, 0, BT_CHARACTER
))
3485 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3488 if (!type_check (path2
, 1, BT_CHARACTER
))
3490 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3498 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3500 if (!type_check (path1
, 0, BT_CHARACTER
))
3502 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3505 if (!type_check (path2
, 1, BT_CHARACTER
))
3507 if (!kind_value_check (path2
, 0, gfc_default_character_kind
))
3513 if (!type_check (status
, 2, BT_INTEGER
))
3516 if (!scalar_check (status
, 2))
3524 gfc_check_loc (gfc_expr
*expr
)
3526 return variable_check (expr
, 0, true);
3531 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
3533 if (!type_check (path1
, 0, BT_CHARACTER
))
3535 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3538 if (!type_check (path2
, 1, BT_CHARACTER
))
3540 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3548 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3550 if (!type_check (path1
, 0, BT_CHARACTER
))
3552 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
3555 if (!type_check (path2
, 1, BT_CHARACTER
))
3557 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
3563 if (!type_check (status
, 2, BT_INTEGER
))
3566 if (!scalar_check (status
, 2))
3574 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
3576 if (!type_check (a
, 0, BT_LOGICAL
))
3578 if (!kind_check (kind
, 1, BT_LOGICAL
))
3585 /* Min/max family. */
3588 min_max_args (gfc_actual_arglist
*args
)
3590 gfc_actual_arglist
*arg
;
3591 int i
, j
, nargs
, *nlabels
, nlabelless
;
3592 bool a1
= false, a2
= false;
3594 if (args
== NULL
|| args
->next
== NULL
)
3596 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3597 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
3604 if (!args
->next
->name
)
3608 for (arg
= args
; arg
; arg
= arg
->next
)
3615 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3617 nlabels
= XALLOCAVEC (int, nargs
);
3618 for (arg
= args
, i
= 0; arg
; arg
= arg
->next
, i
++)
3624 if (arg
->name
[0] != 'a' || arg
->name
[1] < '1' || arg
->name
[1] > '9')
3626 n
= strtol (&arg
->name
[1], &endp
, 10);
3627 if (endp
[0] != '\0')
3631 if (n
<= nlabelless
)
3644 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3645 !a1
? "a1" : "a2", gfc_current_intrinsic
,
3646 gfc_current_intrinsic_where
);
3650 /* Check for duplicates. */
3651 for (i
= 0; i
< nargs
; i
++)
3652 for (j
= i
+ 1; j
< nargs
; j
++)
3653 if (nlabels
[i
] == nlabels
[j
])
3659 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg
->name
,
3660 &arg
->expr
->where
, gfc_current_intrinsic
);
3664 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg
->name
,
3665 &arg
->expr
->where
, gfc_current_intrinsic
);
3671 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
3673 gfc_actual_arglist
*arg
, *tmp
;
3677 if (!min_max_args (arglist
))
3680 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
3683 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
3685 if (x
->ts
.type
== type
)
3687 if (!gfc_notify_std (GFC_STD_GNU
, "Different type "
3688 "kinds at %L", &x
->where
))
3693 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3694 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
3695 gfc_basic_typename (type
), kind
);
3700 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
3701 if (!gfc_check_conformance (tmp
->expr
, x
,
3702 "arguments 'a%d' and 'a%d' for "
3703 "intrinsic '%s'", m
, n
,
3704 gfc_current_intrinsic
))
3713 gfc_check_min_max (gfc_actual_arglist
*arg
)
3717 if (!min_max_args (arg
))
3722 if (x
->ts
.type
== BT_CHARACTER
)
3724 if (!gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
3725 "with CHARACTER argument at %L",
3726 gfc_current_intrinsic
, &x
->where
))
3729 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
3731 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3732 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
3736 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
3741 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
3743 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
3748 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
3750 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
3755 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
3757 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
3761 /* End of min/max family. */
3764 gfc_check_malloc (gfc_expr
*size
)
3766 if (!type_check (size
, 0, BT_INTEGER
))
3769 if (!scalar_check (size
, 0))
3777 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3779 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
3781 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3782 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
3783 gfc_current_intrinsic
, &matrix_a
->where
);
3787 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
3789 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3790 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
3791 gfc_current_intrinsic
, &matrix_b
->where
);
3795 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
3796 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
3798 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3799 gfc_current_intrinsic
, &matrix_a
->where
,
3800 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
3804 switch (matrix_a
->rank
)
3807 if (!rank_check (matrix_b
, 1, 2))
3809 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3810 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
3812 gfc_error ("Different shape on dimension 1 for arguments %qs "
3813 "and %qs at %L for intrinsic matmul",
3814 gfc_current_intrinsic_arg
[0]->name
,
3815 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3821 if (matrix_b
->rank
!= 2)
3823 if (!rank_check (matrix_b
, 1, 1))
3826 /* matrix_b has rank 1 or 2 here. Common check for the cases
3827 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3828 - matrix_a has shape (n,m) and matrix_b has shape (m). */
3829 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
3831 gfc_error ("Different shape on dimension 2 for argument %qs and "
3832 "dimension 1 for argument %qs at %L for intrinsic "
3833 "matmul", gfc_current_intrinsic_arg
[0]->name
,
3834 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
3840 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3841 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
3842 gfc_current_intrinsic
, &matrix_a
->where
);
3850 /* Whoever came up with this interface was probably on something.
3851 The possibilities for the occupation of the second and third
3858 NULL MASK minloc(array, mask=m)
3861 I.e. in the case of minloc(array,mask), mask will be in the second
3862 position of the argument list and we'll have to fix that up. Also,
3863 add the BACK argument if that isn't present. */
3866 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
3868 gfc_expr
*a
, *m
, *d
, *k
, *b
;
3871 if (!int_or_real_or_char_check_f2003 (a
, 0) || !array_check (a
, 0))
3875 m
= ap
->next
->next
->expr
;
3876 k
= ap
->next
->next
->next
->expr
;
3877 b
= ap
->next
->next
->next
->next
->expr
;
3881 if (!type_check (b
, 4, BT_LOGICAL
) || !scalar_check (b
,4))
3886 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3887 ap
->next
->next
->next
->next
->expr
= b
;
3890 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3891 && ap
->next
->name
== NULL
)
3895 ap
->next
->expr
= NULL
;
3896 ap
->next
->next
->expr
= m
;
3899 if (!dim_check (d
, 1, false))
3902 if (!dim_rank_check (d
, a
, 0))
3905 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
3909 && !gfc_check_conformance (a
, m
,
3910 "arguments '%s' and '%s' for intrinsic %s",
3911 gfc_current_intrinsic_arg
[0]->name
,
3912 gfc_current_intrinsic_arg
[2]->name
,
3913 gfc_current_intrinsic
))
3916 if (!kind_check (k
, 1, BT_INTEGER
))
3922 /* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3923 above, with the additional "value" argument. */
3926 gfc_check_findloc (gfc_actual_arglist
*ap
)
3928 gfc_expr
*a
, *v
, *m
, *d
, *k
, *b
;
3932 if (!intrinsic_type_check (a
, 0) || !array_check (a
, 0))
3936 if (!intrinsic_type_check (v
, 1) || !scalar_check (v
,1))
3939 /* Check if the type are both logical. */
3940 a1
= a
->ts
.type
== BT_LOGICAL
;
3941 v1
= v
->ts
.type
== BT_LOGICAL
;
3942 if ((a1
&& !v1
) || (!a1
&& v1
))
3945 /* Check if the type are both character. */
3946 a1
= a
->ts
.type
== BT_CHARACTER
;
3947 v1
= v
->ts
.type
== BT_CHARACTER
;
3948 if ((a1
&& !v1
) || (!a1
&& v1
))
3951 /* Check the kind of the characters argument match. */
3952 if (a1
&& v1
&& a
->ts
.kind
!= v
->ts
.kind
)
3955 d
= ap
->next
->next
->expr
;
3956 m
= ap
->next
->next
->next
->expr
;
3957 k
= ap
->next
->next
->next
->next
->expr
;
3958 b
= ap
->next
->next
->next
->next
->next
->expr
;
3962 if (!type_check (b
, 5, BT_LOGICAL
) || !scalar_check (b
,4))
3967 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3968 ap
->next
->next
->next
->next
->next
->expr
= b
;
3971 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3972 && ap
->next
->name
== NULL
)
3976 ap
->next
->next
->expr
= NULL
;
3977 ap
->next
->next
->next
->expr
= m
;
3980 if (!dim_check (d
, 2, false))
3983 if (!dim_rank_check (d
, a
, 0))
3986 if (m
!= NULL
&& !type_check (m
, 3, BT_LOGICAL
))
3990 && !gfc_check_conformance (a
, m
,
3991 "arguments '%s' and '%s' for intrinsic %s",
3992 gfc_current_intrinsic_arg
[0]->name
,
3993 gfc_current_intrinsic_arg
[3]->name
,
3994 gfc_current_intrinsic
))
3997 if (!kind_check (k
, 1, BT_INTEGER
))
4003 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4004 "conformance to argument %qs at %L",
4005 gfc_current_intrinsic_arg
[0]->name
,
4006 gfc_current_intrinsic
, &a
->where
,
4007 gfc_current_intrinsic_arg
[1]->name
, &v
->where
);
4012 /* Similar to minloc/maxloc, the argument list might need to be
4013 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4014 difference is that MINLOC/MAXLOC take an additional KIND argument.
4015 The possibilities are:
4021 NULL MASK minval(array, mask=m)
4024 I.e. in the case of minval(array,mask), mask will be in the second
4025 position of the argument list and we'll have to fix that up. */
4028 check_reduction (gfc_actual_arglist
*ap
)
4030 gfc_expr
*a
, *m
, *d
;
4034 m
= ap
->next
->next
->expr
;
4036 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
4037 && ap
->next
->name
== NULL
)
4041 ap
->next
->expr
= NULL
;
4042 ap
->next
->next
->expr
= m
;
4045 if (!dim_check (d
, 1, false))
4048 if (!dim_rank_check (d
, a
, 0))
4051 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
4055 && !gfc_check_conformance (a
, m
,
4056 "arguments '%s' and '%s' for intrinsic %s",
4057 gfc_current_intrinsic_arg
[0]->name
,
4058 gfc_current_intrinsic_arg
[2]->name
,
4059 gfc_current_intrinsic
))
4067 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
4069 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
4070 || !array_check (ap
->expr
, 0))
4073 return check_reduction (ap
);
4078 gfc_check_product_sum (gfc_actual_arglist
*ap
)
4080 if (!numeric_check (ap
->expr
, 0)
4081 || !array_check (ap
->expr
, 0))
4084 return check_reduction (ap
);
4088 /* For IANY, IALL and IPARITY. */
4091 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
4095 if (!type_check (i
, 0, BT_INTEGER
))
4098 if (!nonnegative_check ("I", i
))
4101 if (!kind_check (kind
, 1, BT_INTEGER
))
4105 gfc_extract_int (kind
, &k
);
4107 k
= gfc_default_integer_kind
;
4109 if (!less_than_bitsizekind ("I", i
, k
))
4117 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
4119 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
4121 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4122 gfc_current_intrinsic_arg
[0]->name
,
4123 gfc_current_intrinsic
, &ap
->expr
->where
);
4127 if (!array_check (ap
->expr
, 0))
4130 return check_reduction (ap
);
4135 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4137 if (!same_type_check (tsource
, 0, fsource
, 1))
4140 if (!type_check (mask
, 2, BT_LOGICAL
))
4143 if (tsource
->ts
.type
== BT_CHARACTER
)
4144 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
4151 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
4153 /* i and j cannot both be BOZ literal constants. */
4154 if (!boz_args_check (i
, j
))
4157 /* If i is BOZ and j is integer, convert i to type of j. */
4158 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
4159 && !gfc_boz2int (i
, j
->ts
.kind
))
4162 /* If j is BOZ and i is integer, convert j to type of i. */
4163 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
4164 && !gfc_boz2int (j
, i
->ts
.kind
))
4167 if (!type_check (i
, 0, BT_INTEGER
))
4170 if (!type_check (j
, 1, BT_INTEGER
))
4173 if (!same_type_check (i
, 0, j
, 1))
4176 if (mask
->ts
.type
== BT_BOZ
&& !gfc_boz2int(mask
, i
->ts
.kind
))
4179 if (!type_check (mask
, 2, BT_INTEGER
))
4182 if (!same_type_check (i
, 0, mask
, 2))
4190 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
4192 if (!variable_check (from
, 0, false))
4194 if (!allocatable_check (from
, 0))
4196 if (gfc_is_coindexed (from
))
4198 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4199 "coindexed", &from
->where
);
4203 if (!variable_check (to
, 1, false))
4205 if (!allocatable_check (to
, 1))
4207 if (gfc_is_coindexed (to
))
4209 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4210 "coindexed", &to
->where
);
4214 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
4216 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4217 "polymorphic if FROM is polymorphic",
4222 if (!same_type_check (to
, 1, from
, 0))
4225 if (to
->rank
!= from
->rank
)
4227 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4228 "must have the same rank %d/%d", &to
->where
, from
->rank
,
4233 /* IR F08/0040; cf. 12-006A. */
4234 if (gfc_get_corank (to
) != gfc_get_corank (from
))
4236 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4237 "must have the same corank %d/%d", &to
->where
,
4238 gfc_get_corank (from
), gfc_get_corank (to
));
4242 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
4243 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4244 and cmp2 are allocatable. After the allocation is transferred,
4245 the 'to' chain is broken by the nullification of the 'from'. A bit
4246 of reflection reveals that this can only occur for derived types
4247 with recursive allocatable components. */
4248 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
4249 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
4251 gfc_ref
*to_ref
, *from_ref
;
4253 from_ref
= from
->ref
;
4254 bool aliasing
= true;
4256 for (; from_ref
&& to_ref
;
4257 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
4259 if (to_ref
->type
!= from
->ref
->type
)
4261 else if (to_ref
->type
== REF_ARRAY
4262 && to_ref
->u
.ar
.type
!= AR_FULL
4263 && from_ref
->u
.ar
.type
!= AR_FULL
)
4264 /* Play safe; assume sections and elements are different. */
4266 else if (to_ref
->type
== REF_COMPONENT
4267 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
4276 gfc_error ("The FROM and TO arguments at %L violate aliasing "
4277 "restrictions (F2003 12.4.1.7)", &to
->where
);
4282 /* CLASS arguments: Make sure the vtab of from is present. */
4283 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
4284 gfc_find_vtab (&from
->ts
);
4291 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
4293 if (!type_check (x
, 0, BT_REAL
))
4296 if (!type_check (s
, 1, BT_REAL
))
4299 if (s
->expr_type
== EXPR_CONSTANT
)
4301 if (mpfr_sgn (s
->value
.real
) == 0)
4303 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4314 gfc_check_new_line (gfc_expr
*a
)
4316 if (!type_check (a
, 0, BT_CHARACTER
))
4324 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
4326 if (!type_check (array
, 0, BT_REAL
))
4329 if (!array_check (array
, 0))
4332 if (!dim_rank_check (dim
, array
, false))
4339 gfc_check_null (gfc_expr
*mold
)
4341 symbol_attribute attr
;
4346 if (!variable_check (mold
, 0, true))
4349 attr
= gfc_variable_attr (mold
, NULL
);
4351 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
4353 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4354 "ALLOCATABLE or procedure pointer",
4355 gfc_current_intrinsic_arg
[0]->name
,
4356 gfc_current_intrinsic
, &mold
->where
);
4360 if (attr
.allocatable
4361 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
4362 "allocatable MOLD at %L", &mold
->where
))
4366 if (gfc_is_coindexed (mold
))
4368 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4369 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
4370 gfc_current_intrinsic
, &mold
->where
);
4379 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4381 if (!array_check (array
, 0))
4384 if (!type_check (mask
, 1, BT_LOGICAL
))
4387 if (!gfc_check_conformance (array
, mask
,
4388 "arguments '%s' and '%s' for intrinsic '%s'",
4389 gfc_current_intrinsic_arg
[0]->name
,
4390 gfc_current_intrinsic_arg
[1]->name
,
4391 gfc_current_intrinsic
))
4396 mpz_t array_size
, vector_size
;
4397 bool have_array_size
, have_vector_size
;
4399 if (!same_type_check (array
, 0, vector
, 2))
4402 if (!rank_check (vector
, 2, 1))
4405 /* VECTOR requires at least as many elements as MASK
4406 has .TRUE. values. */
4407 have_array_size
= gfc_array_size(array
, &array_size
);
4408 have_vector_size
= gfc_array_size(vector
, &vector_size
);
4410 if (have_vector_size
4411 && (mask
->expr_type
== EXPR_ARRAY
4412 || (mask
->expr_type
== EXPR_CONSTANT
4413 && have_array_size
)))
4415 int mask_true_values
= 0;
4417 if (mask
->expr_type
== EXPR_ARRAY
)
4419 gfc_constructor
*mask_ctor
;
4420 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4423 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4425 mask_true_values
= 0;
4429 if (mask_ctor
->expr
->value
.logical
)
4432 mask_ctor
= gfc_constructor_next (mask_ctor
);
4435 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
4436 mask_true_values
= mpz_get_si (array_size
);
4438 if (mpz_get_si (vector_size
) < mask_true_values
)
4440 gfc_error ("%qs argument of %qs intrinsic at %L must "
4441 "provide at least as many elements as there "
4442 "are .TRUE. values in %qs (%ld/%d)",
4443 gfc_current_intrinsic_arg
[2]->name
,
4444 gfc_current_intrinsic
, &vector
->where
,
4445 gfc_current_intrinsic_arg
[1]->name
,
4446 mpz_get_si (vector_size
), mask_true_values
);
4451 if (have_array_size
)
4452 mpz_clear (array_size
);
4453 if (have_vector_size
)
4454 mpz_clear (vector_size
);
4462 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
4464 if (!type_check (mask
, 0, BT_LOGICAL
))
4467 if (!array_check (mask
, 0))
4470 if (!dim_rank_check (dim
, mask
, false))
4478 gfc_check_precision (gfc_expr
*x
)
4480 if (!real_or_complex_check (x
, 0))
4488 gfc_check_present (gfc_expr
*a
)
4492 if (!variable_check (a
, 0, true))
4495 sym
= a
->symtree
->n
.sym
;
4496 if (!sym
->attr
.dummy
)
4498 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4499 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
4500 gfc_current_intrinsic
, &a
->where
);
4504 if (!sym
->attr
.optional
)
4506 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4507 "an OPTIONAL dummy variable",
4508 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4513 /* 13.14.82 PRESENT(A)
4515 Argument. A shall be the name of an optional dummy argument that is
4516 accessible in the subprogram in which the PRESENT function reference
4520 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
4521 && (a
->ref
->u
.ar
.type
== AR_FULL
4522 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
4523 && a
->ref
->u
.ar
.as
->rank
== 0))))
4525 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4526 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
4527 gfc_current_intrinsic
, &a
->where
, sym
->name
);
4536 gfc_check_radix (gfc_expr
*x
)
4538 if (!int_or_real_check (x
, 0))
4546 gfc_check_range (gfc_expr
*x
)
4548 if (!numeric_check (x
, 0))
4556 gfc_check_rank (gfc_expr
*a
)
4558 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4559 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4561 bool is_variable
= true;
4563 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4564 if (a
->expr_type
== EXPR_FUNCTION
)
4565 is_variable
= a
->value
.function
.esym
4566 ? a
->value
.function
.esym
->result
->attr
.pointer
4567 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
4569 if (a
->expr_type
== EXPR_OP
4570 || a
->expr_type
== EXPR_NULL
4571 || a
->expr_type
== EXPR_COMPCALL
4572 || a
->expr_type
== EXPR_PPC
4573 || a
->ts
.type
== BT_PROCEDURE
4576 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4577 "object", &a
->where
);
4586 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
4588 if (!kind_check (kind
, 1, BT_REAL
))
4591 /* BOZ is dealt with in gfc_simplify_real. */
4592 if (a
->ts
.type
== BT_BOZ
)
4595 if (!numeric_check (a
, 0))
4603 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
4605 if (!type_check (path1
, 0, BT_CHARACTER
))
4607 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4610 if (!type_check (path2
, 1, BT_CHARACTER
))
4612 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4620 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
4622 if (!type_check (path1
, 0, BT_CHARACTER
))
4624 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4627 if (!type_check (path2
, 1, BT_CHARACTER
))
4629 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4635 if (!type_check (status
, 2, BT_INTEGER
))
4638 if (!scalar_check (status
, 2))
4646 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
4648 if (!type_check (x
, 0, BT_CHARACTER
))
4651 if (!scalar_check (x
, 0))
4654 if (!type_check (y
, 0, BT_INTEGER
))
4657 if (!scalar_check (y
, 1))
4665 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
4666 gfc_expr
*pad
, gfc_expr
*order
)
4672 if (!array_check (source
, 0))
4675 if (!rank_check (shape
, 1, 1))
4678 if (!type_check (shape
, 1, BT_INTEGER
))
4681 if (!gfc_array_size (shape
, &size
))
4683 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4684 "array of constant size", &shape
->where
);
4688 shape_size
= mpz_get_ui (size
);
4691 if (shape_size
<= 0)
4693 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4694 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4698 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4700 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4701 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4704 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
4708 for (i
= 0; i
< shape_size
; ++i
)
4710 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4711 if (e
->expr_type
!= EXPR_CONSTANT
)
4714 gfc_extract_int (e
, &extent
);
4717 gfc_error ("%qs argument of %qs intrinsic at %L has "
4718 "negative element (%d)",
4719 gfc_current_intrinsic_arg
[1]->name
,
4720 gfc_current_intrinsic
, &e
->where
, extent
);
4725 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4726 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4727 && shape
->ref
->u
.ar
.as
4728 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4729 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4730 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4731 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4732 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4737 v
= shape
->symtree
->n
.sym
->value
;
4739 for (i
= 0; i
< shape_size
; i
++)
4741 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4745 gfc_extract_int (e
, &extent
);
4749 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4750 "cannot be negative", i
+ 1, &shape
->where
);
4758 if (!same_type_check (source
, 0, pad
, 2))
4761 if (!array_check (pad
, 2))
4767 if (!array_check (order
, 3))
4770 if (!type_check (order
, 3, BT_INTEGER
))
4773 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4775 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4778 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4781 gfc_array_size (order
, &size
);
4782 order_size
= mpz_get_ui (size
);
4785 if (order_size
!= shape_size
)
4787 gfc_error ("%qs argument of %qs intrinsic at %L "
4788 "has wrong number of elements (%d/%d)",
4789 gfc_current_intrinsic_arg
[3]->name
,
4790 gfc_current_intrinsic
, &order
->where
,
4791 order_size
, shape_size
);
4795 for (i
= 1; i
<= order_size
; ++i
)
4797 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4798 if (e
->expr_type
!= EXPR_CONSTANT
)
4801 gfc_extract_int (e
, &dim
);
4803 if (dim
< 1 || dim
> order_size
)
4805 gfc_error ("%qs argument of %qs intrinsic at %L "
4806 "has out-of-range dimension (%d)",
4807 gfc_current_intrinsic_arg
[3]->name
,
4808 gfc_current_intrinsic
, &e
->where
, dim
);
4812 if (perm
[dim
-1] != 0)
4814 gfc_error ("%qs argument of %qs intrinsic at %L has "
4815 "invalid permutation of dimensions (dimension "
4817 gfc_current_intrinsic_arg
[3]->name
,
4818 gfc_current_intrinsic
, &e
->where
, dim
);
4827 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4828 && gfc_is_constant_expr (shape
)
4829 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4830 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4832 /* Check the match in size between source and destination. */
4833 if (gfc_array_size (source
, &nelems
))
4839 mpz_init_set_ui (size
, 1);
4840 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4841 c
; c
= gfc_constructor_next (c
))
4842 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4844 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4850 gfc_error ("Without padding, there are not enough elements "
4851 "in the intrinsic RESHAPE source at %L to match "
4852 "the shape", &source
->where
);
4863 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4865 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4867 gfc_error ("%qs argument of %qs intrinsic at %L "
4868 "cannot be of type %s",
4869 gfc_current_intrinsic_arg
[0]->name
,
4870 gfc_current_intrinsic
,
4871 &a
->where
, gfc_typename (a
));
4875 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4877 gfc_error ("%qs argument of %qs intrinsic at %L "
4878 "must be of an extensible type",
4879 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4884 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4886 gfc_error ("%qs argument of %qs intrinsic at %L "
4887 "cannot be of type %s",
4888 gfc_current_intrinsic_arg
[0]->name
,
4889 gfc_current_intrinsic
,
4890 &b
->where
, gfc_typename (b
));
4894 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4896 gfc_error ("%qs argument of %qs intrinsic at %L "
4897 "must be of an extensible type",
4898 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4908 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4910 if (!type_check (x
, 0, BT_REAL
))
4913 if (!type_check (i
, 1, BT_INTEGER
))
4921 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4923 if (!type_check (x
, 0, BT_CHARACTER
))
4926 if (!type_check (y
, 1, BT_CHARACTER
))
4929 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4932 if (!kind_check (kind
, 3, BT_INTEGER
))
4934 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4935 "with KIND argument at %L",
4936 gfc_current_intrinsic
, &kind
->where
))
4939 if (!same_type_check (x
, 0, y
, 1))
4947 gfc_check_secnds (gfc_expr
*r
)
4949 if (!type_check (r
, 0, BT_REAL
))
4952 if (!kind_value_check (r
, 0, 4))
4955 if (!scalar_check (r
, 0))
4963 gfc_check_selected_char_kind (gfc_expr
*name
)
4965 if (!type_check (name
, 0, BT_CHARACTER
))
4968 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4971 if (!scalar_check (name
, 0))
4979 gfc_check_selected_int_kind (gfc_expr
*r
)
4981 if (!type_check (r
, 0, BT_INTEGER
))
4984 if (!scalar_check (r
, 0))
4992 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4994 if (p
== NULL
&& r
== NULL
4995 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4996 " neither %<P%> nor %<R%> argument at %L",
4997 gfc_current_intrinsic_where
))
5002 if (!type_check (p
, 0, BT_INTEGER
))
5005 if (!scalar_check (p
, 0))
5011 if (!type_check (r
, 1, BT_INTEGER
))
5014 if (!scalar_check (r
, 1))
5020 if (!type_check (radix
, 1, BT_INTEGER
))
5023 if (!scalar_check (radix
, 1))
5026 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
5027 "RADIX argument at %L", gfc_current_intrinsic
,
5037 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5039 if (!type_check (x
, 0, BT_REAL
))
5042 if (!type_check (i
, 1, BT_INTEGER
))
5050 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
5054 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
5057 ar
= gfc_find_array_ref (source
);
5059 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
5061 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5062 "an assumed size array", &source
->where
);
5066 if (!kind_check (kind
, 1, BT_INTEGER
))
5068 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5069 "with KIND argument at %L",
5070 gfc_current_intrinsic
, &kind
->where
))
5078 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
5080 if (!type_check (i
, 0, BT_INTEGER
))
5083 if (!type_check (shift
, 0, BT_INTEGER
))
5086 if (!nonnegative_check ("SHIFT", shift
))
5089 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
5097 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
5099 if (!int_or_real_check (a
, 0))
5102 if (!same_type_check (a
, 0, b
, 1))
5110 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5112 if (!array_check (array
, 0))
5115 if (!dim_check (dim
, 1, true))
5118 if (!dim_rank_check (dim
, array
, 0))
5121 if (!kind_check (kind
, 2, BT_INTEGER
))
5123 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5124 "with KIND argument at %L",
5125 gfc_current_intrinsic
, &kind
->where
))
5134 gfc_check_sizeof (gfc_expr
*arg
)
5136 if (arg
->ts
.type
== BT_PROCEDURE
)
5138 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5139 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5144 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5145 if (arg
->ts
.type
== BT_ASSUMED
5146 && (arg
->symtree
->n
.sym
->as
== NULL
5147 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
5148 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
5149 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
5151 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5152 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5157 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5158 && arg
->symtree
->n
.sym
->as
!= NULL
5159 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5160 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5162 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5163 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5164 gfc_current_intrinsic
, &arg
->where
);
5172 /* Check whether an expression is interoperable. When returning false,
5173 msg is set to a string telling why the expression is not interoperable,
5174 otherwise, it is set to NULL. The msg string can be used in diagnostics.
5175 If c_loc is true, character with len > 1 are allowed (cf. Fortran
5176 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5177 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5181 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
5185 if (expr
->ts
.type
== BT_CLASS
)
5187 *msg
= "Expression is polymorphic";
5191 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
5192 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
5194 *msg
= "Expression is a noninteroperable derived type";
5198 if (expr
->ts
.type
== BT_PROCEDURE
)
5200 *msg
= "Procedure unexpected as argument";
5204 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
5207 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
5208 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
5210 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
5214 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
5215 && expr
->ts
.kind
!= 1)
5217 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
5221 if (expr
->ts
.type
== BT_CHARACTER
) {
5222 if (expr
->ts
.deferred
)
5224 /* TS 29113 allows deferred-length strings as dummy arguments,
5225 but it is not an interoperable type. */
5226 *msg
= "Expression shall not be a deferred-length string";
5230 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
5231 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
5232 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5234 if (!c_loc
&& expr
->ts
.u
.cl
5235 && (!expr
->ts
.u
.cl
->length
5236 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5237 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5239 *msg
= "Type shall have a character length of 1";
5244 /* Note: The following checks are about interoperatable variables, Fortran
5245 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5246 is allowed, e.g. assumed-shape arrays with TS 29113. */
5248 if (gfc_is_coarray (expr
))
5250 *msg
= "Coarrays are not interoperable";
5254 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
5256 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
5257 if (ar
->type
!= AR_FULL
)
5259 *msg
= "Only whole-arrays are interoperable";
5262 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
5263 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
5265 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
5275 gfc_check_c_sizeof (gfc_expr
*arg
)
5279 if (!is_c_interoperable (arg
, &msg
, false, false))
5281 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5282 "interoperable data entity: %s",
5283 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5288 if (arg
->ts
.type
== BT_ASSUMED
)
5290 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5292 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5297 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5298 && arg
->symtree
->n
.sym
->as
!= NULL
5299 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5300 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5302 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5303 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5304 gfc_current_intrinsic
, &arg
->where
);
5313 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
5315 if (c_ptr_1
->ts
.type
!= BT_DERIVED
5316 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5317 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
5318 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
5320 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5321 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
5325 if (!scalar_check (c_ptr_1
, 0))
5329 && (c_ptr_2
->ts
.type
!= BT_DERIVED
5330 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5331 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
5332 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
5334 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5335 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
5336 gfc_typename (&c_ptr_1
->ts
),
5337 gfc_typename (&c_ptr_2
->ts
));
5341 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
5349 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
5351 symbol_attribute attr
;
5354 if (cptr
->ts
.type
!= BT_DERIVED
5355 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5356 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
5358 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5359 "type TYPE(C_PTR)", &cptr
->where
);
5363 if (!scalar_check (cptr
, 0))
5366 attr
= gfc_expr_attr (fptr
);
5370 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5375 if (fptr
->ts
.type
== BT_CLASS
)
5377 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5382 if (gfc_is_coindexed (fptr
))
5384 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5385 "coindexed", &fptr
->where
);
5389 if (fptr
->rank
== 0 && shape
)
5391 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5392 "FPTR", &fptr
->where
);
5395 else if (fptr
->rank
&& !shape
)
5397 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5398 "FPTR at %L", &fptr
->where
);
5402 if (shape
&& !rank_check (shape
, 2, 1))
5405 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
5411 if (gfc_array_size (shape
, &size
))
5413 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
5416 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5417 "size as the RANK of FPTR", &shape
->where
);
5424 if (fptr
->ts
.type
== BT_CLASS
)
5426 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
5430 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
5431 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable array FPTR "
5432 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
5439 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
5441 symbol_attribute attr
;
5443 if (cptr
->ts
.type
!= BT_DERIVED
5444 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5445 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
5447 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5448 "type TYPE(C_FUNPTR)", &cptr
->where
);
5452 if (!scalar_check (cptr
, 0))
5455 attr
= gfc_expr_attr (fptr
);
5457 if (!attr
.proc_pointer
)
5459 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5460 "pointer", &fptr
->where
);
5464 if (gfc_is_coindexed (fptr
))
5466 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5467 "coindexed", &fptr
->where
);
5471 if (!attr
.is_bind_c
)
5472 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5473 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
5480 gfc_check_c_funloc (gfc_expr
*x
)
5482 symbol_attribute attr
;
5484 if (gfc_is_coindexed (x
))
5486 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5487 "coindexed", &x
->where
);
5491 attr
= gfc_expr_attr (x
);
5493 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
5494 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
5495 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5496 if (x
->symtree
->n
.sym
== ns
->proc_name
)
5498 gfc_error ("Function result %qs at %L is invalid as X argument "
5499 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
5503 if (attr
.flavor
!= FL_PROCEDURE
)
5505 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5506 "or a procedure pointer", &x
->where
);
5510 if (!attr
.is_bind_c
)
5511 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5512 "at %L to C_FUNLOC", &x
->where
);
5518 gfc_check_c_loc (gfc_expr
*x
)
5520 symbol_attribute attr
;
5523 if (gfc_is_coindexed (x
))
5525 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
5529 if (x
->ts
.type
== BT_CLASS
)
5531 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5536 attr
= gfc_expr_attr (x
);
5539 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
5540 || attr
.flavor
== FL_PARAMETER
))
5542 gfc_error ("Argument X at %L to C_LOC shall have either "
5543 "the POINTER or the TARGET attribute", &x
->where
);
5547 if (x
->ts
.type
== BT_CHARACTER
5548 && gfc_var_strlen (x
) == 0)
5550 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5551 "string", &x
->where
);
5555 if (!is_c_interoperable (x
, &msg
, true, false))
5557 if (x
->ts
.type
== BT_CLASS
)
5559 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5565 && !gfc_notify_std (GFC_STD_F2018
,
5566 "Noninteroperable array at %L as"
5567 " argument to C_LOC: %s", &x
->where
, msg
))
5570 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
5572 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
5574 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
5575 && !attr
.allocatable
5576 && !gfc_notify_std (GFC_STD_F2008
,
5577 "Array of interoperable type at %L "
5578 "to C_LOC which is nonallocatable and neither "
5579 "assumed size nor explicit size", &x
->where
))
5581 else if (ar
->type
!= AR_FULL
5582 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
5583 "to C_LOC", &x
->where
))
5592 gfc_check_sleep_sub (gfc_expr
*seconds
)
5594 if (!type_check (seconds
, 0, BT_INTEGER
))
5597 if (!scalar_check (seconds
, 0))
5604 gfc_check_sngl (gfc_expr
*a
)
5606 if (!type_check (a
, 0, BT_REAL
))
5609 if ((a
->ts
.kind
!= gfc_default_double_kind
)
5610 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
5611 "REAL argument to %s intrinsic at %L",
5612 gfc_current_intrinsic
, &a
->where
))
5619 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
5621 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
5623 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5624 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
5625 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
5633 if (!dim_check (dim
, 1, false))
5636 /* dim_rank_check() does not apply here. */
5638 && dim
->expr_type
== EXPR_CONSTANT
5639 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
5640 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
5642 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5643 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
5644 gfc_current_intrinsic
, &dim
->where
);
5648 if (!type_check (ncopies
, 2, BT_INTEGER
))
5651 if (!scalar_check (ncopies
, 2))
5658 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5662 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
5664 if (!type_check (unit
, 0, BT_INTEGER
))
5667 if (!scalar_check (unit
, 0))
5670 if (!type_check (c
, 1, BT_CHARACTER
))
5672 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5678 if (!type_check (status
, 2, BT_INTEGER
)
5679 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5680 || !scalar_check (status
, 2))
5688 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5690 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5695 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5697 if (!type_check (c
, 0, BT_CHARACTER
))
5699 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5705 if (!type_check (status
, 1, BT_INTEGER
)
5706 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5707 || !scalar_check (status
, 1))
5715 gfc_check_fgetput (gfc_expr
*c
)
5717 return gfc_check_fgetput_sub (c
, NULL
);
5722 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5724 if (!type_check (unit
, 0, BT_INTEGER
))
5727 if (!scalar_check (unit
, 0))
5730 if (!type_check (offset
, 1, BT_INTEGER
))
5733 if (!scalar_check (offset
, 1))
5736 if (!type_check (whence
, 2, BT_INTEGER
))
5739 if (!scalar_check (whence
, 2))
5745 if (!type_check (status
, 3, BT_INTEGER
))
5748 if (!kind_value_check (status
, 3, 4))
5751 if (!scalar_check (status
, 3))
5760 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5762 if (!type_check (unit
, 0, BT_INTEGER
))
5765 if (!scalar_check (unit
, 0))
5768 if (!type_check (array
, 1, BT_INTEGER
)
5769 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5772 if (!array_check (array
, 1))
5780 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5782 if (!type_check (unit
, 0, BT_INTEGER
))
5785 if (!scalar_check (unit
, 0))
5788 if (!type_check (array
, 1, BT_INTEGER
)
5789 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5792 if (!array_check (array
, 1))
5798 if (!type_check (status
, 2, BT_INTEGER
)
5799 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5802 if (!scalar_check (status
, 2))
5810 gfc_check_ftell (gfc_expr
*unit
)
5812 if (!type_check (unit
, 0, BT_INTEGER
))
5815 if (!scalar_check (unit
, 0))
5823 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5825 if (!type_check (unit
, 0, BT_INTEGER
))
5828 if (!scalar_check (unit
, 0))
5831 if (!type_check (offset
, 1, BT_INTEGER
))
5834 if (!scalar_check (offset
, 1))
5842 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5844 if (!type_check (name
, 0, BT_CHARACTER
))
5846 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5849 if (!type_check (array
, 1, BT_INTEGER
)
5850 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5853 if (!array_check (array
, 1))
5861 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5863 if (!type_check (name
, 0, BT_CHARACTER
))
5865 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5868 if (!type_check (array
, 1, BT_INTEGER
)
5869 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5872 if (!array_check (array
, 1))
5878 if (!type_check (status
, 2, BT_INTEGER
)
5879 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5882 if (!scalar_check (status
, 2))
5890 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5894 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5896 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5900 if (!coarray_check (coarray
, 0))
5905 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5906 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5910 if (gfc_array_size (sub
, &nelems
))
5912 int corank
= gfc_get_corank (coarray
);
5914 if (mpz_cmp_ui (nelems
, corank
) != 0)
5916 gfc_error ("The number of array elements of the SUB argument to "
5917 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5918 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5930 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5932 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5934 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5940 if (!type_check (distance
, 0, BT_INTEGER
))
5943 if (!nonnegative_check ("DISTANCE", distance
))
5946 if (!scalar_check (distance
, 0))
5949 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
5950 "NUM_IMAGES at %L", &distance
->where
))
5956 if (!type_check (failed
, 1, BT_LOGICAL
))
5959 if (!scalar_check (failed
, 1))
5962 if (!gfc_notify_std (GFC_STD_F2018
, "FAILED= argument to "
5963 "NUM_IMAGES at %L", &failed
->where
))
5972 gfc_check_team_number (gfc_expr
*team
)
5974 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5976 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5982 if (team
->ts
.type
!= BT_DERIVED
5983 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
5984 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
5986 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
5987 "shall be of type TEAM_TYPE", &team
->where
);
5999 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
6001 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6003 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6007 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
6010 if (dim
!= NULL
&& coarray
== NULL
)
6012 gfc_error ("DIM argument without COARRAY argument not allowed for "
6013 "THIS_IMAGE intrinsic at %L", &dim
->where
);
6017 if (distance
&& (coarray
|| dim
))
6019 gfc_error ("The DISTANCE argument may not be specified together with the "
6020 "COARRAY or DIM argument in intrinsic at %L",
6025 /* Assume that we have "this_image (distance)". */
6026 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
6030 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6039 if (!type_check (distance
, 2, BT_INTEGER
))
6042 if (!nonnegative_check ("DISTANCE", distance
))
6045 if (!scalar_check (distance
, 2))
6048 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6049 "THIS_IMAGE at %L", &distance
->where
))
6055 if (!coarray_check (coarray
, 0))
6060 if (!dim_check (dim
, 1, false))
6063 if (!dim_corank_check (dim
, coarray
))
6070 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6071 by gfc_simplify_transfer. Return false if we cannot do so. */
6074 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
6075 size_t *source_size
, size_t *result_size
,
6076 size_t *result_length_p
)
6078 size_t result_elt_size
;
6080 if (source
->expr_type
== EXPR_FUNCTION
)
6083 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
6086 /* Calculate the size of the source. */
6087 if (!gfc_target_expr_size (source
, source_size
))
6090 /* Determine the size of the element. */
6091 if (!gfc_element_size (mold
, &result_elt_size
))
6094 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6095 * a scalar with the type and type parameters of MOLD shall not have a
6096 * storage size equal to zero.
6097 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6098 * If MOLD is an array and SIZE is absent, the result is an array and of
6099 * rank one. Its size is as small as possible such that its physical
6100 * representation is not shorter than that of SOURCE.
6101 * If SIZE is present, the result is an array of rank one and size SIZE.
6103 if (result_elt_size
== 0 && *source_size
> 0 && !size
6104 && mold
->expr_type
== EXPR_ARRAY
)
6106 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6107 "array and shall not have storage size 0 when %<SOURCE%> "
6108 "argument has size greater than 0", &mold
->where
);
6112 if (result_elt_size
== 0 && *source_size
== 0 && !size
)
6115 if (result_length_p
)
6116 *result_length_p
= 0;
6120 if ((result_elt_size
> 0 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6126 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6129 result_length
= *source_size
/ result_elt_size
;
6130 if (result_length
* result_elt_size
< *source_size
)
6134 *result_size
= result_length
* result_elt_size
;
6135 if (result_length_p
)
6136 *result_length_p
= result_length
;
6139 *result_size
= result_elt_size
;
6146 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6151 /* SOURCE shall be a scalar or array of any type. */
6152 if (source
->ts
.type
== BT_PROCEDURE
6153 && source
->symtree
->n
.sym
->attr
.subroutine
== 1)
6155 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6156 "must not be a %s", &source
->where
,
6157 gfc_basic_typename (source
->ts
.type
));
6161 if (source
->ts
.type
== BT_BOZ
&& illegal_boz_arg (source
))
6164 if (mold
->ts
.type
== BT_BOZ
&& illegal_boz_arg (mold
))
6167 /* MOLD shall be a scalar or array of any type. */
6168 if (mold
->ts
.type
== BT_PROCEDURE
6169 && mold
->symtree
->n
.sym
->attr
.subroutine
== 1)
6171 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6172 "must not be a %s", &mold
->where
,
6173 gfc_basic_typename (mold
->ts
.type
));
6177 if (mold
->ts
.type
== BT_HOLLERITH
)
6179 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6180 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
6184 /* SIZE (optional) shall be an integer scalar. The corresponding actual
6185 argument shall not be an optional dummy argument. */
6188 if (!type_check (size
, 2, BT_INTEGER
))
6190 if (size
->ts
.type
== BT_BOZ
)
6195 if (!scalar_check (size
, 2))
6198 if (!nonoptional_check (size
, 2))
6202 if (!warn_surprising
)
6205 /* If we can't calculate the sizes, we cannot check any more.
6206 Return true for that case. */
6208 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6209 &result_size
, NULL
))
6212 if (source_size
< result_size
)
6213 gfc_warning (OPT_Wsurprising
,
6214 "Intrinsic TRANSFER at %L has partly undefined result: "
6215 "source size %ld < result size %ld", &source
->where
,
6216 (long) source_size
, (long) result_size
);
6223 gfc_check_transpose (gfc_expr
*matrix
)
6225 if (!rank_check (matrix
, 0, 2))
6233 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6235 if (!array_check (array
, 0))
6238 if (!dim_check (dim
, 1, false))
6241 if (!dim_rank_check (dim
, array
, 0))
6244 if (!kind_check (kind
, 2, BT_INTEGER
))
6246 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6247 "with KIND argument at %L",
6248 gfc_current_intrinsic
, &kind
->where
))
6256 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
6258 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6260 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6264 if (!coarray_check (coarray
, 0))
6269 if (!dim_check (dim
, 1, false))
6272 if (!dim_corank_check (dim
, coarray
))
6276 if (!kind_check (kind
, 2, BT_INTEGER
))
6284 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6288 if (!rank_check (vector
, 0, 1))
6291 if (!array_check (mask
, 1))
6294 if (!type_check (mask
, 1, BT_LOGICAL
))
6297 if (!same_type_check (vector
, 0, field
, 2))
6300 if (mask
->expr_type
== EXPR_ARRAY
6301 && gfc_array_size (vector
, &vector_size
))
6303 int mask_true_count
= 0;
6304 gfc_constructor
*mask_ctor
;
6305 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6308 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
6310 mask_true_count
= 0;
6314 if (mask_ctor
->expr
->value
.logical
)
6317 mask_ctor
= gfc_constructor_next (mask_ctor
);
6320 if (mpz_get_si (vector_size
) < mask_true_count
)
6322 gfc_error ("%qs argument of %qs intrinsic at %L must "
6323 "provide at least as many elements as there "
6324 "are .TRUE. values in %qs (%ld/%d)",
6325 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6326 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
6327 mpz_get_si (vector_size
), mask_true_count
);
6331 mpz_clear (vector_size
);
6334 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
6336 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6337 "the same rank as %qs or be a scalar",
6338 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6339 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
6343 if (mask
->rank
== field
->rank
)
6346 for (i
= 0; i
< field
->rank
; i
++)
6347 if (! identical_dimen_shape (mask
, i
, field
, i
))
6349 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6350 "must have identical shape.",
6351 gfc_current_intrinsic_arg
[2]->name
,
6352 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6362 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
6364 if (!type_check (x
, 0, BT_CHARACTER
))
6367 if (!same_type_check (x
, 0, y
, 1))
6370 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
6373 if (!kind_check (kind
, 3, BT_INTEGER
))
6375 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6376 "with KIND argument at %L",
6377 gfc_current_intrinsic
, &kind
->where
))
6385 gfc_check_trim (gfc_expr
*x
)
6387 if (!type_check (x
, 0, BT_CHARACTER
))
6390 if (!scalar_check (x
, 0))
6398 gfc_check_ttynam (gfc_expr
*unit
)
6400 if (!scalar_check (unit
, 0))
6403 if (!type_check (unit
, 0, BT_INTEGER
))
6410 /************* Check functions for intrinsic subroutines *************/
6413 gfc_check_cpu_time (gfc_expr
*time
)
6415 if (!scalar_check (time
, 0))
6418 if (!type_check (time
, 0, BT_REAL
))
6421 if (!variable_check (time
, 0, false))
6429 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
6430 gfc_expr
*zone
, gfc_expr
*values
)
6434 if (!type_check (date
, 0, BT_CHARACTER
))
6436 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6438 if (!scalar_check (date
, 0))
6440 if (!variable_check (date
, 0, false))
6446 if (!type_check (time
, 1, BT_CHARACTER
))
6448 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
6450 if (!scalar_check (time
, 1))
6452 if (!variable_check (time
, 1, false))
6458 if (!type_check (zone
, 2, BT_CHARACTER
))
6460 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
6462 if (!scalar_check (zone
, 2))
6464 if (!variable_check (zone
, 2, false))
6470 if (!type_check (values
, 3, BT_INTEGER
))
6472 if (!array_check (values
, 3))
6474 if (!rank_check (values
, 3, 1))
6476 if (!variable_check (values
, 3, false))
6485 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
6486 gfc_expr
*to
, gfc_expr
*topos
)
6488 if (!type_check (from
, 0, BT_INTEGER
))
6491 if (!type_check (frompos
, 1, BT_INTEGER
))
6494 if (!type_check (len
, 2, BT_INTEGER
))
6497 if (!same_type_check (from
, 0, to
, 3))
6500 if (!variable_check (to
, 3, false))
6503 if (!type_check (topos
, 4, BT_INTEGER
))
6506 if (!nonnegative_check ("frompos", frompos
))
6509 if (!nonnegative_check ("topos", topos
))
6512 if (!nonnegative_check ("len", len
))
6515 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
6518 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
6525 /* Check the arguments for RANDOM_INIT. */
6528 gfc_check_random_init (gfc_expr
*repeatable
, gfc_expr
*image_distinct
)
6530 if (!type_check (repeatable
, 0, BT_LOGICAL
))
6533 if (!scalar_check (repeatable
, 0))
6536 if (!type_check (image_distinct
, 1, BT_LOGICAL
))
6539 if (!scalar_check (image_distinct
, 1))
6547 gfc_check_random_number (gfc_expr
*harvest
)
6549 if (!type_check (harvest
, 0, BT_REAL
))
6552 if (!variable_check (harvest
, 0, false))
6560 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
6562 unsigned int nargs
= 0, seed_size
;
6563 locus
*where
= NULL
;
6564 mpz_t put_size
, get_size
;
6566 /* Keep the number of bytes in sync with master_state in
6567 libgfortran/intrinsics/random.c. */
6568 seed_size
= 32 / gfc_default_integer_kind
;
6572 if (size
->expr_type
!= EXPR_VARIABLE
6573 || !size
->symtree
->n
.sym
->attr
.optional
)
6576 if (!scalar_check (size
, 0))
6579 if (!type_check (size
, 0, BT_INTEGER
))
6582 if (!variable_check (size
, 0, false))
6585 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
6591 if (put
->expr_type
!= EXPR_VARIABLE
6592 || !put
->symtree
->n
.sym
->attr
.optional
)
6595 where
= &put
->where
;
6598 if (!array_check (put
, 1))
6601 if (!rank_check (put
, 1, 1))
6604 if (!type_check (put
, 1, BT_INTEGER
))
6607 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
6610 if (gfc_array_size (put
, &put_size
)
6611 && mpz_get_ui (put_size
) < seed_size
)
6612 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6613 "too small (%i/%i)",
6614 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6615 where
, (int) mpz_get_ui (put_size
), seed_size
);
6620 if (get
->expr_type
!= EXPR_VARIABLE
6621 || !get
->symtree
->n
.sym
->attr
.optional
)
6624 where
= &get
->where
;
6627 if (!array_check (get
, 2))
6630 if (!rank_check (get
, 2, 1))
6633 if (!type_check (get
, 2, BT_INTEGER
))
6636 if (!variable_check (get
, 2, false))
6639 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
6642 if (gfc_array_size (get
, &get_size
)
6643 && mpz_get_ui (get_size
) < seed_size
)
6644 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6645 "too small (%i/%i)",
6646 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6647 where
, (int) mpz_get_ui (get_size
), seed_size
);
6650 /* RANDOM_SEED may not have more than one non-optional argument. */
6652 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
6658 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
6662 int num_percent
, nargs
;
6665 if (e
->expr_type
!= EXPR_CONSTANT
)
6668 len
= e
->value
.character
.length
;
6669 if (e
->value
.character
.string
[len
-1] != '\0')
6670 gfc_internal_error ("fe_runtime_error string must be null terminated");
6673 for (i
=0; i
<len
-1; i
++)
6674 if (e
->value
.character
.string
[i
] == '%')
6678 for (; a
; a
= a
->next
)
6681 if (nargs
-1 != num_percent
)
6682 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6683 nargs
, num_percent
++);
6689 gfc_check_second_sub (gfc_expr
*time
)
6691 if (!scalar_check (time
, 0))
6694 if (!type_check (time
, 0, BT_REAL
))
6697 if (!kind_value_check (time
, 0, 4))
6704 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6705 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6706 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6707 count_max are all optional arguments */
6710 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
6711 gfc_expr
*count_max
)
6715 if (!scalar_check (count
, 0))
6718 if (!type_check (count
, 0, BT_INTEGER
))
6721 if (count
->ts
.kind
!= gfc_default_integer_kind
6722 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
6723 "SYSTEM_CLOCK at %L has non-default kind",
6727 if (!variable_check (count
, 0, false))
6731 if (count_rate
!= NULL
)
6733 if (!scalar_check (count_rate
, 1))
6736 if (!variable_check (count_rate
, 1, false))
6739 if (count_rate
->ts
.type
== BT_REAL
)
6741 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
6742 "SYSTEM_CLOCK at %L", &count_rate
->where
))
6747 if (!type_check (count_rate
, 1, BT_INTEGER
))
6750 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6751 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6752 "SYSTEM_CLOCK at %L has non-default kind",
6753 &count_rate
->where
))
6759 if (count_max
!= NULL
)
6761 if (!scalar_check (count_max
, 2))
6764 if (!type_check (count_max
, 2, BT_INTEGER
))
6767 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6768 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6769 "SYSTEM_CLOCK at %L has non-default kind",
6773 if (!variable_check (count_max
, 2, false))
6782 gfc_check_irand (gfc_expr
*x
)
6787 if (!scalar_check (x
, 0))
6790 if (!type_check (x
, 0, BT_INTEGER
))
6793 if (!kind_value_check (x
, 0, 4))
6801 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6803 if (!scalar_check (seconds
, 0))
6805 if (!type_check (seconds
, 0, BT_INTEGER
))
6808 if (!int_or_proc_check (handler
, 1))
6810 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6816 if (!scalar_check (status
, 2))
6818 if (!type_check (status
, 2, BT_INTEGER
))
6820 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6828 gfc_check_rand (gfc_expr
*x
)
6833 if (!scalar_check (x
, 0))
6836 if (!type_check (x
, 0, BT_INTEGER
))
6839 if (!kind_value_check (x
, 0, 4))
6847 gfc_check_srand (gfc_expr
*x
)
6849 if (!scalar_check (x
, 0))
6852 if (!type_check (x
, 0, BT_INTEGER
))
6855 if (!kind_value_check (x
, 0, 4))
6863 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6865 if (!scalar_check (time
, 0))
6867 if (!type_check (time
, 0, BT_INTEGER
))
6870 if (!type_check (result
, 1, BT_CHARACTER
))
6872 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6880 gfc_check_dtime_etime (gfc_expr
*x
)
6882 if (!array_check (x
, 0))
6885 if (!rank_check (x
, 0, 1))
6888 if (!variable_check (x
, 0, false))
6891 if (!type_check (x
, 0, BT_REAL
))
6894 if (!kind_value_check (x
, 0, 4))
6902 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6904 if (!array_check (values
, 0))
6907 if (!rank_check (values
, 0, 1))
6910 if (!variable_check (values
, 0, false))
6913 if (!type_check (values
, 0, BT_REAL
))
6916 if (!kind_value_check (values
, 0, 4))
6919 if (!scalar_check (time
, 1))
6922 if (!type_check (time
, 1, BT_REAL
))
6925 if (!kind_value_check (time
, 1, 4))
6933 gfc_check_fdate_sub (gfc_expr
*date
)
6935 if (!type_check (date
, 0, BT_CHARACTER
))
6937 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6945 gfc_check_gerror (gfc_expr
*msg
)
6947 if (!type_check (msg
, 0, BT_CHARACTER
))
6949 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6957 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6959 if (!type_check (cwd
, 0, BT_CHARACTER
))
6961 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6967 if (!scalar_check (status
, 1))
6970 if (!type_check (status
, 1, BT_INTEGER
))
6978 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6980 if (!type_check (pos
, 0, BT_INTEGER
))
6983 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6985 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6986 "not wider than the default kind (%d)",
6987 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6988 &pos
->where
, gfc_default_integer_kind
);
6992 if (!type_check (value
, 1, BT_CHARACTER
))
6994 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
7002 gfc_check_getlog (gfc_expr
*msg
)
7004 if (!type_check (msg
, 0, BT_CHARACTER
))
7006 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7014 gfc_check_exit (gfc_expr
*status
)
7019 if (!type_check (status
, 0, BT_INTEGER
))
7022 if (!scalar_check (status
, 0))
7030 gfc_check_flush (gfc_expr
*unit
)
7035 if (!type_check (unit
, 0, BT_INTEGER
))
7038 if (!scalar_check (unit
, 0))
7046 gfc_check_free (gfc_expr
*i
)
7048 if (!type_check (i
, 0, BT_INTEGER
))
7051 if (!scalar_check (i
, 0))
7059 gfc_check_hostnm (gfc_expr
*name
)
7061 if (!type_check (name
, 0, BT_CHARACTER
))
7063 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7071 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
7073 if (!type_check (name
, 0, BT_CHARACTER
))
7075 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7081 if (!scalar_check (status
, 1))
7084 if (!type_check (status
, 1, BT_INTEGER
))
7092 gfc_check_itime_idate (gfc_expr
*values
)
7094 if (!array_check (values
, 0))
7097 if (!rank_check (values
, 0, 1))
7100 if (!variable_check (values
, 0, false))
7103 if (!type_check (values
, 0, BT_INTEGER
))
7106 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
7114 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
7116 if (!type_check (time
, 0, BT_INTEGER
))
7119 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
7122 if (!scalar_check (time
, 0))
7125 if (!array_check (values
, 1))
7128 if (!rank_check (values
, 1, 1))
7131 if (!variable_check (values
, 1, false))
7134 if (!type_check (values
, 1, BT_INTEGER
))
7137 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
7145 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
7147 if (!scalar_check (unit
, 0))
7150 if (!type_check (unit
, 0, BT_INTEGER
))
7153 if (!type_check (name
, 1, BT_CHARACTER
))
7155 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
7163 gfc_check_is_contiguous (gfc_expr
*array
)
7165 if (array
->expr_type
== EXPR_NULL
)
7167 gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7168 "associated pointer", &array
->where
, gfc_current_intrinsic
);
7172 if (!array_check (array
, 0))
7180 gfc_check_isatty (gfc_expr
*unit
)
7185 if (!type_check (unit
, 0, BT_INTEGER
))
7188 if (!scalar_check (unit
, 0))
7196 gfc_check_isnan (gfc_expr
*x
)
7198 if (!type_check (x
, 0, BT_REAL
))
7206 gfc_check_perror (gfc_expr
*string
)
7208 if (!type_check (string
, 0, BT_CHARACTER
))
7210 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
7218 gfc_check_umask (gfc_expr
*mask
)
7220 if (!type_check (mask
, 0, BT_INTEGER
))
7223 if (!scalar_check (mask
, 0))
7231 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
7233 if (!type_check (mask
, 0, BT_INTEGER
))
7236 if (!scalar_check (mask
, 0))
7242 if (!scalar_check (old
, 1))
7245 if (!type_check (old
, 1, BT_INTEGER
))
7253 gfc_check_unlink (gfc_expr
*name
)
7255 if (!type_check (name
, 0, BT_CHARACTER
))
7257 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7265 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
7267 if (!type_check (name
, 0, BT_CHARACTER
))
7269 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7275 if (!scalar_check (status
, 1))
7278 if (!type_check (status
, 1, BT_INTEGER
))
7286 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
7288 if (!scalar_check (number
, 0))
7290 if (!type_check (number
, 0, BT_INTEGER
))
7293 if (!int_or_proc_check (handler
, 1))
7295 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7303 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
7305 if (!scalar_check (number
, 0))
7307 if (!type_check (number
, 0, BT_INTEGER
))
7310 if (!int_or_proc_check (handler
, 1))
7312 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7318 if (!type_check (status
, 2, BT_INTEGER
))
7320 if (!scalar_check (status
, 2))
7328 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
7330 if (!type_check (cmd
, 0, BT_CHARACTER
))
7332 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
7335 if (!scalar_check (status
, 1))
7338 if (!type_check (status
, 1, BT_INTEGER
))
7341 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
7348 /* This is used for the GNU intrinsics AND, OR and XOR. */
7350 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
7352 if (i
->ts
.type
!= BT_INTEGER
7353 && i
->ts
.type
!= BT_LOGICAL
7354 && i
->ts
.type
!= BT_BOZ
)
7356 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7357 "LOGICAL, or a BOZ literal constant",
7358 gfc_current_intrinsic_arg
[0]->name
,
7359 gfc_current_intrinsic
, &i
->where
);
7363 if (j
->ts
.type
!= BT_INTEGER
7364 && j
->ts
.type
!= BT_LOGICAL
7365 && j
->ts
.type
!= BT_BOZ
)
7367 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7368 "LOGICAL, or a BOZ literal constant",
7369 gfc_current_intrinsic_arg
[1]->name
,
7370 gfc_current_intrinsic
, &j
->where
);
7374 /* i and j cannot both be BOZ literal constants. */
7375 if (!boz_args_check (i
, j
))
7378 /* If i is BOZ and j is integer, convert i to type of j. */
7379 if (i
->ts
.type
== BT_BOZ
)
7381 if (j
->ts
.type
!= BT_INTEGER
)
7383 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7384 gfc_current_intrinsic_arg
[1]->name
,
7385 gfc_current_intrinsic
, &j
->where
);
7389 if (!gfc_boz2int (i
, j
->ts
.kind
))
7393 /* If j is BOZ and i is integer, convert j to type of i. */
7394 if (j
->ts
.type
== BT_BOZ
)
7396 if (i
->ts
.type
!= BT_INTEGER
)
7398 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7399 gfc_current_intrinsic_arg
[0]->name
,
7400 gfc_current_intrinsic
, &j
->where
);
7404 if (!gfc_boz2int (j
, i
->ts
.kind
))
7408 if (!same_type_check (i
, 0, j
, 1, false))
7411 if (!scalar_check (i
, 0))
7414 if (!scalar_check (j
, 1))
7422 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
7425 if (a
->expr_type
== EXPR_NULL
)
7427 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7428 "argument to STORAGE_SIZE, because it returns a "
7429 "disassociated pointer", &a
->where
);
7433 if (a
->ts
.type
== BT_ASSUMED
)
7435 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7436 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7441 if (a
->ts
.type
== BT_PROCEDURE
)
7443 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7444 "procedure", gfc_current_intrinsic_arg
[0]->name
,
7445 gfc_current_intrinsic
, &a
->where
);
7449 if (a
->ts
.type
== BT_BOZ
&& illegal_boz_arg (a
))
7455 if (!type_check (kind
, 1, BT_INTEGER
))
7458 if (!scalar_check (kind
, 1))
7461 if (kind
->expr_type
!= EXPR_CONSTANT
)
7463 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7464 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,