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 d
= ap
->next
->next
->expr
;
3952 m
= ap
->next
->next
->next
->expr
;
3953 k
= ap
->next
->next
->next
->next
->expr
;
3954 b
= ap
->next
->next
->next
->next
->next
->expr
;
3958 if (!type_check (b
, 5, BT_LOGICAL
) || !scalar_check (b
,4))
3963 b
= gfc_get_logical_expr (gfc_logical_4_kind
, NULL
, 0);
3964 ap
->next
->next
->next
->next
->next
->expr
= b
;
3967 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
3968 && ap
->next
->name
== NULL
)
3972 ap
->next
->next
->expr
= NULL
;
3973 ap
->next
->next
->next
->expr
= m
;
3976 if (!dim_check (d
, 2, false))
3979 if (!dim_rank_check (d
, a
, 0))
3982 if (m
!= NULL
&& !type_check (m
, 3, BT_LOGICAL
))
3986 && !gfc_check_conformance (a
, m
,
3987 "arguments '%s' and '%s' for intrinsic %s",
3988 gfc_current_intrinsic_arg
[0]->name
,
3989 gfc_current_intrinsic_arg
[3]->name
,
3990 gfc_current_intrinsic
))
3993 if (!kind_check (k
, 1, BT_INTEGER
))
3999 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4000 "conformance to argument %qs at %L",
4001 gfc_current_intrinsic_arg
[0]->name
,
4002 gfc_current_intrinsic
, &a
->where
,
4003 gfc_current_intrinsic_arg
[1]->name
, &v
->where
);
4008 /* Similar to minloc/maxloc, the argument list might need to be
4009 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4010 difference is that MINLOC/MAXLOC take an additional KIND argument.
4011 The possibilities are:
4017 NULL MASK minval(array, mask=m)
4020 I.e. in the case of minval(array,mask), mask will be in the second
4021 position of the argument list and we'll have to fix that up. */
4024 check_reduction (gfc_actual_arglist
*ap
)
4026 gfc_expr
*a
, *m
, *d
;
4030 m
= ap
->next
->next
->expr
;
4032 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
4033 && ap
->next
->name
== NULL
)
4037 ap
->next
->expr
= NULL
;
4038 ap
->next
->next
->expr
= m
;
4041 if (!dim_check (d
, 1, false))
4044 if (!dim_rank_check (d
, a
, 0))
4047 if (m
!= NULL
&& !type_check (m
, 2, BT_LOGICAL
))
4051 && !gfc_check_conformance (a
, m
,
4052 "arguments '%s' and '%s' for intrinsic %s",
4053 gfc_current_intrinsic_arg
[0]->name
,
4054 gfc_current_intrinsic_arg
[2]->name
,
4055 gfc_current_intrinsic
))
4063 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
4065 if (!int_or_real_or_char_check_f2003 (ap
->expr
, 0)
4066 || !array_check (ap
->expr
, 0))
4069 return check_reduction (ap
);
4074 gfc_check_product_sum (gfc_actual_arglist
*ap
)
4076 if (!numeric_check (ap
->expr
, 0)
4077 || !array_check (ap
->expr
, 0))
4080 return check_reduction (ap
);
4084 /* For IANY, IALL and IPARITY. */
4087 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
4091 if (!type_check (i
, 0, BT_INTEGER
))
4094 if (!nonnegative_check ("I", i
))
4097 if (!kind_check (kind
, 1, BT_INTEGER
))
4101 gfc_extract_int (kind
, &k
);
4103 k
= gfc_default_integer_kind
;
4105 if (!less_than_bitsizekind ("I", i
, k
))
4113 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
4115 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
4117 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4118 gfc_current_intrinsic_arg
[0]->name
,
4119 gfc_current_intrinsic
, &ap
->expr
->where
);
4123 if (!array_check (ap
->expr
, 0))
4126 return check_reduction (ap
);
4131 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4133 if (!same_type_check (tsource
, 0, fsource
, 1))
4136 if (!type_check (mask
, 2, BT_LOGICAL
))
4139 if (tsource
->ts
.type
== BT_CHARACTER
)
4140 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
4147 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
4149 /* i and j cannot both be BOZ literal constants. */
4150 if (!boz_args_check (i
, j
))
4153 /* If i is BOZ and j is integer, convert i to type of j. */
4154 if (i
->ts
.type
== BT_BOZ
&& j
->ts
.type
== BT_INTEGER
4155 && !gfc_boz2int (i
, j
->ts
.kind
))
4158 /* If j is BOZ and i is integer, convert j to type of i. */
4159 if (j
->ts
.type
== BT_BOZ
&& i
->ts
.type
== BT_INTEGER
4160 && !gfc_boz2int (j
, i
->ts
.kind
))
4163 if (!type_check (i
, 0, BT_INTEGER
))
4166 if (!type_check (j
, 1, BT_INTEGER
))
4169 if (!same_type_check (i
, 0, j
, 1))
4172 if (mask
->ts
.type
== BT_BOZ
&& !gfc_boz2int(mask
, i
->ts
.kind
))
4175 if (!type_check (mask
, 2, BT_INTEGER
))
4178 if (!same_type_check (i
, 0, mask
, 2))
4186 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
4188 if (!variable_check (from
, 0, false))
4190 if (!allocatable_check (from
, 0))
4192 if (gfc_is_coindexed (from
))
4194 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4195 "coindexed", &from
->where
);
4199 if (!variable_check (to
, 1, false))
4201 if (!allocatable_check (to
, 1))
4203 if (gfc_is_coindexed (to
))
4205 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4206 "coindexed", &to
->where
);
4210 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
4212 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4213 "polymorphic if FROM is polymorphic",
4218 if (!same_type_check (to
, 1, from
, 0))
4221 if (to
->rank
!= from
->rank
)
4223 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4224 "must have the same rank %d/%d", &to
->where
, from
->rank
,
4229 /* IR F08/0040; cf. 12-006A. */
4230 if (gfc_get_corank (to
) != gfc_get_corank (from
))
4232 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4233 "must have the same corank %d/%d", &to
->where
,
4234 gfc_get_corank (from
), gfc_get_corank (to
));
4238 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
4239 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4240 and cmp2 are allocatable. After the allocation is transferred,
4241 the 'to' chain is broken by the nullification of the 'from'. A bit
4242 of reflection reveals that this can only occur for derived types
4243 with recursive allocatable components. */
4244 if (to
->expr_type
== EXPR_VARIABLE
&& from
->expr_type
== EXPR_VARIABLE
4245 && !strcmp (to
->symtree
->n
.sym
->name
, from
->symtree
->n
.sym
->name
))
4247 gfc_ref
*to_ref
, *from_ref
;
4249 from_ref
= from
->ref
;
4250 bool aliasing
= true;
4252 for (; from_ref
&& to_ref
;
4253 from_ref
= from_ref
->next
, to_ref
= to_ref
->next
)
4255 if (to_ref
->type
!= from
->ref
->type
)
4257 else if (to_ref
->type
== REF_ARRAY
4258 && to_ref
->u
.ar
.type
!= AR_FULL
4259 && from_ref
->u
.ar
.type
!= AR_FULL
)
4260 /* Play safe; assume sections and elements are different. */
4262 else if (to_ref
->type
== REF_COMPONENT
4263 && to_ref
->u
.c
.component
!= from_ref
->u
.c
.component
)
4272 gfc_error ("The FROM and TO arguments at %L violate aliasing "
4273 "restrictions (F2003 12.4.1.7)", &to
->where
);
4278 /* CLASS arguments: Make sure the vtab of from is present. */
4279 if (to
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (from
))
4280 gfc_find_vtab (&from
->ts
);
4287 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
4289 if (!type_check (x
, 0, BT_REAL
))
4292 if (!type_check (s
, 1, BT_REAL
))
4295 if (s
->expr_type
== EXPR_CONSTANT
)
4297 if (mpfr_sgn (s
->value
.real
) == 0)
4299 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4310 gfc_check_new_line (gfc_expr
*a
)
4312 if (!type_check (a
, 0, BT_CHARACTER
))
4320 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
4322 if (!type_check (array
, 0, BT_REAL
))
4325 if (!array_check (array
, 0))
4328 if (!dim_rank_check (dim
, array
, false))
4335 gfc_check_null (gfc_expr
*mold
)
4337 symbol_attribute attr
;
4342 if (!variable_check (mold
, 0, true))
4345 attr
= gfc_variable_attr (mold
, NULL
);
4347 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
4349 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4350 "ALLOCATABLE or procedure pointer",
4351 gfc_current_intrinsic_arg
[0]->name
,
4352 gfc_current_intrinsic
, &mold
->where
);
4356 if (attr
.allocatable
4357 && !gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
4358 "allocatable MOLD at %L", &mold
->where
))
4362 if (gfc_is_coindexed (mold
))
4364 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4365 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
4366 gfc_current_intrinsic
, &mold
->where
);
4375 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4377 if (!array_check (array
, 0))
4380 if (!type_check (mask
, 1, BT_LOGICAL
))
4383 if (!gfc_check_conformance (array
, mask
,
4384 "arguments '%s' and '%s' for intrinsic '%s'",
4385 gfc_current_intrinsic_arg
[0]->name
,
4386 gfc_current_intrinsic_arg
[1]->name
,
4387 gfc_current_intrinsic
))
4392 mpz_t array_size
, vector_size
;
4393 bool have_array_size
, have_vector_size
;
4395 if (!same_type_check (array
, 0, vector
, 2))
4398 if (!rank_check (vector
, 2, 1))
4401 /* VECTOR requires at least as many elements as MASK
4402 has .TRUE. values. */
4403 have_array_size
= gfc_array_size(array
, &array_size
);
4404 have_vector_size
= gfc_array_size(vector
, &vector_size
);
4406 if (have_vector_size
4407 && (mask
->expr_type
== EXPR_ARRAY
4408 || (mask
->expr_type
== EXPR_CONSTANT
4409 && have_array_size
)))
4411 int mask_true_values
= 0;
4413 if (mask
->expr_type
== EXPR_ARRAY
)
4415 gfc_constructor
*mask_ctor
;
4416 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4419 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4421 mask_true_values
= 0;
4425 if (mask_ctor
->expr
->value
.logical
)
4428 mask_ctor
= gfc_constructor_next (mask_ctor
);
4431 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
4432 mask_true_values
= mpz_get_si (array_size
);
4434 if (mpz_get_si (vector_size
) < mask_true_values
)
4436 gfc_error ("%qs argument of %qs intrinsic at %L must "
4437 "provide at least as many elements as there "
4438 "are .TRUE. values in %qs (%ld/%d)",
4439 gfc_current_intrinsic_arg
[2]->name
,
4440 gfc_current_intrinsic
, &vector
->where
,
4441 gfc_current_intrinsic_arg
[1]->name
,
4442 mpz_get_si (vector_size
), mask_true_values
);
4447 if (have_array_size
)
4448 mpz_clear (array_size
);
4449 if (have_vector_size
)
4450 mpz_clear (vector_size
);
4458 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
4460 if (!type_check (mask
, 0, BT_LOGICAL
))
4463 if (!array_check (mask
, 0))
4466 if (!dim_rank_check (dim
, mask
, false))
4474 gfc_check_precision (gfc_expr
*x
)
4476 if (!real_or_complex_check (x
, 0))
4484 gfc_check_present (gfc_expr
*a
)
4488 if (!variable_check (a
, 0, true))
4491 sym
= a
->symtree
->n
.sym
;
4492 if (!sym
->attr
.dummy
)
4494 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4495 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
4496 gfc_current_intrinsic
, &a
->where
);
4500 if (!sym
->attr
.optional
)
4502 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4503 "an OPTIONAL dummy variable",
4504 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4509 /* 13.14.82 PRESENT(A)
4511 Argument. A shall be the name of an optional dummy argument that is
4512 accessible in the subprogram in which the PRESENT function reference
4516 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
4517 && (a
->ref
->u
.ar
.type
== AR_FULL
4518 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
4519 && a
->ref
->u
.ar
.as
->rank
== 0))))
4521 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4522 "subobject of %qs", gfc_current_intrinsic_arg
[0]->name
,
4523 gfc_current_intrinsic
, &a
->where
, sym
->name
);
4532 gfc_check_radix (gfc_expr
*x
)
4534 if (!int_or_real_check (x
, 0))
4542 gfc_check_range (gfc_expr
*x
)
4544 if (!numeric_check (x
, 0))
4552 gfc_check_rank (gfc_expr
*a
)
4554 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4555 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4557 bool is_variable
= true;
4559 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4560 if (a
->expr_type
== EXPR_FUNCTION
)
4561 is_variable
= a
->value
.function
.esym
4562 ? a
->value
.function
.esym
->result
->attr
.pointer
4563 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
4565 if (a
->expr_type
== EXPR_OP
4566 || a
->expr_type
== EXPR_NULL
4567 || a
->expr_type
== EXPR_COMPCALL
4568 || a
->expr_type
== EXPR_PPC
4569 || a
->ts
.type
== BT_PROCEDURE
4572 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4573 "object", &a
->where
);
4582 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
4584 if (!kind_check (kind
, 1, BT_REAL
))
4587 /* BOZ is dealt with in gfc_simplify_real. */
4588 if (a
->ts
.type
== BT_BOZ
)
4591 if (!numeric_check (a
, 0))
4599 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
4601 if (!type_check (path1
, 0, BT_CHARACTER
))
4603 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4606 if (!type_check (path2
, 1, BT_CHARACTER
))
4608 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4616 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
4618 if (!type_check (path1
, 0, BT_CHARACTER
))
4620 if (!kind_value_check (path1
, 0, gfc_default_character_kind
))
4623 if (!type_check (path2
, 1, BT_CHARACTER
))
4625 if (!kind_value_check (path2
, 1, gfc_default_character_kind
))
4631 if (!type_check (status
, 2, BT_INTEGER
))
4634 if (!scalar_check (status
, 2))
4642 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
4644 if (!type_check (x
, 0, BT_CHARACTER
))
4647 if (!scalar_check (x
, 0))
4650 if (!type_check (y
, 0, BT_INTEGER
))
4653 if (!scalar_check (y
, 1))
4661 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
4662 gfc_expr
*pad
, gfc_expr
*order
)
4668 if (!array_check (source
, 0))
4671 if (!rank_check (shape
, 1, 1))
4674 if (!type_check (shape
, 1, BT_INTEGER
))
4677 if (!gfc_array_size (shape
, &size
))
4679 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4680 "array of constant size", &shape
->where
);
4684 shape_size
= mpz_get_ui (size
);
4687 if (shape_size
<= 0)
4689 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4690 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4694 else if (shape_size
> GFC_MAX_DIMENSIONS
)
4696 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4697 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
4700 else if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
4704 for (i
= 0; i
< shape_size
; ++i
)
4706 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
4707 if (e
->expr_type
!= EXPR_CONSTANT
)
4710 gfc_extract_int (e
, &extent
);
4713 gfc_error ("%qs argument of %qs intrinsic at %L has "
4714 "negative element (%d)",
4715 gfc_current_intrinsic_arg
[1]->name
,
4716 gfc_current_intrinsic
, &e
->where
, extent
);
4721 else if (shape
->expr_type
== EXPR_VARIABLE
&& shape
->ref
4722 && shape
->ref
->u
.ar
.type
== AR_FULL
&& shape
->ref
->u
.ar
.dimen
== 1
4723 && shape
->ref
->u
.ar
.as
4724 && shape
->ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
4725 && shape
->ref
->u
.ar
.as
->lower
[0]->ts
.type
== BT_INTEGER
4726 && shape
->ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
4727 && shape
->ref
->u
.ar
.as
->upper
[0]->ts
.type
== BT_INTEGER
4728 && shape
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4733 v
= shape
->symtree
->n
.sym
->value
;
4735 for (i
= 0; i
< shape_size
; i
++)
4737 e
= gfc_constructor_lookup_expr (v
->value
.constructor
, i
);
4741 gfc_extract_int (e
, &extent
);
4745 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4746 "cannot be negative", i
+ 1, &shape
->where
);
4754 if (!same_type_check (source
, 0, pad
, 2))
4757 if (!array_check (pad
, 2))
4763 if (!array_check (order
, 3))
4766 if (!type_check (order
, 3, BT_INTEGER
))
4769 if (order
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (order
))
4771 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
4774 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
4777 gfc_array_size (order
, &size
);
4778 order_size
= mpz_get_ui (size
);
4781 if (order_size
!= shape_size
)
4783 gfc_error ("%qs argument of %qs intrinsic at %L "
4784 "has wrong number of elements (%d/%d)",
4785 gfc_current_intrinsic_arg
[3]->name
,
4786 gfc_current_intrinsic
, &order
->where
,
4787 order_size
, shape_size
);
4791 for (i
= 1; i
<= order_size
; ++i
)
4793 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
4794 if (e
->expr_type
!= EXPR_CONSTANT
)
4797 gfc_extract_int (e
, &dim
);
4799 if (dim
< 1 || dim
> order_size
)
4801 gfc_error ("%qs argument of %qs intrinsic at %L "
4802 "has out-of-range dimension (%d)",
4803 gfc_current_intrinsic_arg
[3]->name
,
4804 gfc_current_intrinsic
, &e
->where
, dim
);
4808 if (perm
[dim
-1] != 0)
4810 gfc_error ("%qs argument of %qs intrinsic at %L has "
4811 "invalid permutation of dimensions (dimension "
4813 gfc_current_intrinsic_arg
[3]->name
,
4814 gfc_current_intrinsic
, &e
->where
, dim
);
4823 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
4824 && gfc_is_constant_expr (shape
)
4825 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
4826 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
4828 /* Check the match in size between source and destination. */
4829 if (gfc_array_size (source
, &nelems
))
4835 mpz_init_set_ui (size
, 1);
4836 for (c
= gfc_constructor_first (shape
->value
.constructor
);
4837 c
; c
= gfc_constructor_next (c
))
4838 mpz_mul (size
, size
, c
->expr
->value
.integer
);
4840 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
4846 gfc_error ("Without padding, there are not enough elements "
4847 "in the intrinsic RESHAPE source at %L to match "
4848 "the shape", &source
->where
);
4859 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
4861 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
4863 gfc_error ("%qs argument of %qs intrinsic at %L "
4864 "cannot be of type %s",
4865 gfc_current_intrinsic_arg
[0]->name
,
4866 gfc_current_intrinsic
,
4867 &a
->where
, gfc_typename (a
));
4871 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
4873 gfc_error ("%qs argument of %qs intrinsic at %L "
4874 "must be of an extensible type",
4875 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4880 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
4882 gfc_error ("%qs argument of %qs intrinsic at %L "
4883 "cannot be of type %s",
4884 gfc_current_intrinsic_arg
[0]->name
,
4885 gfc_current_intrinsic
,
4886 &b
->where
, gfc_typename (b
));
4890 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
4892 gfc_error ("%qs argument of %qs intrinsic at %L "
4893 "must be of an extensible type",
4894 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4904 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
4906 if (!type_check (x
, 0, BT_REAL
))
4909 if (!type_check (i
, 1, BT_INTEGER
))
4917 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4919 if (!type_check (x
, 0, BT_CHARACTER
))
4922 if (!type_check (y
, 1, BT_CHARACTER
))
4925 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
4928 if (!kind_check (kind
, 3, BT_INTEGER
))
4930 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
4931 "with KIND argument at %L",
4932 gfc_current_intrinsic
, &kind
->where
))
4935 if (!same_type_check (x
, 0, y
, 1))
4943 gfc_check_secnds (gfc_expr
*r
)
4945 if (!type_check (r
, 0, BT_REAL
))
4948 if (!kind_value_check (r
, 0, 4))
4951 if (!scalar_check (r
, 0))
4959 gfc_check_selected_char_kind (gfc_expr
*name
)
4961 if (!type_check (name
, 0, BT_CHARACTER
))
4964 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
4967 if (!scalar_check (name
, 0))
4975 gfc_check_selected_int_kind (gfc_expr
*r
)
4977 if (!type_check (r
, 0, BT_INTEGER
))
4980 if (!scalar_check (r
, 0))
4988 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
4990 if (p
== NULL
&& r
== NULL
4991 && !gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
4992 " neither %<P%> nor %<R%> argument at %L",
4993 gfc_current_intrinsic_where
))
4998 if (!type_check (p
, 0, BT_INTEGER
))
5001 if (!scalar_check (p
, 0))
5007 if (!type_check (r
, 1, BT_INTEGER
))
5010 if (!scalar_check (r
, 1))
5016 if (!type_check (radix
, 1, BT_INTEGER
))
5019 if (!scalar_check (radix
, 1))
5022 if (!gfc_notify_std (GFC_STD_F2008
, "%qs intrinsic with "
5023 "RADIX argument at %L", gfc_current_intrinsic
,
5033 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5035 if (!type_check (x
, 0, BT_REAL
))
5038 if (!type_check (i
, 1, BT_INTEGER
))
5046 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
5050 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
5053 ar
= gfc_find_array_ref (source
);
5055 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
5057 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5058 "an assumed size array", &source
->where
);
5062 if (!kind_check (kind
, 1, BT_INTEGER
))
5064 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5065 "with KIND argument at %L",
5066 gfc_current_intrinsic
, &kind
->where
))
5074 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
5076 if (!type_check (i
, 0, BT_INTEGER
))
5079 if (!type_check (shift
, 0, BT_INTEGER
))
5082 if (!nonnegative_check ("SHIFT", shift
))
5085 if (!less_than_bitsize1 ("I", i
, "SHIFT", shift
, true))
5093 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
5095 if (!int_or_real_check (a
, 0))
5098 if (!same_type_check (a
, 0, b
, 1))
5106 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5108 if (!array_check (array
, 0))
5111 if (!dim_check (dim
, 1, true))
5114 if (!dim_rank_check (dim
, array
, 0))
5117 if (!kind_check (kind
, 2, BT_INTEGER
))
5119 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
5120 "with KIND argument at %L",
5121 gfc_current_intrinsic
, &kind
->where
))
5130 gfc_check_sizeof (gfc_expr
*arg
)
5132 if (arg
->ts
.type
== BT_PROCEDURE
)
5134 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5135 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5140 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5141 if (arg
->ts
.type
== BT_ASSUMED
5142 && (arg
->symtree
->n
.sym
->as
== NULL
5143 || (arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_SHAPE
5144 && arg
->symtree
->n
.sym
->as
->type
!= AS_DEFERRED
5145 && arg
->symtree
->n
.sym
->as
->type
!= AS_ASSUMED_RANK
)))
5147 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5148 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5153 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5154 && arg
->symtree
->n
.sym
->as
!= NULL
5155 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5156 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5158 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5159 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5160 gfc_current_intrinsic
, &arg
->where
);
5168 /* Check whether an expression is interoperable. When returning false,
5169 msg is set to a string telling why the expression is not interoperable,
5170 otherwise, it is set to NULL. The msg string can be used in diagnostics.
5171 If c_loc is true, character with len > 1 are allowed (cf. Fortran
5172 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5173 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5177 is_c_interoperable (gfc_expr
*expr
, const char **msg
, bool c_loc
, bool c_f_ptr
)
5181 if (expr
->ts
.type
== BT_CLASS
)
5183 *msg
= "Expression is polymorphic";
5187 if (expr
->ts
.type
== BT_DERIVED
&& !expr
->ts
.u
.derived
->attr
.is_bind_c
5188 && !expr
->ts
.u
.derived
->ts
.is_iso_c
)
5190 *msg
= "Expression is a noninteroperable derived type";
5194 if (expr
->ts
.type
== BT_PROCEDURE
)
5196 *msg
= "Procedure unexpected as argument";
5200 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_LOGICAL
)
5203 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
5204 if (gfc_logical_kinds
[i
].kind
== expr
->ts
.kind
)
5206 *msg
= "Extension to use a non-C_Bool-kind LOGICAL";
5210 if (gfc_notification_std (GFC_STD_GNU
) && expr
->ts
.type
== BT_CHARACTER
5211 && expr
->ts
.kind
!= 1)
5213 *msg
= "Extension to use a non-C_CHAR-kind CHARACTER";
5217 if (expr
->ts
.type
== BT_CHARACTER
) {
5218 if (expr
->ts
.deferred
)
5220 /* TS 29113 allows deferred-length strings as dummy arguments,
5221 but it is not an interoperable type. */
5222 *msg
= "Expression shall not be a deferred-length string";
5226 if (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length
5227 && !gfc_simplify_expr (expr
->ts
.u
.cl
->length
, 0))
5228 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5230 if (!c_loc
&& expr
->ts
.u
.cl
5231 && (!expr
->ts
.u
.cl
->length
5232 || expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5233 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5235 *msg
= "Type shall have a character length of 1";
5240 /* Note: The following checks are about interoperatable variables, Fortran
5241 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5242 is allowed, e.g. assumed-shape arrays with TS 29113. */
5244 if (gfc_is_coarray (expr
))
5246 *msg
= "Coarrays are not interoperable";
5250 if (!c_loc
&& expr
->rank
> 0 && expr
->expr_type
!= EXPR_ARRAY
)
5252 gfc_array_ref
*ar
= gfc_find_array_ref (expr
);
5253 if (ar
->type
!= AR_FULL
)
5255 *msg
= "Only whole-arrays are interoperable";
5258 if (!c_f_ptr
&& ar
->as
->type
!= AS_EXPLICIT
5259 && ar
->as
->type
!= AS_ASSUMED_SIZE
)
5261 *msg
= "Only explicit-size and assumed-size arrays are interoperable";
5271 gfc_check_c_sizeof (gfc_expr
*arg
)
5275 if (!is_c_interoperable (arg
, &msg
, false, false))
5277 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5278 "interoperable data entity: %s",
5279 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5284 if (arg
->ts
.type
== BT_ASSUMED
)
5286 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5288 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
5293 if (arg
->rank
&& arg
->expr_type
== EXPR_VARIABLE
5294 && arg
->symtree
->n
.sym
->as
!= NULL
5295 && arg
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
&& arg
->ref
5296 && arg
->ref
->type
== REF_ARRAY
&& arg
->ref
->u
.ar
.type
== AR_FULL
)
5298 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5299 "assumed-size array", gfc_current_intrinsic_arg
[0]->name
,
5300 gfc_current_intrinsic
, &arg
->where
);
5309 gfc_check_c_associated (gfc_expr
*c_ptr_1
, gfc_expr
*c_ptr_2
)
5311 if (c_ptr_1
->ts
.type
!= BT_DERIVED
5312 || c_ptr_1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5313 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
5314 && c_ptr_1
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
))
5316 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5317 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1
->where
);
5321 if (!scalar_check (c_ptr_1
, 0))
5325 && (c_ptr_2
->ts
.type
!= BT_DERIVED
5326 || c_ptr_2
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5327 || (c_ptr_1
->ts
.u
.derived
->intmod_sym_id
5328 != c_ptr_2
->ts
.u
.derived
->intmod_sym_id
)))
5330 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5331 "same type as C_PTR_1: %s instead of %s", &c_ptr_1
->where
,
5332 gfc_typename (&c_ptr_1
->ts
),
5333 gfc_typename (&c_ptr_2
->ts
));
5337 if (c_ptr_2
&& !scalar_check (c_ptr_2
, 1))
5345 gfc_check_c_f_pointer (gfc_expr
*cptr
, gfc_expr
*fptr
, gfc_expr
*shape
)
5347 symbol_attribute attr
;
5350 if (cptr
->ts
.type
!= BT_DERIVED
5351 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5352 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
5354 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5355 "type TYPE(C_PTR)", &cptr
->where
);
5359 if (!scalar_check (cptr
, 0))
5362 attr
= gfc_expr_attr (fptr
);
5366 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5371 if (fptr
->ts
.type
== BT_CLASS
)
5373 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5378 if (gfc_is_coindexed (fptr
))
5380 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5381 "coindexed", &fptr
->where
);
5385 if (fptr
->rank
== 0 && shape
)
5387 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5388 "FPTR", &fptr
->where
);
5391 else if (fptr
->rank
&& !shape
)
5393 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5394 "FPTR at %L", &fptr
->where
);
5398 if (shape
&& !rank_check (shape
, 2, 1))
5401 if (shape
&& !type_check (shape
, 2, BT_INTEGER
))
5407 if (gfc_array_size (shape
, &size
))
5409 if (mpz_cmp_ui (size
, fptr
->rank
) != 0)
5412 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5413 "size as the RANK of FPTR", &shape
->where
);
5420 if (fptr
->ts
.type
== BT_CLASS
)
5422 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr
->where
);
5426 if (fptr
->rank
> 0 && !is_c_interoperable (fptr
, &msg
, false, true))
5427 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable array FPTR "
5428 "at %L to C_F_POINTER: %s", &fptr
->where
, msg
);
5435 gfc_check_c_f_procpointer (gfc_expr
*cptr
, gfc_expr
*fptr
)
5437 symbol_attribute attr
;
5439 if (cptr
->ts
.type
!= BT_DERIVED
5440 || cptr
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_C_BINDING
5441 || cptr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_FUNPTR
)
5443 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5444 "type TYPE(C_FUNPTR)", &cptr
->where
);
5448 if (!scalar_check (cptr
, 0))
5451 attr
= gfc_expr_attr (fptr
);
5453 if (!attr
.proc_pointer
)
5455 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5456 "pointer", &fptr
->where
);
5460 if (gfc_is_coindexed (fptr
))
5462 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5463 "coindexed", &fptr
->where
);
5467 if (!attr
.is_bind_c
)
5468 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5469 "pointer at %L to C_F_PROCPOINTER", &fptr
->where
);
5476 gfc_check_c_funloc (gfc_expr
*x
)
5478 symbol_attribute attr
;
5480 if (gfc_is_coindexed (x
))
5482 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5483 "coindexed", &x
->where
);
5487 attr
= gfc_expr_attr (x
);
5489 if (attr
.function
&& !attr
.proc_pointer
&& x
->expr_type
== EXPR_VARIABLE
5490 && x
->symtree
->n
.sym
== x
->symtree
->n
.sym
->result
)
5491 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5492 if (x
->symtree
->n
.sym
== ns
->proc_name
)
5494 gfc_error ("Function result %qs at %L is invalid as X argument "
5495 "to C_FUNLOC", x
->symtree
->n
.sym
->name
, &x
->where
);
5499 if (attr
.flavor
!= FL_PROCEDURE
)
5501 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5502 "or a procedure pointer", &x
->where
);
5506 if (!attr
.is_bind_c
)
5507 return gfc_notify_std (GFC_STD_F2018
, "Noninteroperable procedure "
5508 "at %L to C_FUNLOC", &x
->where
);
5514 gfc_check_c_loc (gfc_expr
*x
)
5516 symbol_attribute attr
;
5519 if (gfc_is_coindexed (x
))
5521 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x
->where
);
5525 if (x
->ts
.type
== BT_CLASS
)
5527 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5532 attr
= gfc_expr_attr (x
);
5535 && (x
->expr_type
!= EXPR_VARIABLE
|| !attr
.target
5536 || attr
.flavor
== FL_PARAMETER
))
5538 gfc_error ("Argument X at %L to C_LOC shall have either "
5539 "the POINTER or the TARGET attribute", &x
->where
);
5543 if (x
->ts
.type
== BT_CHARACTER
5544 && gfc_var_strlen (x
) == 0)
5546 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5547 "string", &x
->where
);
5551 if (!is_c_interoperable (x
, &msg
, true, false))
5553 if (x
->ts
.type
== BT_CLASS
)
5555 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5561 && !gfc_notify_std (GFC_STD_F2018
,
5562 "Noninteroperable array at %L as"
5563 " argument to C_LOC: %s", &x
->where
, msg
))
5566 else if (x
->rank
> 0 && gfc_notification_std (GFC_STD_F2008
))
5568 gfc_array_ref
*ar
= gfc_find_array_ref (x
);
5570 if (ar
->as
->type
!= AS_EXPLICIT
&& ar
->as
->type
!= AS_ASSUMED_SIZE
5571 && !attr
.allocatable
5572 && !gfc_notify_std (GFC_STD_F2008
,
5573 "Array of interoperable type at %L "
5574 "to C_LOC which is nonallocatable and neither "
5575 "assumed size nor explicit size", &x
->where
))
5577 else if (ar
->type
!= AR_FULL
5578 && !gfc_notify_std (GFC_STD_F2008
, "Array section at %L "
5579 "to C_LOC", &x
->where
))
5588 gfc_check_sleep_sub (gfc_expr
*seconds
)
5590 if (!type_check (seconds
, 0, BT_INTEGER
))
5593 if (!scalar_check (seconds
, 0))
5600 gfc_check_sngl (gfc_expr
*a
)
5602 if (!type_check (a
, 0, BT_REAL
))
5605 if ((a
->ts
.kind
!= gfc_default_double_kind
)
5606 && !gfc_notify_std (GFC_STD_GNU
, "non double precision "
5607 "REAL argument to %s intrinsic at %L",
5608 gfc_current_intrinsic
, &a
->where
))
5615 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
5617 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
5619 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5620 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
5621 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
5629 if (!dim_check (dim
, 1, false))
5632 /* dim_rank_check() does not apply here. */
5634 && dim
->expr_type
== EXPR_CONSTANT
5635 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
5636 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
5638 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5639 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
5640 gfc_current_intrinsic
, &dim
->where
);
5644 if (!type_check (ncopies
, 2, BT_INTEGER
))
5647 if (!scalar_check (ncopies
, 2))
5654 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5658 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
5660 if (!type_check (unit
, 0, BT_INTEGER
))
5663 if (!scalar_check (unit
, 0))
5666 if (!type_check (c
, 1, BT_CHARACTER
))
5668 if (!kind_value_check (c
, 1, gfc_default_character_kind
))
5674 if (!type_check (status
, 2, BT_INTEGER
)
5675 || !kind_value_check (status
, 2, gfc_default_integer_kind
)
5676 || !scalar_check (status
, 2))
5684 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
5686 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
5691 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
5693 if (!type_check (c
, 0, BT_CHARACTER
))
5695 if (!kind_value_check (c
, 0, gfc_default_character_kind
))
5701 if (!type_check (status
, 1, BT_INTEGER
)
5702 || !kind_value_check (status
, 1, gfc_default_integer_kind
)
5703 || !scalar_check (status
, 1))
5711 gfc_check_fgetput (gfc_expr
*c
)
5713 return gfc_check_fgetput_sub (c
, NULL
);
5718 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
5720 if (!type_check (unit
, 0, BT_INTEGER
))
5723 if (!scalar_check (unit
, 0))
5726 if (!type_check (offset
, 1, BT_INTEGER
))
5729 if (!scalar_check (offset
, 1))
5732 if (!type_check (whence
, 2, BT_INTEGER
))
5735 if (!scalar_check (whence
, 2))
5741 if (!type_check (status
, 3, BT_INTEGER
))
5744 if (!kind_value_check (status
, 3, 4))
5747 if (!scalar_check (status
, 3))
5756 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
5758 if (!type_check (unit
, 0, BT_INTEGER
))
5761 if (!scalar_check (unit
, 0))
5764 if (!type_check (array
, 1, BT_INTEGER
)
5765 || !kind_value_check (unit
, 0, gfc_default_integer_kind
))
5768 if (!array_check (array
, 1))
5776 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
5778 if (!type_check (unit
, 0, BT_INTEGER
))
5781 if (!scalar_check (unit
, 0))
5784 if (!type_check (array
, 1, BT_INTEGER
)
5785 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5788 if (!array_check (array
, 1))
5794 if (!type_check (status
, 2, BT_INTEGER
)
5795 || !kind_value_check (status
, 2, gfc_default_integer_kind
))
5798 if (!scalar_check (status
, 2))
5806 gfc_check_ftell (gfc_expr
*unit
)
5808 if (!type_check (unit
, 0, BT_INTEGER
))
5811 if (!scalar_check (unit
, 0))
5819 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
5821 if (!type_check (unit
, 0, BT_INTEGER
))
5824 if (!scalar_check (unit
, 0))
5827 if (!type_check (offset
, 1, BT_INTEGER
))
5830 if (!scalar_check (offset
, 1))
5838 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
5840 if (!type_check (name
, 0, BT_CHARACTER
))
5842 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5845 if (!type_check (array
, 1, BT_INTEGER
)
5846 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5849 if (!array_check (array
, 1))
5857 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
5859 if (!type_check (name
, 0, BT_CHARACTER
))
5861 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
5864 if (!type_check (array
, 1, BT_INTEGER
)
5865 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5868 if (!array_check (array
, 1))
5874 if (!type_check (status
, 2, BT_INTEGER
)
5875 || !kind_value_check (array
, 1, gfc_default_integer_kind
))
5878 if (!scalar_check (status
, 2))
5886 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
5890 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5892 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5896 if (!coarray_check (coarray
, 0))
5901 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5902 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
5906 if (gfc_array_size (sub
, &nelems
))
5908 int corank
= gfc_get_corank (coarray
);
5910 if (mpz_cmp_ui (nelems
, corank
) != 0)
5912 gfc_error ("The number of array elements of the SUB argument to "
5913 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5914 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
5926 gfc_check_num_images (gfc_expr
*distance
, gfc_expr
*failed
)
5928 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5930 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5936 if (!type_check (distance
, 0, BT_INTEGER
))
5939 if (!nonnegative_check ("DISTANCE", distance
))
5942 if (!scalar_check (distance
, 0))
5945 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
5946 "NUM_IMAGES at %L", &distance
->where
))
5952 if (!type_check (failed
, 1, BT_LOGICAL
))
5955 if (!scalar_check (failed
, 1))
5958 if (!gfc_notify_std (GFC_STD_F2018
, "FAILED= argument to "
5959 "NUM_IMAGES at %L", &failed
->where
))
5968 gfc_check_team_number (gfc_expr
*team
)
5970 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5972 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5978 if (team
->ts
.type
!= BT_DERIVED
5979 || team
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
5980 || team
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_TEAM_TYPE
)
5982 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
5983 "shall be of type TEAM_TYPE", &team
->where
);
5995 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*distance
)
5997 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5999 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6003 if (coarray
== NULL
&& dim
== NULL
&& distance
== NULL
)
6006 if (dim
!= NULL
&& coarray
== NULL
)
6008 gfc_error ("DIM argument without COARRAY argument not allowed for "
6009 "THIS_IMAGE intrinsic at %L", &dim
->where
);
6013 if (distance
&& (coarray
|| dim
))
6015 gfc_error ("The DISTANCE argument may not be specified together with the "
6016 "COARRAY or DIM argument in intrinsic at %L",
6021 /* Assume that we have "this_image (distance)". */
6022 if (coarray
&& !gfc_is_coarray (coarray
) && coarray
->ts
.type
== BT_INTEGER
)
6026 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6035 if (!type_check (distance
, 2, BT_INTEGER
))
6038 if (!nonnegative_check ("DISTANCE", distance
))
6041 if (!scalar_check (distance
, 2))
6044 if (!gfc_notify_std (GFC_STD_F2018
, "DISTANCE= argument to "
6045 "THIS_IMAGE at %L", &distance
->where
))
6051 if (!coarray_check (coarray
, 0))
6056 if (!dim_check (dim
, 1, false))
6059 if (!dim_corank_check (dim
, coarray
))
6066 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6067 by gfc_simplify_transfer. Return false if we cannot do so. */
6070 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
6071 size_t *source_size
, size_t *result_size
,
6072 size_t *result_length_p
)
6074 size_t result_elt_size
;
6076 if (source
->expr_type
== EXPR_FUNCTION
)
6079 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
6082 /* Calculate the size of the source. */
6083 if (!gfc_target_expr_size (source
, source_size
))
6086 /* Determine the size of the element. */
6087 if (!gfc_element_size (mold
, &result_elt_size
))
6090 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6091 * a scalar with the type and type parameters of MOLD shall not have a
6092 * storage size equal to zero.
6093 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6094 * If MOLD is an array and SIZE is absent, the result is an array and of
6095 * rank one. Its size is as small as possible such that its physical
6096 * representation is not shorter than that of SOURCE.
6097 * If SIZE is present, the result is an array of rank one and size SIZE.
6099 if (result_elt_size
== 0 && *source_size
> 0 && !size
6100 && mold
->expr_type
== EXPR_ARRAY
)
6102 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6103 "array and shall not have storage size 0 when %<SOURCE%> "
6104 "argument has size greater than 0", &mold
->where
);
6108 if (result_elt_size
== 0 && *source_size
== 0 && !size
)
6111 if (result_length_p
)
6112 *result_length_p
= 0;
6116 if ((result_elt_size
> 0 && (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
))
6122 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6125 result_length
= *source_size
/ result_elt_size
;
6126 if (result_length
* result_elt_size
< *source_size
)
6130 *result_size
= result_length
* result_elt_size
;
6131 if (result_length_p
)
6132 *result_length_p
= result_length
;
6135 *result_size
= result_elt_size
;
6142 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6147 /* SOURCE shall be a scalar or array of any type. */
6148 if (source
->ts
.type
== BT_PROCEDURE
6149 && source
->symtree
->n
.sym
->attr
.subroutine
== 1)
6151 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6152 "must not be a %s", &source
->where
,
6153 gfc_basic_typename (source
->ts
.type
));
6157 if (source
->ts
.type
== BT_BOZ
&& illegal_boz_arg (source
))
6160 if (mold
->ts
.type
== BT_BOZ
&& illegal_boz_arg (mold
))
6163 /* MOLD shall be a scalar or array of any type. */
6164 if (mold
->ts
.type
== BT_PROCEDURE
6165 && mold
->symtree
->n
.sym
->attr
.subroutine
== 1)
6167 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6168 "must not be a %s", &mold
->where
,
6169 gfc_basic_typename (mold
->ts
.type
));
6173 if (mold
->ts
.type
== BT_HOLLERITH
)
6175 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6176 " %s", &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
6180 /* SIZE (optional) shall be an integer scalar. The corresponding actual
6181 argument shall not be an optional dummy argument. */
6184 if (!type_check (size
, 2, BT_INTEGER
))
6186 if (size
->ts
.type
== BT_BOZ
)
6191 if (!scalar_check (size
, 2))
6194 if (!nonoptional_check (size
, 2))
6198 if (!warn_surprising
)
6201 /* If we can't calculate the sizes, we cannot check any more.
6202 Return true for that case. */
6204 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6205 &result_size
, NULL
))
6208 if (source_size
< result_size
)
6209 gfc_warning (OPT_Wsurprising
,
6210 "Intrinsic TRANSFER at %L has partly undefined result: "
6211 "source size %ld < result size %ld", &source
->where
,
6212 (long) source_size
, (long) result_size
);
6219 gfc_check_transpose (gfc_expr
*matrix
)
6221 if (!rank_check (matrix
, 0, 2))
6229 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6231 if (!array_check (array
, 0))
6234 if (!dim_check (dim
, 1, false))
6237 if (!dim_rank_check (dim
, array
, 0))
6240 if (!kind_check (kind
, 2, BT_INTEGER
))
6242 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6243 "with KIND argument at %L",
6244 gfc_current_intrinsic
, &kind
->where
))
6252 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
6254 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6256 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6260 if (!coarray_check (coarray
, 0))
6265 if (!dim_check (dim
, 1, false))
6268 if (!dim_corank_check (dim
, coarray
))
6272 if (!kind_check (kind
, 2, BT_INTEGER
))
6280 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6284 if (!rank_check (vector
, 0, 1))
6287 if (!array_check (mask
, 1))
6290 if (!type_check (mask
, 1, BT_LOGICAL
))
6293 if (!same_type_check (vector
, 0, field
, 2))
6296 if (mask
->expr_type
== EXPR_ARRAY
6297 && gfc_array_size (vector
, &vector_size
))
6299 int mask_true_count
= 0;
6300 gfc_constructor
*mask_ctor
;
6301 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6304 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
6306 mask_true_count
= 0;
6310 if (mask_ctor
->expr
->value
.logical
)
6313 mask_ctor
= gfc_constructor_next (mask_ctor
);
6316 if (mpz_get_si (vector_size
) < mask_true_count
)
6318 gfc_error ("%qs argument of %qs intrinsic at %L must "
6319 "provide at least as many elements as there "
6320 "are .TRUE. values in %qs (%ld/%d)",
6321 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6322 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
6323 mpz_get_si (vector_size
), mask_true_count
);
6327 mpz_clear (vector_size
);
6330 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
6332 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6333 "the same rank as %qs or be a scalar",
6334 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6335 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
6339 if (mask
->rank
== field
->rank
)
6342 for (i
= 0; i
< field
->rank
; i
++)
6343 if (! identical_dimen_shape (mask
, i
, field
, i
))
6345 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6346 "must have identical shape.",
6347 gfc_current_intrinsic_arg
[2]->name
,
6348 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6358 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
6360 if (!type_check (x
, 0, BT_CHARACTER
))
6363 if (!same_type_check (x
, 0, y
, 1))
6366 if (z
!= NULL
&& !type_check (z
, 2, BT_LOGICAL
))
6369 if (!kind_check (kind
, 3, BT_INTEGER
))
6371 if (kind
&& !gfc_notify_std (GFC_STD_F2003
, "%qs intrinsic "
6372 "with KIND argument at %L",
6373 gfc_current_intrinsic
, &kind
->where
))
6381 gfc_check_trim (gfc_expr
*x
)
6383 if (!type_check (x
, 0, BT_CHARACTER
))
6386 if (!scalar_check (x
, 0))
6394 gfc_check_ttynam (gfc_expr
*unit
)
6396 if (!scalar_check (unit
, 0))
6399 if (!type_check (unit
, 0, BT_INTEGER
))
6406 /************* Check functions for intrinsic subroutines *************/
6409 gfc_check_cpu_time (gfc_expr
*time
)
6411 if (!scalar_check (time
, 0))
6414 if (!type_check (time
, 0, BT_REAL
))
6417 if (!variable_check (time
, 0, false))
6425 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
6426 gfc_expr
*zone
, gfc_expr
*values
)
6430 if (!type_check (date
, 0, BT_CHARACTER
))
6432 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6434 if (!scalar_check (date
, 0))
6436 if (!variable_check (date
, 0, false))
6442 if (!type_check (time
, 1, BT_CHARACTER
))
6444 if (!kind_value_check (time
, 1, gfc_default_character_kind
))
6446 if (!scalar_check (time
, 1))
6448 if (!variable_check (time
, 1, false))
6454 if (!type_check (zone
, 2, BT_CHARACTER
))
6456 if (!kind_value_check (zone
, 2, gfc_default_character_kind
))
6458 if (!scalar_check (zone
, 2))
6460 if (!variable_check (zone
, 2, false))
6466 if (!type_check (values
, 3, BT_INTEGER
))
6468 if (!array_check (values
, 3))
6470 if (!rank_check (values
, 3, 1))
6472 if (!variable_check (values
, 3, false))
6481 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
6482 gfc_expr
*to
, gfc_expr
*topos
)
6484 if (!type_check (from
, 0, BT_INTEGER
))
6487 if (!type_check (frompos
, 1, BT_INTEGER
))
6490 if (!type_check (len
, 2, BT_INTEGER
))
6493 if (!same_type_check (from
, 0, to
, 3))
6496 if (!variable_check (to
, 3, false))
6499 if (!type_check (topos
, 4, BT_INTEGER
))
6502 if (!nonnegative_check ("frompos", frompos
))
6505 if (!nonnegative_check ("topos", topos
))
6508 if (!nonnegative_check ("len", len
))
6511 if (!less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
))
6514 if (!less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
))
6521 /* Check the arguments for RANDOM_INIT. */
6524 gfc_check_random_init (gfc_expr
*repeatable
, gfc_expr
*image_distinct
)
6526 if (!type_check (repeatable
, 0, BT_LOGICAL
))
6529 if (!scalar_check (repeatable
, 0))
6532 if (!type_check (image_distinct
, 1, BT_LOGICAL
))
6535 if (!scalar_check (image_distinct
, 1))
6543 gfc_check_random_number (gfc_expr
*harvest
)
6545 if (!type_check (harvest
, 0, BT_REAL
))
6548 if (!variable_check (harvest
, 0, false))
6556 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
6558 unsigned int nargs
= 0, seed_size
;
6559 locus
*where
= NULL
;
6560 mpz_t put_size
, get_size
;
6562 /* Keep the number of bytes in sync with master_state in
6563 libgfortran/intrinsics/random.c. */
6564 seed_size
= 32 / gfc_default_integer_kind
;
6568 if (size
->expr_type
!= EXPR_VARIABLE
6569 || !size
->symtree
->n
.sym
->attr
.optional
)
6572 if (!scalar_check (size
, 0))
6575 if (!type_check (size
, 0, BT_INTEGER
))
6578 if (!variable_check (size
, 0, false))
6581 if (!kind_value_check (size
, 0, gfc_default_integer_kind
))
6587 if (put
->expr_type
!= EXPR_VARIABLE
6588 || !put
->symtree
->n
.sym
->attr
.optional
)
6591 where
= &put
->where
;
6594 if (!array_check (put
, 1))
6597 if (!rank_check (put
, 1, 1))
6600 if (!type_check (put
, 1, BT_INTEGER
))
6603 if (!kind_value_check (put
, 1, gfc_default_integer_kind
))
6606 if (gfc_array_size (put
, &put_size
)
6607 && mpz_get_ui (put_size
) < seed_size
)
6608 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6609 "too small (%i/%i)",
6610 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
6611 where
, (int) mpz_get_ui (put_size
), seed_size
);
6616 if (get
->expr_type
!= EXPR_VARIABLE
6617 || !get
->symtree
->n
.sym
->attr
.optional
)
6620 where
= &get
->where
;
6623 if (!array_check (get
, 2))
6626 if (!rank_check (get
, 2, 1))
6629 if (!type_check (get
, 2, BT_INTEGER
))
6632 if (!variable_check (get
, 2, false))
6635 if (!kind_value_check (get
, 2, gfc_default_integer_kind
))
6638 if (gfc_array_size (get
, &get_size
)
6639 && mpz_get_ui (get_size
) < seed_size
)
6640 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6641 "too small (%i/%i)",
6642 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
6643 where
, (int) mpz_get_ui (get_size
), seed_size
);
6646 /* RANDOM_SEED may not have more than one non-optional argument. */
6648 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
6654 gfc_check_fe_runtime_error (gfc_actual_arglist
*a
)
6658 int num_percent
, nargs
;
6661 if (e
->expr_type
!= EXPR_CONSTANT
)
6664 len
= e
->value
.character
.length
;
6665 if (e
->value
.character
.string
[len
-1] != '\0')
6666 gfc_internal_error ("fe_runtime_error string must be null terminated");
6669 for (i
=0; i
<len
-1; i
++)
6670 if (e
->value
.character
.string
[i
] == '%')
6674 for (; a
; a
= a
->next
)
6677 if (nargs
-1 != num_percent
)
6678 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6679 nargs
, num_percent
++);
6685 gfc_check_second_sub (gfc_expr
*time
)
6687 if (!scalar_check (time
, 0))
6690 if (!type_check (time
, 0, BT_REAL
))
6693 if (!kind_value_check (time
, 0, 4))
6700 /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6701 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6702 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6703 count_max are all optional arguments */
6706 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
6707 gfc_expr
*count_max
)
6711 if (!scalar_check (count
, 0))
6714 if (!type_check (count
, 0, BT_INTEGER
))
6717 if (count
->ts
.kind
!= gfc_default_integer_kind
6718 && !gfc_notify_std (GFC_STD_F2003
, "COUNT argument to "
6719 "SYSTEM_CLOCK at %L has non-default kind",
6723 if (!variable_check (count
, 0, false))
6727 if (count_rate
!= NULL
)
6729 if (!scalar_check (count_rate
, 1))
6732 if (!variable_check (count_rate
, 1, false))
6735 if (count_rate
->ts
.type
== BT_REAL
)
6737 if (!gfc_notify_std (GFC_STD_F2003
, "Real COUNT_RATE argument to "
6738 "SYSTEM_CLOCK at %L", &count_rate
->where
))
6743 if (!type_check (count_rate
, 1, BT_INTEGER
))
6746 if (count_rate
->ts
.kind
!= gfc_default_integer_kind
6747 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_RATE argument to "
6748 "SYSTEM_CLOCK at %L has non-default kind",
6749 &count_rate
->where
))
6755 if (count_max
!= NULL
)
6757 if (!scalar_check (count_max
, 2))
6760 if (!type_check (count_max
, 2, BT_INTEGER
))
6763 if (count_max
->ts
.kind
!= gfc_default_integer_kind
6764 && !gfc_notify_std (GFC_STD_F2003
, "COUNT_MAX argument to "
6765 "SYSTEM_CLOCK at %L has non-default kind",
6769 if (!variable_check (count_max
, 2, false))
6778 gfc_check_irand (gfc_expr
*x
)
6783 if (!scalar_check (x
, 0))
6786 if (!type_check (x
, 0, BT_INTEGER
))
6789 if (!kind_value_check (x
, 0, 4))
6797 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
6799 if (!scalar_check (seconds
, 0))
6801 if (!type_check (seconds
, 0, BT_INTEGER
))
6804 if (!int_or_proc_check (handler
, 1))
6806 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
6812 if (!scalar_check (status
, 2))
6814 if (!type_check (status
, 2, BT_INTEGER
))
6816 if (!kind_value_check (status
, 2, gfc_default_integer_kind
))
6824 gfc_check_rand (gfc_expr
*x
)
6829 if (!scalar_check (x
, 0))
6832 if (!type_check (x
, 0, BT_INTEGER
))
6835 if (!kind_value_check (x
, 0, 4))
6843 gfc_check_srand (gfc_expr
*x
)
6845 if (!scalar_check (x
, 0))
6848 if (!type_check (x
, 0, BT_INTEGER
))
6851 if (!kind_value_check (x
, 0, 4))
6859 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
6861 if (!scalar_check (time
, 0))
6863 if (!type_check (time
, 0, BT_INTEGER
))
6866 if (!type_check (result
, 1, BT_CHARACTER
))
6868 if (!kind_value_check (result
, 1, gfc_default_character_kind
))
6876 gfc_check_dtime_etime (gfc_expr
*x
)
6878 if (!array_check (x
, 0))
6881 if (!rank_check (x
, 0, 1))
6884 if (!variable_check (x
, 0, false))
6887 if (!type_check (x
, 0, BT_REAL
))
6890 if (!kind_value_check (x
, 0, 4))
6898 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
6900 if (!array_check (values
, 0))
6903 if (!rank_check (values
, 0, 1))
6906 if (!variable_check (values
, 0, false))
6909 if (!type_check (values
, 0, BT_REAL
))
6912 if (!kind_value_check (values
, 0, 4))
6915 if (!scalar_check (time
, 1))
6918 if (!type_check (time
, 1, BT_REAL
))
6921 if (!kind_value_check (time
, 1, 4))
6929 gfc_check_fdate_sub (gfc_expr
*date
)
6931 if (!type_check (date
, 0, BT_CHARACTER
))
6933 if (!kind_value_check (date
, 0, gfc_default_character_kind
))
6941 gfc_check_gerror (gfc_expr
*msg
)
6943 if (!type_check (msg
, 0, BT_CHARACTER
))
6945 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
6953 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
6955 if (!type_check (cwd
, 0, BT_CHARACTER
))
6957 if (!kind_value_check (cwd
, 0, gfc_default_character_kind
))
6963 if (!scalar_check (status
, 1))
6966 if (!type_check (status
, 1, BT_INTEGER
))
6974 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
6976 if (!type_check (pos
, 0, BT_INTEGER
))
6979 if (pos
->ts
.kind
> gfc_default_integer_kind
)
6981 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
6982 "not wider than the default kind (%d)",
6983 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
6984 &pos
->where
, gfc_default_integer_kind
);
6988 if (!type_check (value
, 1, BT_CHARACTER
))
6990 if (!kind_value_check (value
, 1, gfc_default_character_kind
))
6998 gfc_check_getlog (gfc_expr
*msg
)
7000 if (!type_check (msg
, 0, BT_CHARACTER
))
7002 if (!kind_value_check (msg
, 0, gfc_default_character_kind
))
7010 gfc_check_exit (gfc_expr
*status
)
7015 if (!type_check (status
, 0, BT_INTEGER
))
7018 if (!scalar_check (status
, 0))
7026 gfc_check_flush (gfc_expr
*unit
)
7031 if (!type_check (unit
, 0, BT_INTEGER
))
7034 if (!scalar_check (unit
, 0))
7042 gfc_check_free (gfc_expr
*i
)
7044 if (!type_check (i
, 0, BT_INTEGER
))
7047 if (!scalar_check (i
, 0))
7055 gfc_check_hostnm (gfc_expr
*name
)
7057 if (!type_check (name
, 0, BT_CHARACTER
))
7059 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7067 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
7069 if (!type_check (name
, 0, BT_CHARACTER
))
7071 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7077 if (!scalar_check (status
, 1))
7080 if (!type_check (status
, 1, BT_INTEGER
))
7088 gfc_check_itime_idate (gfc_expr
*values
)
7090 if (!array_check (values
, 0))
7093 if (!rank_check (values
, 0, 1))
7096 if (!variable_check (values
, 0, false))
7099 if (!type_check (values
, 0, BT_INTEGER
))
7102 if (!kind_value_check (values
, 0, gfc_default_integer_kind
))
7110 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
7112 if (!type_check (time
, 0, BT_INTEGER
))
7115 if (!kind_value_check (time
, 0, gfc_default_integer_kind
))
7118 if (!scalar_check (time
, 0))
7121 if (!array_check (values
, 1))
7124 if (!rank_check (values
, 1, 1))
7127 if (!variable_check (values
, 1, false))
7130 if (!type_check (values
, 1, BT_INTEGER
))
7133 if (!kind_value_check (values
, 1, gfc_default_integer_kind
))
7141 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
7143 if (!scalar_check (unit
, 0))
7146 if (!type_check (unit
, 0, BT_INTEGER
))
7149 if (!type_check (name
, 1, BT_CHARACTER
))
7151 if (!kind_value_check (name
, 1, gfc_default_character_kind
))
7159 gfc_check_is_contiguous (gfc_expr
*array
)
7161 if (array
->expr_type
== EXPR_NULL
)
7163 gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7164 "associated pointer", &array
->where
, gfc_current_intrinsic
);
7168 if (!array_check (array
, 0))
7176 gfc_check_isatty (gfc_expr
*unit
)
7181 if (!type_check (unit
, 0, BT_INTEGER
))
7184 if (!scalar_check (unit
, 0))
7192 gfc_check_isnan (gfc_expr
*x
)
7194 if (!type_check (x
, 0, BT_REAL
))
7202 gfc_check_perror (gfc_expr
*string
)
7204 if (!type_check (string
, 0, BT_CHARACTER
))
7206 if (!kind_value_check (string
, 0, gfc_default_character_kind
))
7214 gfc_check_umask (gfc_expr
*mask
)
7216 if (!type_check (mask
, 0, BT_INTEGER
))
7219 if (!scalar_check (mask
, 0))
7227 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
7229 if (!type_check (mask
, 0, BT_INTEGER
))
7232 if (!scalar_check (mask
, 0))
7238 if (!scalar_check (old
, 1))
7241 if (!type_check (old
, 1, BT_INTEGER
))
7249 gfc_check_unlink (gfc_expr
*name
)
7251 if (!type_check (name
, 0, BT_CHARACTER
))
7253 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7261 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
7263 if (!type_check (name
, 0, BT_CHARACTER
))
7265 if (!kind_value_check (name
, 0, gfc_default_character_kind
))
7271 if (!scalar_check (status
, 1))
7274 if (!type_check (status
, 1, BT_INTEGER
))
7282 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
7284 if (!scalar_check (number
, 0))
7286 if (!type_check (number
, 0, BT_INTEGER
))
7289 if (!int_or_proc_check (handler
, 1))
7291 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7299 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
7301 if (!scalar_check (number
, 0))
7303 if (!type_check (number
, 0, BT_INTEGER
))
7306 if (!int_or_proc_check (handler
, 1))
7308 if (handler
->ts
.type
== BT_INTEGER
&& !scalar_check (handler
, 1))
7314 if (!type_check (status
, 2, BT_INTEGER
))
7316 if (!scalar_check (status
, 2))
7324 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
7326 if (!type_check (cmd
, 0, BT_CHARACTER
))
7328 if (!kind_value_check (cmd
, 0, gfc_default_character_kind
))
7331 if (!scalar_check (status
, 1))
7334 if (!type_check (status
, 1, BT_INTEGER
))
7337 if (!kind_value_check (status
, 1, gfc_default_integer_kind
))
7344 /* This is used for the GNU intrinsics AND, OR and XOR. */
7346 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
7348 if (i
->ts
.type
!= BT_INTEGER
7349 && i
->ts
.type
!= BT_LOGICAL
7350 && i
->ts
.type
!= BT_BOZ
)
7352 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7353 "LOGICAL, or a BOZ literal constant",
7354 gfc_current_intrinsic_arg
[0]->name
,
7355 gfc_current_intrinsic
, &i
->where
);
7359 if (j
->ts
.type
!= BT_INTEGER
7360 && j
->ts
.type
!= BT_LOGICAL
7361 && j
->ts
.type
!= BT_BOZ
)
7363 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7364 "LOGICAL, or a BOZ literal constant",
7365 gfc_current_intrinsic_arg
[1]->name
,
7366 gfc_current_intrinsic
, &j
->where
);
7370 /* i and j cannot both be BOZ literal constants. */
7371 if (!boz_args_check (i
, j
))
7374 /* If i is BOZ and j is integer, convert i to type of j. */
7375 if (i
->ts
.type
== BT_BOZ
)
7377 if (j
->ts
.type
!= BT_INTEGER
)
7379 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7380 gfc_current_intrinsic_arg
[1]->name
,
7381 gfc_current_intrinsic
, &j
->where
);
7385 if (!gfc_boz2int (i
, j
->ts
.kind
))
7389 /* If j is BOZ and i is integer, convert j to type of i. */
7390 if (j
->ts
.type
== BT_BOZ
)
7392 if (i
->ts
.type
!= BT_INTEGER
)
7394 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7395 gfc_current_intrinsic_arg
[0]->name
,
7396 gfc_current_intrinsic
, &j
->where
);
7400 if (!gfc_boz2int (j
, i
->ts
.kind
))
7404 if (!same_type_check (i
, 0, j
, 1, false))
7407 if (!scalar_check (i
, 0))
7410 if (!scalar_check (j
, 1))
7418 gfc_check_storage_size (gfc_expr
*a
, gfc_expr
*kind
)
7421 if (a
->expr_type
== EXPR_NULL
)
7423 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7424 "argument to STORAGE_SIZE, because it returns a "
7425 "disassociated pointer", &a
->where
);
7429 if (a
->ts
.type
== BT_ASSUMED
)
7431 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7432 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
7437 if (a
->ts
.type
== BT_PROCEDURE
)
7439 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7440 "procedure", gfc_current_intrinsic_arg
[0]->name
,
7441 gfc_current_intrinsic
, &a
->where
);
7445 if (a
->ts
.type
== BT_BOZ
&& illegal_boz_arg (a
))
7451 if (!type_check (kind
, 1, BT_INTEGER
))
7454 if (!scalar_check (kind
, 1))
7457 if (kind
->expr_type
!= EXPR_CONSTANT
)
7459 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7460 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,