2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* These functions check to see if an argument list is compatible with
24 a particular intrinsic function or subroutine. Presence of
25 required arguments has already been established, the argument list
26 has been sorted into the right order and has NULL arguments in the
27 correct places for missing optional arguments. */
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr
*e
, int n
)
46 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
54 /* Check the type of an expression. */
57 type_check (gfc_expr
*e
, int n
, bt type
)
59 if (e
->ts
.type
== type
)
62 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
64 &e
->where
, gfc_basic_typename (type
));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr
*e
, int n
)
75 if (gfc_numeric_ts (&e
->ts
))
78 /* If the expression has not got a type, check if its namespace can
79 offer a default type. */
80 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_VARIABLE
)
81 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
82 && gfc_set_default_type (e
->symtree
->n
.sym
, 0,
83 e
->symtree
->n
.sym
->ns
) == SUCCESS
84 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
86 e
->ts
= e
->symtree
->n
.sym
->ts
;
90 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
91 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
98 /* Check that an expression is integer or real. */
101 int_or_real_check (gfc_expr
*e
, int n
)
103 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
105 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
106 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
107 gfc_current_intrinsic
, &e
->where
);
115 /* Check that an expression is real or complex. */
118 real_or_complex_check (gfc_expr
*e
, int n
)
120 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
122 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
123 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
124 gfc_current_intrinsic
, &e
->where
);
132 /* Check that an expression is INTEGER or PROCEDURE. */
135 int_or_proc_check (gfc_expr
*e
, int n
)
137 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
139 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
140 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
141 gfc_current_intrinsic
, &e
->where
);
149 /* Check that the expression is an optional constant integer
150 and that it specifies a valid kind for that type. */
153 kind_check (gfc_expr
*k
, int n
, bt type
)
160 if (type_check (k
, n
, BT_INTEGER
) == FAILURE
)
163 if (scalar_check (k
, n
) == FAILURE
)
166 if (k
->expr_type
!= EXPR_CONSTANT
)
168 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
169 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
174 if (gfc_extract_int (k
, &kind
) != NULL
175 || gfc_validate_kind (type
, kind
, true) < 0)
177 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
186 /* Make sure the expression is a double precision real. */
189 double_check (gfc_expr
*d
, int n
)
191 if (type_check (d
, n
, BT_REAL
) == FAILURE
)
194 if (d
->ts
.kind
!= gfc_default_double_kind
)
196 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
197 "precision", gfc_current_intrinsic_arg
[n
]->name
,
198 gfc_current_intrinsic
, &d
->where
);
207 coarray_check (gfc_expr
*e
, int n
)
209 if (!gfc_is_coarray (e
))
211 gfc_error ("Expected coarray variable as '%s' argument to the %s "
212 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
213 gfc_current_intrinsic
, &e
->where
);
221 /* Make sure the expression is a logical array. */
224 logical_array_check (gfc_expr
*array
, int n
)
226 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
228 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
229 "array", gfc_current_intrinsic_arg
[n
]->name
,
230 gfc_current_intrinsic
, &array
->where
);
238 /* Make sure an expression is an array. */
241 array_check (gfc_expr
*e
, int n
)
246 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
247 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
254 /* If expr is a constant, then check to ensure that it is greater than
258 nonnegative_check (const char *arg
, gfc_expr
*expr
)
262 if (expr
->expr_type
== EXPR_CONSTANT
)
264 gfc_extract_int (expr
, &i
);
267 gfc_error ("'%s' at %L must be nonnegative", arg
, &expr
->where
);
276 /* If expr2 is constant, then check that the value is less than
277 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
280 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
281 gfc_expr
*expr2
, bool or_equal
)
285 if (expr2
->expr_type
== EXPR_CONSTANT
)
287 gfc_extract_int (expr2
, &i2
);
288 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
290 /* For ISHFT[C], check that |shift| <= bit_size(i). */
296 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
298 gfc_error ("The absolute value of SHIFT at %L must be less "
299 "than or equal to BIT_SIZE('%s')",
300 &expr2
->where
, arg1
);
307 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
309 gfc_error ("'%s' at %L must be less than "
310 "or equal to BIT_SIZE('%s')",
311 arg2
, &expr2
->where
, arg1
);
317 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
319 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
320 arg2
, &expr2
->where
, arg1
);
330 /* If expr is constant, then check that the value is less than or equal
331 to the bit_size of the kind k. */
334 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
338 if (expr
->expr_type
!= EXPR_CONSTANT
)
341 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
342 gfc_extract_int (expr
, &val
);
344 if (val
> gfc_integer_kinds
[i
].bit_size
)
346 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
347 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
355 /* If expr2 and expr3 are constants, then check that the value is less than
356 or equal to bit_size(expr1). */
359 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
360 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
364 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
366 gfc_extract_int (expr2
, &i2
);
367 gfc_extract_int (expr3
, &i3
);
369 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
370 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
372 gfc_error ("'%s + %s' at %L must be less than or equal "
374 arg2
, arg3
, &expr2
->where
, arg1
);
382 /* Make sure two expressions have the same type. */
385 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
387 if (gfc_compare_types (&e
->ts
, &f
->ts
))
390 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
391 "and kind as '%s'", gfc_current_intrinsic_arg
[m
]->name
,
392 gfc_current_intrinsic
, &f
->where
,
393 gfc_current_intrinsic_arg
[n
]->name
);
399 /* Make sure that an expression has a certain (nonzero) rank. */
402 rank_check (gfc_expr
*e
, int n
, int rank
)
407 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
408 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
415 /* Make sure a variable expression is not an optional dummy argument. */
418 nonoptional_check (gfc_expr
*e
, int n
)
420 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
422 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
423 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
427 /* TODO: Recursive check on nonoptional variables? */
433 /* Check for ALLOCATABLE attribute. */
436 allocatable_check (gfc_expr
*e
, int n
)
438 symbol_attribute attr
;
440 attr
= gfc_variable_attr (e
, NULL
);
441 if (!attr
.allocatable
)
443 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
444 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
453 /* Check that an expression has a particular kind. */
456 kind_value_check (gfc_expr
*e
, int n
, int k
)
461 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
462 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
469 /* Make sure an expression is a variable. */
472 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
474 if (e
->expr_type
== EXPR_VARIABLE
475 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
476 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
477 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
479 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
480 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
485 if (e
->expr_type
== EXPR_VARIABLE
486 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
488 || !e
->symtree
->n
.sym
->attr
.function
489 || (e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
490 && (e
->symtree
->n
.sym
== gfc_current_ns
->proc_name
491 || (gfc_current_ns
->parent
493 == gfc_current_ns
->parent
->proc_name
)))))
496 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
497 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
503 /* Check the common DIM parameter for correctness. */
506 dim_check (gfc_expr
*dim
, int n
, bool optional
)
511 if (type_check (dim
, n
, BT_INTEGER
) == FAILURE
)
514 if (scalar_check (dim
, n
) == FAILURE
)
517 if (!optional
&& nonoptional_check (dim
, n
) == FAILURE
)
524 /* If a coarray DIM parameter is a constant, make sure that it is greater than
525 zero and less than or equal to the corank of the given array. */
528 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
532 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
534 if (dim
->expr_type
!= EXPR_CONSTANT
)
537 corank
= gfc_get_corank (array
);
539 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
540 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
542 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
543 "codimension index", gfc_current_intrinsic
, &dim
->where
);
552 /* If a DIM parameter is a constant, make sure that it is greater than
553 zero and less than or equal to the rank of the given array. If
554 allow_assumed is zero then dim must be less than the rank of the array
555 for assumed size arrays. */
558 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
566 if (dim
->expr_type
!= EXPR_CONSTANT
)
569 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
570 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
571 rank
= array
->rank
+ 1;
575 if (array
->expr_type
== EXPR_VARIABLE
)
577 ar
= gfc_find_array_ref (array
);
578 if (ar
->as
->type
== AS_ASSUMED_SIZE
580 && ar
->type
!= AR_ELEMENT
581 && ar
->type
!= AR_SECTION
)
585 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
586 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
588 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
589 "dimension index", gfc_current_intrinsic
, &dim
->where
);
598 /* Compare the size of a along dimension ai with the size of b along
599 dimension bi, returning 0 if they are known not to be identical,
600 and 1 if they are identical, or if this cannot be determined. */
603 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
605 mpz_t a_size
, b_size
;
608 gcc_assert (a
->rank
> ai
);
609 gcc_assert (b
->rank
> bi
);
613 if (gfc_array_dimen_size (a
, ai
, &a_size
) == SUCCESS
)
615 if (gfc_array_dimen_size (b
, bi
, &b_size
) == SUCCESS
)
617 if (mpz_cmp (a_size
, b_size
) != 0)
627 /* Calculate the length of a character variable, including substrings.
628 Strip away parentheses if necessary. Return -1 if no length could
632 gfc_var_strlen (const gfc_expr
*a
)
636 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
639 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
646 if (ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
647 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
649 start_a
= mpz_get_si (ra
->u
.ss
.start
->value
.integer
);
650 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
651 return end_a
- start_a
+ 1;
653 else if (gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
659 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
660 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
661 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
662 else if (a
->expr_type
== EXPR_CONSTANT
663 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
664 return a
->value
.character
.length
;
670 /* Check whether two character expressions have the same length;
671 returns SUCCESS if they have or if the length cannot be determined,
672 otherwise return FAILURE and raise a gfc_error. */
675 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
679 len_a
= gfc_var_strlen(a
);
680 len_b
= gfc_var_strlen(b
);
682 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
686 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
687 len_a
, len_b
, name
, &a
->where
);
693 /***** Check functions *****/
695 /* Check subroutine suitable for intrinsics taking a real argument and
696 a kind argument for the result. */
699 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
701 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
703 if (kind_check (kind
, 1, type
) == FAILURE
)
710 /* Check subroutine suitable for ceiling, floor and nint. */
713 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
715 return check_a_kind (a
, kind
, BT_INTEGER
);
719 /* Check subroutine suitable for aint, anint. */
722 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
724 return check_a_kind (a
, kind
, BT_REAL
);
729 gfc_check_abs (gfc_expr
*a
)
731 if (numeric_check (a
, 0) == FAILURE
)
739 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
741 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
743 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
751 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
753 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
754 || scalar_check (name
, 0) == FAILURE
)
756 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
759 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
760 || scalar_check (mode
, 1) == FAILURE
)
762 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
770 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
772 if (logical_array_check (mask
, 0) == FAILURE
)
775 if (dim_check (dim
, 1, false) == FAILURE
)
778 if (dim_rank_check (dim
, mask
, 0) == FAILURE
)
786 gfc_check_allocated (gfc_expr
*array
)
788 if (variable_check (array
, 0, false) == FAILURE
)
790 if (allocatable_check (array
, 0) == FAILURE
)
797 /* Common check function where the first argument must be real or
798 integer and the second argument must be the same as the first. */
801 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
803 if (int_or_real_check (a
, 0) == FAILURE
)
806 if (a
->ts
.type
!= p
->ts
.type
)
808 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
809 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
810 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
815 if (a
->ts
.kind
!= p
->ts
.kind
)
817 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
818 &p
->where
) == FAILURE
)
827 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
829 if (double_check (x
, 0) == FAILURE
|| double_check (y
, 1) == FAILURE
)
837 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
839 symbol_attribute attr1
, attr2
;
844 where
= &pointer
->where
;
846 if (pointer
->expr_type
== EXPR_VARIABLE
|| pointer
->expr_type
== EXPR_FUNCTION
)
847 attr1
= gfc_expr_attr (pointer
);
848 else if (pointer
->expr_type
== EXPR_NULL
)
851 gcc_assert (0); /* Pointer must be a variable or a function. */
853 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
855 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
856 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
862 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
864 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
865 "conindexed", gfc_current_intrinsic_arg
[0]->name
,
866 gfc_current_intrinsic
, &pointer
->where
);
870 /* Target argument is optional. */
874 where
= &target
->where
;
875 if (target
->expr_type
== EXPR_NULL
)
878 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
879 attr2
= gfc_expr_attr (target
);
882 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
883 "or target VARIABLE or FUNCTION",
884 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
889 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
891 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
892 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
893 gfc_current_intrinsic
, &target
->where
);
898 if (attr1
.pointer
&& gfc_is_coindexed (target
))
900 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
901 "conindexed", gfc_current_intrinsic_arg
[1]->name
,
902 gfc_current_intrinsic
, &target
->where
);
907 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
909 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
911 if (target
->rank
> 0)
913 for (i
= 0; i
< target
->rank
; i
++)
914 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
916 gfc_error ("Array section with a vector subscript at %L shall not "
917 "be the target of a pointer",
927 gfc_error ("NULL pointer at %L is not permitted as actual argument "
928 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
935 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
937 /* gfc_notify_std would be a wast of time as the return value
938 is seemingly used only for the generic resolution. The error
939 will be: Too many arguments. */
940 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
943 return gfc_check_atan2 (y
, x
);
948 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
950 if (type_check (y
, 0, BT_REAL
) == FAILURE
)
952 if (same_type_check (y
, 0, x
, 1) == FAILURE
)
960 gfc_check_atomic (gfc_expr
*atom
, gfc_expr
*value
)
962 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
963 && !(atom
->ts
.type
== BT_LOGICAL
964 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
966 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
967 "integer of ATOMIC_INT_KIND or a logical of "
968 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
972 if (!gfc_expr_attr (atom
).codimension
)
974 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
975 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
979 if (atom
->ts
.type
!= value
->ts
.type
)
981 gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
982 "have the same type at %L", gfc_current_intrinsic
,
992 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
)
994 if (scalar_check (atom
, 0) == FAILURE
|| scalar_check (value
, 1) == FAILURE
)
997 if (gfc_check_vardef_context (atom
, false, false, NULL
) == FAILURE
)
999 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1000 "definable", gfc_current_intrinsic
, &atom
->where
);
1004 return gfc_check_atomic (atom
, value
);
1009 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
)
1011 if (scalar_check (value
, 0) == FAILURE
|| scalar_check (atom
, 1) == FAILURE
)
1014 if (gfc_check_vardef_context (value
, false, false, NULL
) == FAILURE
)
1016 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1017 "definable", gfc_current_intrinsic
, &value
->where
);
1021 return gfc_check_atomic (atom
, value
);
1025 /* BESJN and BESYN functions. */
1028 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1030 if (type_check (n
, 0, BT_INTEGER
) == FAILURE
)
1032 if (n
->expr_type
== EXPR_CONSTANT
)
1035 gfc_extract_int (n
, &i
);
1036 if (i
< 0 && gfc_notify_std (GFC_STD_GNU
, "Extension: Negative argument "
1037 "N at %L", &n
->where
) == FAILURE
)
1041 if (type_check (x
, 1, BT_REAL
) == FAILURE
)
1048 /* Transformational version of the Bessel JN and YN functions. */
1051 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1053 if (type_check (n1
, 0, BT_INTEGER
) == FAILURE
)
1055 if (scalar_check (n1
, 0) == FAILURE
)
1057 if (nonnegative_check("N1", n1
) == FAILURE
)
1060 if (type_check (n2
, 1, BT_INTEGER
) == FAILURE
)
1062 if (scalar_check (n2
, 1) == FAILURE
)
1064 if (nonnegative_check("N2", n2
) == FAILURE
)
1067 if (type_check (x
, 2, BT_REAL
) == FAILURE
)
1069 if (scalar_check (x
, 2) == FAILURE
)
1077 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1079 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1082 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1090 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1092 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1095 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1098 if (nonnegative_check ("pos", pos
) == FAILURE
)
1101 if (less_than_bitsize1 ("i", i
, "pos", pos
, false) == FAILURE
)
1109 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1111 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1113 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
1121 gfc_check_chdir (gfc_expr
*dir
)
1123 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
1125 if (kind_value_check (dir
, 0, gfc_default_character_kind
) == FAILURE
)
1133 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1135 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
1137 if (kind_value_check (dir
, 0, gfc_default_character_kind
) == FAILURE
)
1143 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
1145 if (scalar_check (status
, 1) == FAILURE
)
1153 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1155 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
1157 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
1160 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
1162 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
1170 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1172 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
1174 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
1177 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
1179 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
1185 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1188 if (scalar_check (status
, 2) == FAILURE
)
1196 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1198 if (numeric_check (x
, 0) == FAILURE
)
1203 if (numeric_check (y
, 1) == FAILURE
)
1206 if (x
->ts
.type
== BT_COMPLEX
)
1208 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1209 "present if 'x' is COMPLEX",
1210 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1215 if (y
->ts
.type
== BT_COMPLEX
)
1217 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1218 "of either REAL or INTEGER",
1219 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1226 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
1234 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1236 if (int_or_real_check (x
, 0) == FAILURE
)
1238 if (scalar_check (x
, 0) == FAILURE
)
1241 if (int_or_real_check (y
, 1) == FAILURE
)
1243 if (scalar_check (y
, 1) == FAILURE
)
1251 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1253 if (logical_array_check (mask
, 0) == FAILURE
)
1255 if (dim_check (dim
, 1, false) == FAILURE
)
1257 if (dim_rank_check (dim
, mask
, 0) == FAILURE
)
1259 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
1261 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1262 "with KIND argument at %L",
1263 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1271 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1273 if (array_check (array
, 0) == FAILURE
)
1276 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1279 if (dim_check (dim
, 2, true) == FAILURE
)
1282 if (dim_rank_check (dim
, array
, false) == FAILURE
)
1285 if (array
->rank
== 1 || shift
->rank
== 0)
1287 if (scalar_check (shift
, 1) == FAILURE
)
1290 else if (shift
->rank
== array
->rank
- 1)
1295 else if (dim
->expr_type
== EXPR_CONSTANT
)
1296 gfc_extract_int (dim
, &d
);
1303 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1306 if (!identical_dimen_shape (array
, i
, shift
, j
))
1308 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1309 "invalid shape in dimension %d (%ld/%ld)",
1310 gfc_current_intrinsic_arg
[1]->name
,
1311 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1312 mpz_get_si (array
->shape
[i
]),
1313 mpz_get_si (shift
->shape
[j
]));
1323 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1324 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1325 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1334 gfc_check_ctime (gfc_expr
*time
)
1336 if (scalar_check (time
, 0) == FAILURE
)
1339 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
1346 gfc_try
gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1348 if (double_check (y
, 0) == FAILURE
|| double_check (x
, 1) == FAILURE
)
1355 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1357 if (numeric_check (x
, 0) == FAILURE
)
1362 if (numeric_check (y
, 1) == FAILURE
)
1365 if (x
->ts
.type
== BT_COMPLEX
)
1367 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1368 "present if 'x' is COMPLEX",
1369 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1374 if (y
->ts
.type
== BT_COMPLEX
)
1376 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1377 "of either REAL or INTEGER",
1378 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1389 gfc_check_dble (gfc_expr
*x
)
1391 if (numeric_check (x
, 0) == FAILURE
)
1399 gfc_check_digits (gfc_expr
*x
)
1401 if (int_or_real_check (x
, 0) == FAILURE
)
1409 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1411 switch (vector_a
->ts
.type
)
1414 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
1421 if (numeric_check (vector_b
, 1) == FAILURE
)
1426 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1427 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1428 gfc_current_intrinsic
, &vector_a
->where
);
1432 if (rank_check (vector_a
, 0, 1) == FAILURE
)
1435 if (rank_check (vector_b
, 1, 1) == FAILURE
)
1438 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1440 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1441 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0]->name
,
1442 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1451 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1453 if (type_check (x
, 0, BT_REAL
) == FAILURE
1454 || type_check (y
, 1, BT_REAL
) == FAILURE
)
1457 if (x
->ts
.kind
!= gfc_default_real_kind
)
1459 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1460 "real", gfc_current_intrinsic_arg
[0]->name
,
1461 gfc_current_intrinsic
, &x
->where
);
1465 if (y
->ts
.kind
!= gfc_default_real_kind
)
1467 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1468 "real", gfc_current_intrinsic_arg
[1]->name
,
1469 gfc_current_intrinsic
, &y
->where
);
1478 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1480 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1483 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1486 if (same_type_check (i
, 0, j
, 1) == FAILURE
)
1489 if (type_check (shift
, 2, BT_INTEGER
) == FAILURE
)
1492 if (nonnegative_check ("SHIFT", shift
) == FAILURE
)
1495 if (less_than_bitsize1 ("I", i
, "SHIFT", shift
, true) == FAILURE
)
1503 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1506 if (array_check (array
, 0) == FAILURE
)
1509 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1512 if (dim_check (dim
, 3, true) == FAILURE
)
1515 if (dim_rank_check (dim
, array
, false) == FAILURE
)
1518 if (array
->rank
== 1 || shift
->rank
== 0)
1520 if (scalar_check (shift
, 1) == FAILURE
)
1523 else if (shift
->rank
== array
->rank
- 1)
1528 else if (dim
->expr_type
== EXPR_CONSTANT
)
1529 gfc_extract_int (dim
, &d
);
1536 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1539 if (!identical_dimen_shape (array
, i
, shift
, j
))
1541 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1542 "invalid shape in dimension %d (%ld/%ld)",
1543 gfc_current_intrinsic_arg
[1]->name
,
1544 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1545 mpz_get_si (array
->shape
[i
]),
1546 mpz_get_si (shift
->shape
[j
]));
1556 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1557 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1558 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1562 if (boundary
!= NULL
)
1564 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
1567 if (array
->rank
== 1 || boundary
->rank
== 0)
1569 if (scalar_check (boundary
, 2) == FAILURE
)
1572 else if (boundary
->rank
== array
->rank
- 1)
1574 if (gfc_check_conformance (shift
, boundary
,
1575 "arguments '%s' and '%s' for "
1577 gfc_current_intrinsic_arg
[1]->name
,
1578 gfc_current_intrinsic_arg
[2]->name
,
1579 gfc_current_intrinsic
) == FAILURE
)
1584 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1585 "rank %d or be a scalar",
1586 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1587 &shift
->where
, array
->rank
- 1);
1596 gfc_check_float (gfc_expr
*a
)
1598 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
1601 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
1602 && gfc_notify_std (GFC_STD_GNU
, "GNU extension: non-default INTEGER "
1603 "kind argument to %s intrinsic at %L",
1604 gfc_current_intrinsic
, &a
->where
) == FAILURE
)
1610 /* A single complex argument. */
1613 gfc_check_fn_c (gfc_expr
*a
)
1615 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
1621 /* A single real argument. */
1624 gfc_check_fn_r (gfc_expr
*a
)
1626 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
1632 /* A single double argument. */
1635 gfc_check_fn_d (gfc_expr
*a
)
1637 if (double_check (a
, 0) == FAILURE
)
1643 /* A single real or complex argument. */
1646 gfc_check_fn_rc (gfc_expr
*a
)
1648 if (real_or_complex_check (a
, 0) == FAILURE
)
1656 gfc_check_fn_rc2008 (gfc_expr
*a
)
1658 if (real_or_complex_check (a
, 0) == FAILURE
)
1661 if (a
->ts
.type
== BT_COMPLEX
1662 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: COMPLEX argument '%s' "
1663 "argument of '%s' intrinsic at %L",
1664 gfc_current_intrinsic_arg
[0]->name
,
1665 gfc_current_intrinsic
, &a
->where
) == FAILURE
)
1673 gfc_check_fnum (gfc_expr
*unit
)
1675 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1678 if (scalar_check (unit
, 0) == FAILURE
)
1686 gfc_check_huge (gfc_expr
*x
)
1688 if (int_or_real_check (x
, 0) == FAILURE
)
1696 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
1698 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1700 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1707 /* Check that the single argument is an integer. */
1710 gfc_check_i (gfc_expr
*i
)
1712 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1720 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1722 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1725 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1728 if (i
->ts
.kind
!= j
->ts
.kind
)
1730 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1731 &i
->where
) == FAILURE
)
1740 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1742 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1745 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1748 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1751 if (nonnegative_check ("pos", pos
) == FAILURE
)
1754 if (nonnegative_check ("len", len
) == FAILURE
)
1757 if (less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
) == FAILURE
)
1765 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1769 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
1772 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1775 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1776 "with KIND argument at %L",
1777 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1780 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1786 /* Substring references don't have the charlength set. */
1788 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1791 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1795 /* Check that the argument is length one. Non-constant lengths
1796 can't be checked here, so assume they are ok. */
1797 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
1799 /* If we already have a length for this expression then use it. */
1800 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1802 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1809 start
= ref
->u
.ss
.start
;
1810 end
= ref
->u
.ss
.end
;
1813 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1814 || start
->expr_type
!= EXPR_CONSTANT
)
1817 i
= mpz_get_si (end
->value
.integer
) + 1
1818 - mpz_get_si (start
->value
.integer
);
1826 gfc_error ("Argument of %s at %L must be of length one",
1827 gfc_current_intrinsic
, &c
->where
);
1836 gfc_check_idnint (gfc_expr
*a
)
1838 if (double_check (a
, 0) == FAILURE
)
1846 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
1848 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1851 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1854 if (i
->ts
.kind
!= j
->ts
.kind
)
1856 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1857 &i
->where
) == FAILURE
)
1866 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
1869 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1870 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1873 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1876 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
1878 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
1879 "with KIND argument at %L",
1880 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1883 if (string
->ts
.kind
!= substring
->ts
.kind
)
1885 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1886 "kind as '%s'", gfc_current_intrinsic_arg
[1]->name
,
1887 gfc_current_intrinsic
, &substring
->where
,
1888 gfc_current_intrinsic_arg
[0]->name
);
1897 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
1899 if (numeric_check (x
, 0) == FAILURE
)
1902 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1910 gfc_check_intconv (gfc_expr
*x
)
1912 if (numeric_check (x
, 0) == FAILURE
)
1920 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
1922 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1925 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1928 if (i
->ts
.kind
!= j
->ts
.kind
)
1930 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type kinds at %L",
1931 &i
->where
) == FAILURE
)
1940 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
1942 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1943 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1946 if (less_than_bitsize1 ("I", i
, NULL
, shift
, true) == FAILURE
)
1954 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1956 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
1957 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1964 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
1967 if (less_than_bitsize1 ("I", i
, "SIZE", size
, true) == FAILURE
)
1970 if (size
->expr_type
== EXPR_CONSTANT
)
1972 gfc_extract_int (size
, &i3
);
1975 gfc_error ("SIZE at %L must be positive", &size
->where
);
1979 if (shift
->expr_type
== EXPR_CONSTANT
)
1981 gfc_extract_int (shift
, &i2
);
1987 gfc_error ("The absolute value of SHIFT at %L must be less "
1988 "than or equal to SIZE at %L", &shift
->where
,
1995 else if (less_than_bitsize1 ("I", i
, NULL
, shift
, true) == FAILURE
)
2003 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2005 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
2008 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
2016 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2018 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
2021 if (scalar_check (pid
, 0) == FAILURE
)
2024 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
2027 if (scalar_check (sig
, 1) == FAILURE
)
2033 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2036 if (scalar_check (status
, 2) == FAILURE
)
2044 gfc_check_kind (gfc_expr
*x
)
2046 if (x
->ts
.type
== BT_DERIVED
)
2048 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2049 "non-derived type", gfc_current_intrinsic_arg
[0]->name
,
2050 gfc_current_intrinsic
, &x
->where
);
2059 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2061 if (array_check (array
, 0) == FAILURE
)
2064 if (dim_check (dim
, 1, false) == FAILURE
)
2067 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
2070 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2072 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2073 "with KIND argument at %L",
2074 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2082 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2084 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2086 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2090 if (coarray_check (coarray
, 0) == FAILURE
)
2095 if (dim_check (dim
, 1, false) == FAILURE
)
2098 if (dim_corank_check (dim
, coarray
) == FAILURE
)
2102 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2110 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2112 if (type_check (s
, 0, BT_CHARACTER
) == FAILURE
)
2115 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
2117 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2118 "with KIND argument at %L",
2119 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2127 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2129 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
2131 if (kind_value_check (a
, 0, gfc_default_character_kind
) == FAILURE
)
2134 if (type_check (b
, 1, BT_CHARACTER
) == FAILURE
)
2136 if (kind_value_check (b
, 1, gfc_default_character_kind
) == FAILURE
)
2144 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2146 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2148 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2151 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2153 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2161 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2163 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2165 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2168 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2170 if (kind_value_check (path2
, 0, gfc_default_character_kind
) == FAILURE
)
2176 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2179 if (scalar_check (status
, 2) == FAILURE
)
2187 gfc_check_loc (gfc_expr
*expr
)
2189 return variable_check (expr
, 0, true);
2194 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2196 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2198 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2201 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2203 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2211 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2213 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2215 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2218 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2220 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2226 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2229 if (scalar_check (status
, 2) == FAILURE
)
2237 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2239 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
2241 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
2248 /* Min/max family. */
2251 min_max_args (gfc_actual_arglist
*arg
)
2253 if (arg
== NULL
|| arg
->next
== NULL
)
2255 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2256 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2265 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2267 gfc_actual_arglist
*arg
, *tmp
;
2272 if (min_max_args (arglist
) == FAILURE
)
2275 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2278 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2280 if (x
->ts
.type
== type
)
2282 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Different type "
2283 "kinds at %L", &x
->where
) == FAILURE
)
2288 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2289 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2290 gfc_basic_typename (type
), kind
);
2295 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2296 if (gfc_check_conformance (tmp
->expr
, x
,
2297 "arguments 'a%d' and 'a%d' for "
2298 "intrinsic '%s'", m
, n
,
2299 gfc_current_intrinsic
) == FAILURE
)
2308 gfc_check_min_max (gfc_actual_arglist
*arg
)
2312 if (min_max_args (arg
) == FAILURE
)
2317 if (x
->ts
.type
== BT_CHARACTER
)
2319 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
2320 "with CHARACTER argument at %L",
2321 gfc_current_intrinsic
, &x
->where
) == FAILURE
)
2324 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2326 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2327 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2331 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2336 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2338 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2343 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2345 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2350 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2352 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2356 /* End of min/max family. */
2359 gfc_check_malloc (gfc_expr
*size
)
2361 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
2364 if (scalar_check (size
, 0) == FAILURE
)
2372 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2374 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2376 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2377 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2378 gfc_current_intrinsic
, &matrix_a
->where
);
2382 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2384 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2385 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2386 gfc_current_intrinsic
, &matrix_b
->where
);
2390 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2391 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2393 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2394 gfc_current_intrinsic
, &matrix_a
->where
,
2395 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2399 switch (matrix_a
->rank
)
2402 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
2404 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2405 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2407 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2408 "and '%s' at %L for intrinsic matmul",
2409 gfc_current_intrinsic_arg
[0]->name
,
2410 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2416 if (matrix_b
->rank
!= 2)
2418 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
2421 /* matrix_b has rank 1 or 2 here. Common check for the cases
2422 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2423 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2424 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2426 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2427 "dimension 1 for argument '%s' at %L for intrinsic "
2428 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2429 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2435 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2436 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
2437 gfc_current_intrinsic
, &matrix_a
->where
);
2445 /* Whoever came up with this interface was probably on something.
2446 The possibilities for the occupation of the second and third
2453 NULL MASK minloc(array, mask=m)
2456 I.e. in the case of minloc(array,mask), mask will be in the second
2457 position of the argument list and we'll have to fix that up. */
2460 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
2462 gfc_expr
*a
, *m
, *d
;
2465 if (int_or_real_check (a
, 0) == FAILURE
|| array_check (a
, 0) == FAILURE
)
2469 m
= ap
->next
->next
->expr
;
2471 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2472 && ap
->next
->name
== NULL
)
2476 ap
->next
->expr
= NULL
;
2477 ap
->next
->next
->expr
= m
;
2480 if (dim_check (d
, 1, false) == FAILURE
)
2483 if (dim_rank_check (d
, a
, 0) == FAILURE
)
2486 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
2490 && gfc_check_conformance (a
, m
,
2491 "arguments '%s' and '%s' for intrinsic %s",
2492 gfc_current_intrinsic_arg
[0]->name
,
2493 gfc_current_intrinsic_arg
[2]->name
,
2494 gfc_current_intrinsic
) == FAILURE
)
2501 /* Similar to minloc/maxloc, the argument list might need to be
2502 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2503 difference is that MINLOC/MAXLOC take an additional KIND argument.
2504 The possibilities are:
2510 NULL MASK minval(array, mask=m)
2513 I.e. in the case of minval(array,mask), mask will be in the second
2514 position of the argument list and we'll have to fix that up. */
2517 check_reduction (gfc_actual_arglist
*ap
)
2519 gfc_expr
*a
, *m
, *d
;
2523 m
= ap
->next
->next
->expr
;
2525 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2526 && ap
->next
->name
== NULL
)
2530 ap
->next
->expr
= NULL
;
2531 ap
->next
->next
->expr
= m
;
2534 if (dim_check (d
, 1, false) == FAILURE
)
2537 if (dim_rank_check (d
, a
, 0) == FAILURE
)
2540 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
2544 && gfc_check_conformance (a
, m
,
2545 "arguments '%s' and '%s' for intrinsic %s",
2546 gfc_current_intrinsic_arg
[0]->name
,
2547 gfc_current_intrinsic_arg
[2]->name
,
2548 gfc_current_intrinsic
) == FAILURE
)
2556 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
2558 if (int_or_real_check (ap
->expr
, 0) == FAILURE
2559 || array_check (ap
->expr
, 0) == FAILURE
)
2562 return check_reduction (ap
);
2567 gfc_check_product_sum (gfc_actual_arglist
*ap
)
2569 if (numeric_check (ap
->expr
, 0) == FAILURE
2570 || array_check (ap
->expr
, 0) == FAILURE
)
2573 return check_reduction (ap
);
2577 /* For IANY, IALL and IPARITY. */
2580 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
2584 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
2587 if (nonnegative_check ("I", i
) == FAILURE
)
2590 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
2594 gfc_extract_int (kind
, &k
);
2596 k
= gfc_default_integer_kind
;
2598 if (less_than_bitsizekind ("I", i
, k
) == FAILURE
)
2606 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
2608 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
2610 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2611 gfc_current_intrinsic_arg
[0]->name
,
2612 gfc_current_intrinsic
, &ap
->expr
->where
);
2616 if (array_check (ap
->expr
, 0) == FAILURE
)
2619 return check_reduction (ap
);
2624 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
2626 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
2629 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
2632 if (tsource
->ts
.type
== BT_CHARACTER
)
2633 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
2640 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
2642 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
2645 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
2648 if (type_check (mask
, 2, BT_INTEGER
) == FAILURE
)
2651 if (same_type_check (i
, 0, j
, 1) == FAILURE
)
2654 if (same_type_check (i
, 0, mask
, 2) == FAILURE
)
2662 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
2664 if (variable_check (from
, 0, false) == FAILURE
)
2666 if (allocatable_check (from
, 0) == FAILURE
)
2669 if (variable_check (to
, 1, false) == FAILURE
)
2671 if (allocatable_check (to
, 1) == FAILURE
)
2674 if (same_type_check (to
, 1, from
, 0) == FAILURE
)
2677 if (to
->rank
!= from
->rank
)
2679 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2680 "have the same rank %d/%d", gfc_current_intrinsic_arg
[0]->name
,
2681 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2682 &to
->where
, from
->rank
, to
->rank
);
2686 if (to
->ts
.kind
!= from
->ts
.kind
)
2688 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2689 "be of the same kind %d/%d",
2690 gfc_current_intrinsic_arg
[0]->name
,
2691 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
2692 &to
->where
, from
->ts
.kind
, to
->ts
.kind
);
2696 /* CLASS arguments: Make sure the vtab is present. */
2697 if (to
->ts
.type
== BT_CLASS
)
2698 gfc_find_derived_vtab (from
->ts
.u
.derived
);
2705 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
2707 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2710 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
2718 gfc_check_new_line (gfc_expr
*a
)
2720 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
2728 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
2730 if (type_check (array
, 0, BT_REAL
) == FAILURE
)
2733 if (array_check (array
, 0) == FAILURE
)
2736 if (dim_rank_check (dim
, array
, false) == FAILURE
)
2743 gfc_check_null (gfc_expr
*mold
)
2745 symbol_attribute attr
;
2750 if (variable_check (mold
, 0, true) == FAILURE
)
2753 attr
= gfc_variable_attr (mold
, NULL
);
2755 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
2757 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2758 "ALLOCATABLE or procedure pointer",
2759 gfc_current_intrinsic_arg
[0]->name
,
2760 gfc_current_intrinsic
, &mold
->where
);
2764 if (attr
.allocatable
2765 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NULL intrinsic with "
2766 "allocatable MOLD at %L", &mold
->where
) == FAILURE
)
2770 if (gfc_is_coindexed (mold
))
2772 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2773 "conindexed", gfc_current_intrinsic_arg
[0]->name
,
2774 gfc_current_intrinsic
, &mold
->where
);
2783 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
2785 if (array_check (array
, 0) == FAILURE
)
2788 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2791 if (gfc_check_conformance (array
, mask
,
2792 "arguments '%s' and '%s' for intrinsic '%s'",
2793 gfc_current_intrinsic_arg
[0]->name
,
2794 gfc_current_intrinsic_arg
[1]->name
,
2795 gfc_current_intrinsic
) == FAILURE
)
2800 mpz_t array_size
, vector_size
;
2801 bool have_array_size
, have_vector_size
;
2803 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
2806 if (rank_check (vector
, 2, 1) == FAILURE
)
2809 /* VECTOR requires at least as many elements as MASK
2810 has .TRUE. values. */
2811 have_array_size
= gfc_array_size (array
, &array_size
) == SUCCESS
;
2812 have_vector_size
= gfc_array_size (vector
, &vector_size
) == SUCCESS
;
2814 if (have_vector_size
2815 && (mask
->expr_type
== EXPR_ARRAY
2816 || (mask
->expr_type
== EXPR_CONSTANT
2817 && have_array_size
)))
2819 int mask_true_values
= 0;
2821 if (mask
->expr_type
== EXPR_ARRAY
)
2823 gfc_constructor
*mask_ctor
;
2824 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
2827 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
2829 mask_true_values
= 0;
2833 if (mask_ctor
->expr
->value
.logical
)
2836 mask_ctor
= gfc_constructor_next (mask_ctor
);
2839 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
2840 mask_true_values
= mpz_get_si (array_size
);
2842 if (mpz_get_si (vector_size
) < mask_true_values
)
2844 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2845 "provide at least as many elements as there "
2846 "are .TRUE. values in '%s' (%ld/%d)",
2847 gfc_current_intrinsic_arg
[2]->name
,
2848 gfc_current_intrinsic
, &vector
->where
,
2849 gfc_current_intrinsic_arg
[1]->name
,
2850 mpz_get_si (vector_size
), mask_true_values
);
2855 if (have_array_size
)
2856 mpz_clear (array_size
);
2857 if (have_vector_size
)
2858 mpz_clear (vector_size
);
2866 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
2868 if (type_check (mask
, 0, BT_LOGICAL
) == FAILURE
)
2871 if (array_check (mask
, 0) == FAILURE
)
2874 if (dim_rank_check (dim
, mask
, false) == FAILURE
)
2882 gfc_check_precision (gfc_expr
*x
)
2884 if (real_or_complex_check (x
, 0) == FAILURE
)
2892 gfc_check_present (gfc_expr
*a
)
2896 if (variable_check (a
, 0, true) == FAILURE
)
2899 sym
= a
->symtree
->n
.sym
;
2900 if (!sym
->attr
.dummy
)
2902 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2903 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
2904 gfc_current_intrinsic
, &a
->where
);
2908 if (!sym
->attr
.optional
)
2910 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2911 "an OPTIONAL dummy variable",
2912 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
2917 /* 13.14.82 PRESENT(A)
2919 Argument. A shall be the name of an optional dummy argument that is
2920 accessible in the subprogram in which the PRESENT function reference
2924 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
2925 && (a
->ref
->u
.ar
.type
== AR_FULL
2926 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
2927 && a
->ref
->u
.ar
.as
->rank
== 0))))
2929 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2930 "subobject of '%s'", gfc_current_intrinsic_arg
[0]->name
,
2931 gfc_current_intrinsic
, &a
->where
, sym
->name
);
2940 gfc_check_radix (gfc_expr
*x
)
2942 if (int_or_real_check (x
, 0) == FAILURE
)
2950 gfc_check_range (gfc_expr
*x
)
2952 if (numeric_check (x
, 0) == FAILURE
)
2960 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
2962 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
2963 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
2965 bool is_variable
= true;
2967 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
2968 if (a
->expr_type
== EXPR_FUNCTION
)
2969 is_variable
= a
->value
.function
.esym
2970 ? a
->value
.function
.esym
->result
->attr
.pointer
2971 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
2973 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
2974 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
2977 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
2978 "object", &a
->where
);
2986 /* real, float, sngl. */
2988 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
2990 if (numeric_check (a
, 0) == FAILURE
)
2993 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
3001 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3003 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
3005 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
3008 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
3010 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
3018 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3020 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
3022 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
3025 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
3027 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
3033 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3036 if (scalar_check (status
, 2) == FAILURE
)
3044 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3046 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
3049 if (scalar_check (x
, 0) == FAILURE
)
3052 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
3055 if (scalar_check (y
, 1) == FAILURE
)
3063 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3064 gfc_expr
*pad
, gfc_expr
*order
)
3070 if (array_check (source
, 0) == FAILURE
)
3073 if (rank_check (shape
, 1, 1) == FAILURE
)
3076 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
3079 if (gfc_array_size (shape
, &size
) != SUCCESS
)
3081 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3082 "array of constant size", &shape
->where
);
3086 shape_size
= mpz_get_ui (size
);
3089 if (shape_size
<= 0)
3091 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3092 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3096 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3098 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3099 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3102 else if (shape
->expr_type
== EXPR_ARRAY
)
3106 for (i
= 0; i
< shape_size
; ++i
)
3108 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3109 if (e
->expr_type
!= EXPR_CONSTANT
)
3112 gfc_extract_int (e
, &extent
);
3115 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3116 "negative element (%d)",
3117 gfc_current_intrinsic_arg
[1]->name
,
3118 gfc_current_intrinsic
, &e
->where
, extent
);
3126 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
3129 if (array_check (pad
, 2) == FAILURE
)
3135 if (array_check (order
, 3) == FAILURE
)
3138 if (type_check (order
, 3, BT_INTEGER
) == FAILURE
)
3141 if (order
->expr_type
== EXPR_ARRAY
)
3143 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3146 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3149 gfc_array_size (order
, &size
);
3150 order_size
= mpz_get_ui (size
);
3153 if (order_size
!= shape_size
)
3155 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3156 "has wrong number of elements (%d/%d)",
3157 gfc_current_intrinsic_arg
[3]->name
,
3158 gfc_current_intrinsic
, &order
->where
,
3159 order_size
, shape_size
);
3163 for (i
= 1; i
<= order_size
; ++i
)
3165 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3166 if (e
->expr_type
!= EXPR_CONSTANT
)
3169 gfc_extract_int (e
, &dim
);
3171 if (dim
< 1 || dim
> order_size
)
3173 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3174 "has out-of-range dimension (%d)",
3175 gfc_current_intrinsic_arg
[3]->name
,
3176 gfc_current_intrinsic
, &e
->where
, dim
);
3180 if (perm
[dim
-1] != 0)
3182 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3183 "invalid permutation of dimensions (dimension "
3185 gfc_current_intrinsic_arg
[3]->name
,
3186 gfc_current_intrinsic
, &e
->where
, dim
);
3195 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3196 && gfc_is_constant_expr (shape
)
3197 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3198 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3200 /* Check the match in size between source and destination. */
3201 if (gfc_array_size (source
, &nelems
) == SUCCESS
)
3207 mpz_init_set_ui (size
, 1);
3208 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3209 c
; c
= gfc_constructor_next (c
))
3210 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3212 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3218 gfc_error ("Without padding, there are not enough elements "
3219 "in the intrinsic RESHAPE source at %L to match "
3220 "the shape", &source
->where
);
3231 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3234 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3236 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3237 "must be of a derived type",
3238 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3243 if (!gfc_type_is_extensible (a
->ts
.u
.derived
))
3245 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3246 "must be of an extensible type",
3247 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3252 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3254 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3255 "must be of a derived type",
3256 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3261 if (!gfc_type_is_extensible (b
->ts
.u
.derived
))
3263 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3264 "must be of an extensible type",
3265 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3275 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3277 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3280 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
3288 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3290 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
3293 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
3296 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
3299 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
3301 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
3302 "with KIND argument at %L",
3303 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3306 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
3314 gfc_check_secnds (gfc_expr
*r
)
3316 if (type_check (r
, 0, BT_REAL
) == FAILURE
)
3319 if (kind_value_check (r
, 0, 4) == FAILURE
)
3322 if (scalar_check (r
, 0) == FAILURE
)
3330 gfc_check_selected_char_kind (gfc_expr
*name
)
3332 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3335 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3338 if (scalar_check (name
, 0) == FAILURE
)
3346 gfc_check_selected_int_kind (gfc_expr
*r
)
3348 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
3351 if (scalar_check (r
, 0) == FAILURE
)
3359 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3361 if (p
== NULL
&& r
== NULL
3362 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: SELECTED_REAL_KIND with"
3363 " neither 'P' nor 'R' argument at %L",
3364 gfc_current_intrinsic_where
) == FAILURE
)
3369 if (type_check (p
, 0, BT_INTEGER
) == FAILURE
)
3372 if (scalar_check (p
, 0) == FAILURE
)
3378 if (type_check (r
, 1, BT_INTEGER
) == FAILURE
)
3381 if (scalar_check (r
, 1) == FAILURE
)
3387 if (type_check (radix
, 1, BT_INTEGER
) == FAILURE
)
3390 if (scalar_check (radix
, 1) == FAILURE
)
3393 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: '%s' intrinsic with "
3394 "RADIX argument at %L", gfc_current_intrinsic
,
3395 &radix
->where
) == FAILURE
)
3404 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3406 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3409 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
3417 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
3421 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3424 ar
= gfc_find_array_ref (source
);
3426 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
3428 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3429 "an assumed size array", &source
->where
);
3433 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
3435 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
3436 "with KIND argument at %L",
3437 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3445 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
3447 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
3450 if (type_check (shift
, 0, BT_INTEGER
) == FAILURE
)
3453 if (nonnegative_check ("SHIFT", shift
) == FAILURE
)
3456 if (less_than_bitsize1 ("I", i
, "SHIFT", shift
, true) == FAILURE
)
3464 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
3466 if (int_or_real_check (a
, 0) == FAILURE
)
3469 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
3477 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3479 if (array_check (array
, 0) == FAILURE
)
3482 if (dim_check (dim
, 1, true) == FAILURE
)
3485 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
3488 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
3490 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
3491 "with KIND argument at %L",
3492 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3501 gfc_check_sizeof (gfc_expr
*arg
)
3503 if (arg
->ts
.type
== BT_PROCEDURE
)
3505 gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
3506 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3515 gfc_check_c_sizeof (gfc_expr
*arg
)
3517 if (gfc_verify_c_interop (&arg
->ts
) != SUCCESS
)
3519 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3520 "interoperable data entity",
3521 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3530 gfc_check_sleep_sub (gfc_expr
*seconds
)
3532 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
3535 if (scalar_check (seconds
, 0) == FAILURE
)
3542 gfc_check_sngl (gfc_expr
*a
)
3544 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
3547 if ((a
->ts
.kind
!= gfc_default_double_kind
)
3548 && gfc_notify_std (GFC_STD_GNU
, "GNU extension: non double precision "
3549 "REAL argument to %s intrinsic at %L",
3550 gfc_current_intrinsic
, &a
->where
) == FAILURE
)
3557 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
3559 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
3561 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3562 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
3563 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
3571 if (dim_check (dim
, 1, false) == FAILURE
)
3574 /* dim_rank_check() does not apply here. */
3576 && dim
->expr_type
== EXPR_CONSTANT
3577 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
3578 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
3580 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3581 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
3582 gfc_current_intrinsic
, &dim
->where
);
3586 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
3589 if (scalar_check (ncopies
, 2) == FAILURE
)
3596 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3600 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
3602 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3605 if (scalar_check (unit
, 0) == FAILURE
)
3608 if (type_check (c
, 1, BT_CHARACTER
) == FAILURE
)
3610 if (kind_value_check (c
, 1, gfc_default_character_kind
) == FAILURE
)
3616 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3617 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
3618 || scalar_check (status
, 2) == FAILURE
)
3626 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
3628 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
3633 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
3635 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
3637 if (kind_value_check (c
, 0, gfc_default_character_kind
) == FAILURE
)
3643 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
3644 || kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
3645 || scalar_check (status
, 1) == FAILURE
)
3653 gfc_check_fgetput (gfc_expr
*c
)
3655 return gfc_check_fgetput_sub (c
, NULL
);
3660 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
3662 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3665 if (scalar_check (unit
, 0) == FAILURE
)
3668 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
3671 if (scalar_check (offset
, 1) == FAILURE
)
3674 if (type_check (whence
, 2, BT_INTEGER
) == FAILURE
)
3677 if (scalar_check (whence
, 2) == FAILURE
)
3683 if (type_check (status
, 3, BT_INTEGER
) == FAILURE
)
3686 if (kind_value_check (status
, 3, 4) == FAILURE
)
3689 if (scalar_check (status
, 3) == FAILURE
)
3698 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
3700 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3703 if (scalar_check (unit
, 0) == FAILURE
)
3706 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3707 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
3710 if (array_check (array
, 1) == FAILURE
)
3718 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
3720 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3723 if (scalar_check (unit
, 0) == FAILURE
)
3726 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3727 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3730 if (array_check (array
, 1) == FAILURE
)
3736 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3737 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
3740 if (scalar_check (status
, 2) == FAILURE
)
3748 gfc_check_ftell (gfc_expr
*unit
)
3750 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3753 if (scalar_check (unit
, 0) == FAILURE
)
3761 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
3763 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3766 if (scalar_check (unit
, 0) == FAILURE
)
3769 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
3772 if (scalar_check (offset
, 1) == FAILURE
)
3780 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
3782 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3784 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3787 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3788 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3791 if (array_check (array
, 1) == FAILURE
)
3799 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
3801 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3803 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3806 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3807 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3810 if (array_check (array
, 1) == FAILURE
)
3816 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3817 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3820 if (scalar_check (status
, 2) == FAILURE
)
3828 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
3832 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
3834 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3838 if (coarray_check (coarray
, 0) == FAILURE
)
3843 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3844 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
3848 if (gfc_array_size (sub
, &nelems
) == SUCCESS
)
3850 int corank
= gfc_get_corank (coarray
);
3852 if (mpz_cmp_ui (nelems
, corank
) != 0)
3854 gfc_error ("The number of array elements of the SUB argument to "
3855 "IMAGE_INDEX at %L shall be %d (corank) not %d",
3856 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
3868 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
)
3870 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
3872 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3876 if (dim
!= NULL
&& coarray
== NULL
)
3878 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3879 "intrinsic at %L", &dim
->where
);
3883 if (coarray
== NULL
)
3886 if (coarray_check (coarray
, 0) == FAILURE
)
3891 if (dim_check (dim
, 1, false) == FAILURE
)
3894 if (dim_corank_check (dim
, coarray
) == FAILURE
)
3901 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
3902 by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
3905 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
3906 size_t *source_size
, size_t *result_size
,
3907 size_t *result_length_p
)
3910 size_t result_elt_size
;
3912 gfc_expr
*mold_element
;
3914 if (source
->expr_type
== EXPR_FUNCTION
)
3917 /* Calculate the size of the source. */
3918 if (source
->expr_type
== EXPR_ARRAY
3919 && gfc_array_size (source
, &tmp
) == FAILURE
)
3922 *source_size
= gfc_target_expr_size (source
);
3924 mold_element
= mold
->expr_type
== EXPR_ARRAY
3925 ? gfc_constructor_first (mold
->value
.constructor
)->expr
3928 /* Determine the size of the element. */
3929 result_elt_size
= gfc_target_expr_size (mold_element
);
3930 if (result_elt_size
== 0)
3933 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
3938 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
3941 result_length
= *source_size
/ result_elt_size
;
3942 if (result_length
* result_elt_size
< *source_size
)
3946 *result_size
= result_length
* result_elt_size
;
3947 if (result_length_p
)
3948 *result_length_p
= result_length
;
3951 *result_size
= result_elt_size
;
3958 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
3963 if (mold
->ts
.type
== BT_HOLLERITH
)
3965 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3966 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
3972 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
3975 if (scalar_check (size
, 2) == FAILURE
)
3978 if (nonoptional_check (size
, 2) == FAILURE
)
3982 if (!gfc_option
.warn_surprising
)
3985 /* If we can't calculate the sizes, we cannot check any more.
3986 Return SUCCESS for that case. */
3988 if (gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
3989 &result_size
, NULL
) == FAILURE
)
3992 if (source_size
< result_size
)
3993 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
3994 "source size %ld < result size %ld", &source
->where
,
3995 (long) source_size
, (long) result_size
);
4002 gfc_check_transpose (gfc_expr
*matrix
)
4004 if (rank_check (matrix
, 0, 2) == FAILURE
)
4012 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4014 if (array_check (array
, 0) == FAILURE
)
4017 if (dim_check (dim
, 1, false) == FAILURE
)
4020 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
4023 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
4025 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
4026 "with KIND argument at %L",
4027 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
4035 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
4037 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4039 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4043 if (coarray_check (coarray
, 0) == FAILURE
)
4048 if (dim_check (dim
, 1, false) == FAILURE
)
4051 if (dim_corank_check (dim
, coarray
) == FAILURE
)
4055 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
4063 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
4067 if (rank_check (vector
, 0, 1) == FAILURE
)
4070 if (array_check (mask
, 1) == FAILURE
)
4073 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
4076 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
4079 if (mask
->expr_type
== EXPR_ARRAY
4080 && gfc_array_size (vector
, &vector_size
) == SUCCESS
)
4082 int mask_true_count
= 0;
4083 gfc_constructor
*mask_ctor
;
4084 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4087 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4089 mask_true_count
= 0;
4093 if (mask_ctor
->expr
->value
.logical
)
4096 mask_ctor
= gfc_constructor_next (mask_ctor
);
4099 if (mpz_get_si (vector_size
) < mask_true_count
)
4101 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4102 "provide at least as many elements as there "
4103 "are .TRUE. values in '%s' (%ld/%d)",
4104 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4105 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
4106 mpz_get_si (vector_size
), mask_true_count
);
4110 mpz_clear (vector_size
);
4113 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
4115 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4116 "the same rank as '%s' or be a scalar",
4117 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
4118 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
4122 if (mask
->rank
== field
->rank
)
4125 for (i
= 0; i
< field
->rank
; i
++)
4126 if (! identical_dimen_shape (mask
, i
, field
, i
))
4128 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4129 "must have identical shape.",
4130 gfc_current_intrinsic_arg
[2]->name
,
4131 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4141 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4143 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
4146 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
4149 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
4152 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
4154 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' intrinsic "
4155 "with KIND argument at %L",
4156 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
4164 gfc_check_trim (gfc_expr
*x
)
4166 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
4169 if (scalar_check (x
, 0) == FAILURE
)
4177 gfc_check_ttynam (gfc_expr
*unit
)
4179 if (scalar_check (unit
, 0) == FAILURE
)
4182 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4189 /* Common check function for the half a dozen intrinsics that have a
4190 single real argument. */
4193 gfc_check_x (gfc_expr
*x
)
4195 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
4202 /************* Check functions for intrinsic subroutines *************/
4205 gfc_check_cpu_time (gfc_expr
*time
)
4207 if (scalar_check (time
, 0) == FAILURE
)
4210 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
4213 if (variable_check (time
, 0, false) == FAILURE
)
4221 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
4222 gfc_expr
*zone
, gfc_expr
*values
)
4226 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
4228 if (kind_value_check (date
, 0, gfc_default_character_kind
) == FAILURE
)
4230 if (scalar_check (date
, 0) == FAILURE
)
4232 if (variable_check (date
, 0, false) == FAILURE
)
4238 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
4240 if (kind_value_check (time
, 1, gfc_default_character_kind
) == FAILURE
)
4242 if (scalar_check (time
, 1) == FAILURE
)
4244 if (variable_check (time
, 1, false) == FAILURE
)
4250 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
4252 if (kind_value_check (zone
, 2, gfc_default_character_kind
) == FAILURE
)
4254 if (scalar_check (zone
, 2) == FAILURE
)
4256 if (variable_check (zone
, 2, false) == FAILURE
)
4262 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
4264 if (array_check (values
, 3) == FAILURE
)
4266 if (rank_check (values
, 3, 1) == FAILURE
)
4268 if (variable_check (values
, 3, false) == FAILURE
)
4277 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
4278 gfc_expr
*to
, gfc_expr
*topos
)
4280 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
4283 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
4286 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
4289 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
4292 if (variable_check (to
, 3, false) == FAILURE
)
4295 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
4298 if (nonnegative_check ("frompos", frompos
) == FAILURE
)
4301 if (nonnegative_check ("topos", topos
) == FAILURE
)
4304 if (nonnegative_check ("len", len
) == FAILURE
)
4307 if (less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
)
4311 if (less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
) == FAILURE
)
4319 gfc_check_random_number (gfc_expr
*harvest
)
4321 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
4324 if (variable_check (harvest
, 0, false) == FAILURE
)
4332 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
4334 unsigned int nargs
= 0, kiss_size
;
4335 locus
*where
= NULL
;
4336 mpz_t put_size
, get_size
;
4337 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4339 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
4341 /* Keep the number of bytes in sync with kiss_size in
4342 libgfortran/intrinsics/random.c. */
4343 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
4347 if (size
->expr_type
!= EXPR_VARIABLE
4348 || !size
->symtree
->n
.sym
->attr
.optional
)
4351 if (scalar_check (size
, 0) == FAILURE
)
4354 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
4357 if (variable_check (size
, 0, false) == FAILURE
)
4360 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
4366 if (put
->expr_type
!= EXPR_VARIABLE
4367 || !put
->symtree
->n
.sym
->attr
.optional
)
4370 where
= &put
->where
;
4373 if (array_check (put
, 1) == FAILURE
)
4376 if (rank_check (put
, 1, 1) == FAILURE
)
4379 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
4382 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
4385 if (gfc_array_size (put
, &put_size
) == SUCCESS
4386 && mpz_get_ui (put_size
) < kiss_size
)
4387 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4388 "too small (%i/%i)",
4389 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4390 where
, (int) mpz_get_ui (put_size
), kiss_size
);
4395 if (get
->expr_type
!= EXPR_VARIABLE
4396 || !get
->symtree
->n
.sym
->attr
.optional
)
4399 where
= &get
->where
;
4402 if (array_check (get
, 2) == FAILURE
)
4405 if (rank_check (get
, 2, 1) == FAILURE
)
4408 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
4411 if (variable_check (get
, 2, false) == FAILURE
)
4414 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
4417 if (gfc_array_size (get
, &get_size
) == SUCCESS
4418 && mpz_get_ui (get_size
) < kiss_size
)
4419 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4420 "too small (%i/%i)",
4421 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
4422 where
, (int) mpz_get_ui (get_size
), kiss_size
);
4425 /* RANDOM_SEED may not have more than one non-optional argument. */
4427 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
4434 gfc_check_second_sub (gfc_expr
*time
)
4436 if (scalar_check (time
, 0) == FAILURE
)
4439 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
4442 if (kind_value_check(time
, 0, 4) == FAILURE
)
4449 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
4450 count, count_rate, and count_max are all optional arguments */
4453 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
4454 gfc_expr
*count_max
)
4458 if (scalar_check (count
, 0) == FAILURE
)
4461 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
4464 if (variable_check (count
, 0, false) == FAILURE
)
4468 if (count_rate
!= NULL
)
4470 if (scalar_check (count_rate
, 1) == FAILURE
)
4473 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
4476 if (variable_check (count_rate
, 1, false) == FAILURE
)
4480 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
4485 if (count_max
!= NULL
)
4487 if (scalar_check (count_max
, 2) == FAILURE
)
4490 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
4493 if (variable_check (count_max
, 2, false) == FAILURE
)
4497 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
4500 if (count_rate
!= NULL
4501 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
4510 gfc_check_irand (gfc_expr
*x
)
4515 if (scalar_check (x
, 0) == FAILURE
)
4518 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
4521 if (kind_value_check(x
, 0, 4) == FAILURE
)
4529 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
4531 if (scalar_check (seconds
, 0) == FAILURE
)
4533 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
4536 if (int_or_proc_check (handler
, 1) == FAILURE
)
4538 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
4544 if (scalar_check (status
, 2) == FAILURE
)
4546 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
4548 if (kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
4556 gfc_check_rand (gfc_expr
*x
)
4561 if (scalar_check (x
, 0) == FAILURE
)
4564 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
4567 if (kind_value_check(x
, 0, 4) == FAILURE
)
4575 gfc_check_srand (gfc_expr
*x
)
4577 if (scalar_check (x
, 0) == FAILURE
)
4580 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
4583 if (kind_value_check(x
, 0, 4) == FAILURE
)
4591 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
4593 if (scalar_check (time
, 0) == FAILURE
)
4595 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
4598 if (type_check (result
, 1, BT_CHARACTER
) == FAILURE
)
4600 if (kind_value_check (result
, 1, gfc_default_character_kind
) == FAILURE
)
4608 gfc_check_dtime_etime (gfc_expr
*x
)
4610 if (array_check (x
, 0) == FAILURE
)
4613 if (rank_check (x
, 0, 1) == FAILURE
)
4616 if (variable_check (x
, 0, false) == FAILURE
)
4619 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
4622 if (kind_value_check(x
, 0, 4) == FAILURE
)
4630 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
4632 if (array_check (values
, 0) == FAILURE
)
4635 if (rank_check (values
, 0, 1) == FAILURE
)
4638 if (variable_check (values
, 0, false) == FAILURE
)
4641 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
4644 if (kind_value_check(values
, 0, 4) == FAILURE
)
4647 if (scalar_check (time
, 1) == FAILURE
)
4650 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
4653 if (kind_value_check(time
, 1, 4) == FAILURE
)
4661 gfc_check_fdate_sub (gfc_expr
*date
)
4663 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
4665 if (kind_value_check (date
, 0, gfc_default_character_kind
) == FAILURE
)
4673 gfc_check_gerror (gfc_expr
*msg
)
4675 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
4677 if (kind_value_check (msg
, 0, gfc_default_character_kind
) == FAILURE
)
4685 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
4687 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
4689 if (kind_value_check (cwd
, 0, gfc_default_character_kind
) == FAILURE
)
4695 if (scalar_check (status
, 1) == FAILURE
)
4698 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
4706 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
4708 if (type_check (pos
, 0, BT_INTEGER
) == FAILURE
)
4711 if (pos
->ts
.kind
> gfc_default_integer_kind
)
4713 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4714 "not wider than the default kind (%d)",
4715 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4716 &pos
->where
, gfc_default_integer_kind
);
4720 if (type_check (value
, 1, BT_CHARACTER
) == FAILURE
)
4722 if (kind_value_check (value
, 1, gfc_default_character_kind
) == FAILURE
)
4730 gfc_check_getlog (gfc_expr
*msg
)
4732 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
4734 if (kind_value_check (msg
, 0, gfc_default_character_kind
) == FAILURE
)
4742 gfc_check_exit (gfc_expr
*status
)
4747 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
4750 if (scalar_check (status
, 0) == FAILURE
)
4758 gfc_check_flush (gfc_expr
*unit
)
4763 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4766 if (scalar_check (unit
, 0) == FAILURE
)
4774 gfc_check_free (gfc_expr
*i
)
4776 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
4779 if (scalar_check (i
, 0) == FAILURE
)
4787 gfc_check_hostnm (gfc_expr
*name
)
4789 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4791 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4799 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
4801 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4803 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4809 if (scalar_check (status
, 1) == FAILURE
)
4812 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
4820 gfc_check_itime_idate (gfc_expr
*values
)
4822 if (array_check (values
, 0) == FAILURE
)
4825 if (rank_check (values
, 0, 1) == FAILURE
)
4828 if (variable_check (values
, 0, false) == FAILURE
)
4831 if (type_check (values
, 0, BT_INTEGER
) == FAILURE
)
4834 if (kind_value_check(values
, 0, gfc_default_integer_kind
) == FAILURE
)
4842 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
4844 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
4847 if (kind_value_check(time
, 0, gfc_default_integer_kind
) == FAILURE
)
4850 if (scalar_check (time
, 0) == FAILURE
)
4853 if (array_check (values
, 1) == FAILURE
)
4856 if (rank_check (values
, 1, 1) == FAILURE
)
4859 if (variable_check (values
, 1, false) == FAILURE
)
4862 if (type_check (values
, 1, BT_INTEGER
) == FAILURE
)
4865 if (kind_value_check(values
, 1, gfc_default_integer_kind
) == FAILURE
)
4873 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
4875 if (scalar_check (unit
, 0) == FAILURE
)
4878 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4881 if (type_check (name
, 1, BT_CHARACTER
) == FAILURE
)
4883 if (kind_value_check (name
, 1, gfc_default_character_kind
) == FAILURE
)
4891 gfc_check_isatty (gfc_expr
*unit
)
4896 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4899 if (scalar_check (unit
, 0) == FAILURE
)
4907 gfc_check_isnan (gfc_expr
*x
)
4909 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
4917 gfc_check_perror (gfc_expr
*string
)
4919 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
4921 if (kind_value_check (string
, 0, gfc_default_character_kind
) == FAILURE
)
4929 gfc_check_umask (gfc_expr
*mask
)
4931 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
4934 if (scalar_check (mask
, 0) == FAILURE
)
4942 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
4944 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
4947 if (scalar_check (mask
, 0) == FAILURE
)
4953 if (scalar_check (old
, 1) == FAILURE
)
4956 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
4964 gfc_check_unlink (gfc_expr
*name
)
4966 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4968 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4976 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
4978 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4980 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4986 if (scalar_check (status
, 1) == FAILURE
)
4989 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
4997 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
4999 if (scalar_check (number
, 0) == FAILURE
)
5001 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
5004 if (int_or_proc_check (handler
, 1) == FAILURE
)
5006 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
5014 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
5016 if (scalar_check (number
, 0) == FAILURE
)
5018 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
5021 if (int_or_proc_check (handler
, 1) == FAILURE
)
5023 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
5029 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
5031 if (scalar_check (status
, 2) == FAILURE
)
5039 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
5041 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
5043 if (kind_value_check (cmd
, 0, gfc_default_character_kind
) == FAILURE
)
5046 if (scalar_check (status
, 1) == FAILURE
)
5049 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
5052 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)
5059 /* This is used for the GNU intrinsics AND, OR and XOR. */
5061 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
5063 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
5065 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5066 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
5067 gfc_current_intrinsic
, &i
->where
);
5071 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
5073 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5074 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
5075 gfc_current_intrinsic
, &j
->where
);
5079 if (i
->ts
.type
!= j
->ts
.type
)
5081 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5082 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
5083 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5088 if (scalar_check (i
, 0) == FAILURE
)
5091 if (scalar_check (j
, 1) == FAILURE
)
5099 gfc_check_storage_size (gfc_expr
*a ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
5104 if (type_check (kind
, 1, BT_INTEGER
) == FAILURE
)
5107 if (scalar_check (kind
, 1) == FAILURE
)
5110 if (kind
->expr_type
!= EXPR_CONSTANT
)
5112 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5113 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,