2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught & Katherine Holcomb
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* These functions check to see if an argument list is compatible with
25 a particular intrinsic function or subroutine. Presence of
26 required arguments has already been established, the argument list
27 has been sorted into the right order and has NULL arguments in the
28 correct places for missing optional arguments. */
32 #include "coretypes.h"
35 #include "intrinsic.h"
36 #include "constructor.h"
37 #include "target-memory.h"
40 /* Make sure an expression is a scalar. */
43 scalar_check (gfc_expr
*e
, int n
)
48 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
49 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
56 /* Check the type of an expression. */
59 type_check (gfc_expr
*e
, int n
, bt type
)
61 if (e
->ts
.type
== type
)
64 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
65 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
66 &e
->where
, gfc_basic_typename (type
));
72 /* Check that the expression is a numeric type. */
75 numeric_check (gfc_expr
*e
, int n
)
77 if (gfc_numeric_ts (&e
->ts
))
80 /* If the expression has not got a type, check if its namespace can
81 offer a default type. */
82 if ((e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
83 && e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
84 && gfc_set_default_type (e
->symtree
->n
.sym
, 0,
85 e
->symtree
->n
.sym
->ns
) == SUCCESS
86 && gfc_numeric_ts (&e
->symtree
->n
.sym
->ts
))
88 e
->ts
= e
->symtree
->n
.sym
->ts
;
92 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
93 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
100 /* Check that an expression is integer or real. */
103 int_or_real_check (gfc_expr
*e
, int n
)
105 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_REAL
)
107 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
108 "or REAL", gfc_current_intrinsic_arg
[n
]->name
,
109 gfc_current_intrinsic
, &e
->where
);
117 /* Check that an expression is real or complex. */
120 real_or_complex_check (gfc_expr
*e
, int n
)
122 if (e
->ts
.type
!= BT_REAL
&& e
->ts
.type
!= BT_COMPLEX
)
124 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
125 "or COMPLEX", gfc_current_intrinsic_arg
[n
]->name
,
126 gfc_current_intrinsic
, &e
->where
);
134 /* Check that an expression is INTEGER or PROCEDURE. */
137 int_or_proc_check (gfc_expr
*e
, int n
)
139 if (e
->ts
.type
!= BT_INTEGER
&& e
->ts
.type
!= BT_PROCEDURE
)
141 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
142 "or PROCEDURE", gfc_current_intrinsic_arg
[n
]->name
,
143 gfc_current_intrinsic
, &e
->where
);
151 /* Check that the expression is an optional constant integer
152 and that it specifies a valid kind for that type. */
155 kind_check (gfc_expr
*k
, int n
, bt type
)
162 if (type_check (k
, n
, BT_INTEGER
) == FAILURE
)
165 if (scalar_check (k
, n
) == FAILURE
)
168 if (gfc_check_init_expr (k
) != SUCCESS
)
170 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
171 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
176 if (gfc_extract_int (k
, &kind
) != NULL
177 || gfc_validate_kind (type
, kind
, true) < 0)
179 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type
),
188 /* Make sure the expression is a double precision real. */
191 double_check (gfc_expr
*d
, int n
)
193 if (type_check (d
, n
, BT_REAL
) == FAILURE
)
196 if (d
->ts
.kind
!= gfc_default_double_kind
)
198 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
199 "precision", gfc_current_intrinsic_arg
[n
]->name
,
200 gfc_current_intrinsic
, &d
->where
);
209 coarray_check (gfc_expr
*e
, int n
)
211 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
212 && CLASS_DATA (e
)->attr
.codimension
213 && CLASS_DATA (e
)->as
->corank
)
215 gfc_add_class_array_ref (e
);
219 if (!gfc_is_coarray (e
))
221 gfc_error ("Expected coarray variable as '%s' argument to the %s "
222 "intrinsic at %L", gfc_current_intrinsic_arg
[n
]->name
,
223 gfc_current_intrinsic
, &e
->where
);
231 /* Make sure the expression is a logical array. */
234 logical_array_check (gfc_expr
*array
, int n
)
236 if (array
->ts
.type
!= BT_LOGICAL
|| array
->rank
== 0)
238 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
239 "array", gfc_current_intrinsic_arg
[n
]->name
,
240 gfc_current_intrinsic
, &array
->where
);
248 /* Make sure an expression is an array. */
251 array_check (gfc_expr
*e
, int n
)
253 if (e
->ts
.type
== BT_CLASS
&& gfc_expr_attr (e
).class_ok
254 && CLASS_DATA (e
)->attr
.dimension
255 && CLASS_DATA (e
)->as
->rank
)
257 gfc_add_class_array_ref (e
);
264 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
265 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
272 /* If expr is a constant, then check to ensure that it is greater than
276 nonnegative_check (const char *arg
, gfc_expr
*expr
)
280 if (expr
->expr_type
== EXPR_CONSTANT
)
282 gfc_extract_int (expr
, &i
);
285 gfc_error ("'%s' at %L must be nonnegative", arg
, &expr
->where
);
294 /* If expr2 is constant, then check that the value is less than
295 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
298 less_than_bitsize1 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
299 gfc_expr
*expr2
, bool or_equal
)
303 if (expr2
->expr_type
== EXPR_CONSTANT
)
305 gfc_extract_int (expr2
, &i2
);
306 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
308 /* For ISHFT[C], check that |shift| <= bit_size(i). */
314 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
316 gfc_error ("The absolute value of SHIFT at %L must be less "
317 "than or equal to BIT_SIZE('%s')",
318 &expr2
->where
, arg1
);
325 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
327 gfc_error ("'%s' at %L must be less than "
328 "or equal to BIT_SIZE('%s')",
329 arg2
, &expr2
->where
, arg1
);
335 if (i2
>= gfc_integer_kinds
[i3
].bit_size
)
337 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
338 arg2
, &expr2
->where
, arg1
);
348 /* If expr is constant, then check that the value is less than or equal
349 to the bit_size of the kind k. */
352 less_than_bitsizekind (const char *arg
, gfc_expr
*expr
, int k
)
356 if (expr
->expr_type
!= EXPR_CONSTANT
)
359 i
= gfc_validate_kind (BT_INTEGER
, k
, false);
360 gfc_extract_int (expr
, &val
);
362 if (val
> gfc_integer_kinds
[i
].bit_size
)
364 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
365 "INTEGER(KIND=%d)", arg
, &expr
->where
, k
);
373 /* If expr2 and expr3 are constants, then check that the value is less than
374 or equal to bit_size(expr1). */
377 less_than_bitsize2 (const char *arg1
, gfc_expr
*expr1
, const char *arg2
,
378 gfc_expr
*expr2
, const char *arg3
, gfc_expr
*expr3
)
382 if (expr2
->expr_type
== EXPR_CONSTANT
&& expr3
->expr_type
== EXPR_CONSTANT
)
384 gfc_extract_int (expr2
, &i2
);
385 gfc_extract_int (expr3
, &i3
);
387 i3
= gfc_validate_kind (BT_INTEGER
, expr1
->ts
.kind
, false);
388 if (i2
> gfc_integer_kinds
[i3
].bit_size
)
390 gfc_error ("'%s + %s' at %L must be less than or equal "
392 arg2
, arg3
, &expr2
->where
, arg1
);
400 /* Make sure two expressions have the same type. */
403 same_type_check (gfc_expr
*e
, int n
, gfc_expr
*f
, int m
)
405 if (gfc_compare_types (&e
->ts
, &f
->ts
))
408 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
409 "and kind as '%s'", gfc_current_intrinsic_arg
[m
]->name
,
410 gfc_current_intrinsic
, &f
->where
,
411 gfc_current_intrinsic_arg
[n
]->name
);
417 /* Make sure that an expression has a certain (nonzero) rank. */
420 rank_check (gfc_expr
*e
, int n
, int rank
)
425 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
426 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
433 /* Make sure a variable expression is not an optional dummy argument. */
436 nonoptional_check (gfc_expr
*e
, int n
)
438 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
440 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
441 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
445 /* TODO: Recursive check on nonoptional variables? */
451 /* Check for ALLOCATABLE attribute. */
454 allocatable_check (gfc_expr
*e
, int n
)
456 symbol_attribute attr
;
458 attr
= gfc_variable_attr (e
, NULL
);
459 if (!attr
.allocatable
)
461 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
462 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
471 /* Check that an expression has a particular kind. */
474 kind_value_check (gfc_expr
*e
, int n
, int k
)
479 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
480 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
,
487 /* Make sure an expression is a variable. */
490 variable_check (gfc_expr
*e
, int n
, bool allow_proc
)
492 if (e
->expr_type
== EXPR_VARIABLE
493 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
494 && (gfc_current_intrinsic_arg
[n
]->intent
== INTENT_OUT
495 || gfc_current_intrinsic_arg
[n
]->intent
== INTENT_INOUT
))
498 bool pointer
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
499 && CLASS_DATA (e
->symtree
->n
.sym
)
500 ? CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
501 : e
->symtree
->n
.sym
->attr
.pointer
;
503 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
505 if (pointer
&& ref
->type
== REF_COMPONENT
)
507 if (ref
->type
== REF_COMPONENT
508 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
509 && CLASS_DATA (ref
->u
.c
.component
)->attr
.class_pointer
)
510 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
511 && ref
->u
.c
.component
->attr
.pointer
)))
517 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
518 "INTENT(IN)", gfc_current_intrinsic_arg
[n
]->name
,
519 gfc_current_intrinsic
, &e
->where
);
524 if (e
->expr_type
== EXPR_VARIABLE
525 && e
->symtree
->n
.sym
->attr
.flavor
!= FL_PARAMETER
526 && (allow_proc
|| !e
->symtree
->n
.sym
->attr
.function
))
529 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.function
530 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
533 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
534 if (ns
->proc_name
== e
->symtree
->n
.sym
)
538 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
539 gfc_current_intrinsic_arg
[n
]->name
, gfc_current_intrinsic
, &e
->where
);
545 /* Check the common DIM parameter for correctness. */
548 dim_check (gfc_expr
*dim
, int n
, bool optional
)
553 if (type_check (dim
, n
, BT_INTEGER
) == FAILURE
)
556 if (scalar_check (dim
, n
) == FAILURE
)
559 if (!optional
&& nonoptional_check (dim
, n
) == FAILURE
)
566 /* If a coarray DIM parameter is a constant, make sure that it is greater than
567 zero and less than or equal to the corank of the given array. */
570 dim_corank_check (gfc_expr
*dim
, gfc_expr
*array
)
574 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
576 if (dim
->expr_type
!= EXPR_CONSTANT
)
579 if (array
->ts
.type
== BT_CLASS
)
582 corank
= gfc_get_corank (array
);
584 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
585 || mpz_cmp_ui (dim
->value
.integer
, corank
) > 0)
587 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
588 "codimension index", gfc_current_intrinsic
, &dim
->where
);
597 /* If a DIM parameter is a constant, make sure that it is greater than
598 zero and less than or equal to the rank of the given array. If
599 allow_assumed is zero then dim must be less than the rank of the array
600 for assumed size arrays. */
603 dim_rank_check (gfc_expr
*dim
, gfc_expr
*array
, int allow_assumed
)
611 if (dim
->expr_type
!= EXPR_CONSTANT
)
614 if (array
->ts
.type
== BT_CLASS
)
617 if (array
->expr_type
== EXPR_FUNCTION
&& array
->value
.function
.isym
618 && array
->value
.function
.isym
->id
== GFC_ISYM_SPREAD
)
619 rank
= array
->rank
+ 1;
623 /* Assumed-rank array. */
625 rank
= GFC_MAX_DIMENSIONS
;
627 if (array
->expr_type
== EXPR_VARIABLE
)
629 ar
= gfc_find_array_ref (array
);
630 if (ar
->as
->type
== AS_ASSUMED_SIZE
632 && ar
->type
!= AR_ELEMENT
633 && ar
->type
!= AR_SECTION
)
637 if (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
638 || mpz_cmp_ui (dim
->value
.integer
, rank
) > 0)
640 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
641 "dimension index", gfc_current_intrinsic
, &dim
->where
);
650 /* Compare the size of a along dimension ai with the size of b along
651 dimension bi, returning 0 if they are known not to be identical,
652 and 1 if they are identical, or if this cannot be determined. */
655 identical_dimen_shape (gfc_expr
*a
, int ai
, gfc_expr
*b
, int bi
)
657 mpz_t a_size
, b_size
;
660 gcc_assert (a
->rank
> ai
);
661 gcc_assert (b
->rank
> bi
);
665 if (gfc_array_dimen_size (a
, ai
, &a_size
) == SUCCESS
)
667 if (gfc_array_dimen_size (b
, bi
, &b_size
) == SUCCESS
)
669 if (mpz_cmp (a_size
, b_size
) != 0)
679 /* Calculate the length of a character variable, including substrings.
680 Strip away parentheses if necessary. Return -1 if no length could
684 gfc_var_strlen (const gfc_expr
*a
)
688 while (a
->expr_type
== EXPR_OP
&& a
->value
.op
.op
== INTRINSIC_PARENTHESES
)
691 for (ra
= a
->ref
; ra
!= NULL
&& ra
->type
!= REF_SUBSTRING
; ra
= ra
->next
)
698 if (ra
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
699 && ra
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
701 start_a
= mpz_get_si (ra
->u
.ss
.start
->value
.integer
);
702 end_a
= mpz_get_si (ra
->u
.ss
.end
->value
.integer
);
703 return end_a
- start_a
+ 1;
705 else if (gfc_dep_compare_expr (ra
->u
.ss
.start
, ra
->u
.ss
.end
) == 0)
711 if (a
->ts
.u
.cl
&& a
->ts
.u
.cl
->length
712 && a
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
713 return mpz_get_si (a
->ts
.u
.cl
->length
->value
.integer
);
714 else if (a
->expr_type
== EXPR_CONSTANT
715 && (a
->ts
.u
.cl
== NULL
|| a
->ts
.u
.cl
->length
== NULL
))
716 return a
->value
.character
.length
;
722 /* Check whether two character expressions have the same length;
723 returns SUCCESS if they have or if the length cannot be determined,
724 otherwise return FAILURE and raise a gfc_error. */
727 gfc_check_same_strlen (const gfc_expr
*a
, const gfc_expr
*b
, const char *name
)
731 len_a
= gfc_var_strlen(a
);
732 len_b
= gfc_var_strlen(b
);
734 if (len_a
== -1 || len_b
== -1 || len_a
== len_b
)
738 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
739 len_a
, len_b
, name
, &a
->where
);
745 /***** Check functions *****/
747 /* Check subroutine suitable for intrinsics taking a real argument and
748 a kind argument for the result. */
751 check_a_kind (gfc_expr
*a
, gfc_expr
*kind
, bt type
)
753 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
755 if (kind_check (kind
, 1, type
) == FAILURE
)
762 /* Check subroutine suitable for ceiling, floor and nint. */
765 gfc_check_a_ikind (gfc_expr
*a
, gfc_expr
*kind
)
767 return check_a_kind (a
, kind
, BT_INTEGER
);
771 /* Check subroutine suitable for aint, anint. */
774 gfc_check_a_xkind (gfc_expr
*a
, gfc_expr
*kind
)
776 return check_a_kind (a
, kind
, BT_REAL
);
781 gfc_check_abs (gfc_expr
*a
)
783 if (numeric_check (a
, 0) == FAILURE
)
791 gfc_check_achar (gfc_expr
*a
, gfc_expr
*kind
)
793 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
795 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
803 gfc_check_access_func (gfc_expr
*name
, gfc_expr
*mode
)
805 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
806 || scalar_check (name
, 0) == FAILURE
)
808 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
811 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
812 || scalar_check (mode
, 1) == FAILURE
)
814 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
822 gfc_check_all_any (gfc_expr
*mask
, gfc_expr
*dim
)
824 if (logical_array_check (mask
, 0) == FAILURE
)
827 if (dim_check (dim
, 1, false) == FAILURE
)
830 if (dim_rank_check (dim
, mask
, 0) == FAILURE
)
838 gfc_check_allocated (gfc_expr
*array
)
840 if (variable_check (array
, 0, false) == FAILURE
)
842 if (allocatable_check (array
, 0) == FAILURE
)
849 /* Common check function where the first argument must be real or
850 integer and the second argument must be the same as the first. */
853 gfc_check_a_p (gfc_expr
*a
, gfc_expr
*p
)
855 if (int_or_real_check (a
, 0) == FAILURE
)
858 if (a
->ts
.type
!= p
->ts
.type
)
860 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
861 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
862 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
867 if (a
->ts
.kind
!= p
->ts
.kind
)
869 if (gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
870 &p
->where
) == FAILURE
)
879 gfc_check_x_yd (gfc_expr
*x
, gfc_expr
*y
)
881 if (double_check (x
, 0) == FAILURE
|| double_check (y
, 1) == FAILURE
)
889 gfc_check_associated (gfc_expr
*pointer
, gfc_expr
*target
)
891 symbol_attribute attr1
, attr2
;
896 where
= &pointer
->where
;
898 if (pointer
->expr_type
== EXPR_VARIABLE
|| pointer
->expr_type
== EXPR_FUNCTION
)
899 attr1
= gfc_expr_attr (pointer
);
900 else if (pointer
->expr_type
== EXPR_NULL
)
903 gcc_assert (0); /* Pointer must be a variable or a function. */
905 if (!attr1
.pointer
&& !attr1
.proc_pointer
)
907 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
908 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
914 if (attr1
.pointer
&& gfc_is_coindexed (pointer
))
916 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
917 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
918 gfc_current_intrinsic
, &pointer
->where
);
922 /* Target argument is optional. */
926 where
= &target
->where
;
927 if (target
->expr_type
== EXPR_NULL
)
930 if (target
->expr_type
== EXPR_VARIABLE
|| target
->expr_type
== EXPR_FUNCTION
)
931 attr2
= gfc_expr_attr (target
);
934 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
935 "or target VARIABLE or FUNCTION",
936 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
941 if (attr1
.pointer
&& !attr2
.pointer
&& !attr2
.target
)
943 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
944 "or a TARGET", gfc_current_intrinsic_arg
[1]->name
,
945 gfc_current_intrinsic
, &target
->where
);
950 if (attr1
.pointer
&& gfc_is_coindexed (target
))
952 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
953 "coindexed", gfc_current_intrinsic_arg
[1]->name
,
954 gfc_current_intrinsic
, &target
->where
);
959 if (same_type_check (pointer
, 0, target
, 1) == FAILURE
)
961 if (rank_check (target
, 0, pointer
->rank
) == FAILURE
)
963 if (target
->rank
> 0)
965 for (i
= 0; i
< target
->rank
; i
++)
966 if (target
->ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
968 gfc_error ("Array section with a vector subscript at %L shall not "
969 "be the target of a pointer",
979 gfc_error ("NULL pointer at %L is not permitted as actual argument "
980 "of '%s' intrinsic function", where
, gfc_current_intrinsic
);
987 gfc_check_atan_2 (gfc_expr
*y
, gfc_expr
*x
)
989 /* gfc_notify_std would be a waste of time as the return value
990 is seemingly used only for the generic resolution. The error
991 will be: Too many arguments. */
992 if ((gfc_option
.allow_std
& GFC_STD_F2008
) == 0)
995 return gfc_check_atan2 (y
, x
);
1000 gfc_check_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1002 if (type_check (y
, 0, BT_REAL
) == FAILURE
)
1004 if (same_type_check (y
, 0, x
, 1) == FAILURE
)
1012 gfc_check_atomic (gfc_expr
*atom
, gfc_expr
*value
)
1014 if (!(atom
->ts
.type
== BT_INTEGER
&& atom
->ts
.kind
== gfc_atomic_int_kind
)
1015 && !(atom
->ts
.type
== BT_LOGICAL
1016 && atom
->ts
.kind
== gfc_atomic_logical_kind
))
1018 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1019 "integer of ATOMIC_INT_KIND or a logical of "
1020 "ATOMIC_LOGICAL_KIND", &atom
->where
, gfc_current_intrinsic
);
1024 if (!gfc_expr_attr (atom
).codimension
)
1026 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1027 "coarray or coindexed", &atom
->where
, gfc_current_intrinsic
);
1031 if (atom
->ts
.type
!= value
->ts
.type
)
1033 gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
1034 "have the same type at %L", gfc_current_intrinsic
,
1044 gfc_check_atomic_def (gfc_expr
*atom
, gfc_expr
*value
)
1046 if (scalar_check (atom
, 0) == FAILURE
|| scalar_check (value
, 1) == FAILURE
)
1049 if (gfc_check_vardef_context (atom
, false, false, false, NULL
) == FAILURE
)
1051 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1052 "definable", gfc_current_intrinsic
, &atom
->where
);
1056 return gfc_check_atomic (atom
, value
);
1061 gfc_check_atomic_ref (gfc_expr
*value
, gfc_expr
*atom
)
1063 if (scalar_check (value
, 0) == FAILURE
|| scalar_check (atom
, 1) == FAILURE
)
1066 if (gfc_check_vardef_context (value
, false, false, false, NULL
) == FAILURE
)
1068 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1069 "definable", gfc_current_intrinsic
, &value
->where
);
1073 return gfc_check_atomic (atom
, value
);
1077 /* BESJN and BESYN functions. */
1080 gfc_check_besn (gfc_expr
*n
, gfc_expr
*x
)
1082 if (type_check (n
, 0, BT_INTEGER
) == FAILURE
)
1084 if (n
->expr_type
== EXPR_CONSTANT
)
1087 gfc_extract_int (n
, &i
);
1088 if (i
< 0 && gfc_notify_std (GFC_STD_GNU
, "Negative argument "
1089 "N at %L", &n
->where
) == FAILURE
)
1093 if (type_check (x
, 1, BT_REAL
) == FAILURE
)
1100 /* Transformational version of the Bessel JN and YN functions. */
1103 gfc_check_bessel_n2 (gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
1105 if (type_check (n1
, 0, BT_INTEGER
) == FAILURE
)
1107 if (scalar_check (n1
, 0) == FAILURE
)
1109 if (nonnegative_check("N1", n1
) == FAILURE
)
1112 if (type_check (n2
, 1, BT_INTEGER
) == FAILURE
)
1114 if (scalar_check (n2
, 1) == FAILURE
)
1116 if (nonnegative_check("N2", n2
) == FAILURE
)
1119 if (type_check (x
, 2, BT_REAL
) == FAILURE
)
1121 if (scalar_check (x
, 2) == FAILURE
)
1129 gfc_check_bge_bgt_ble_blt (gfc_expr
*i
, gfc_expr
*j
)
1131 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1134 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1142 gfc_check_bitfcn (gfc_expr
*i
, gfc_expr
*pos
)
1144 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1147 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1150 if (nonnegative_check ("pos", pos
) == FAILURE
)
1153 if (less_than_bitsize1 ("i", i
, "pos", pos
, false) == FAILURE
)
1161 gfc_check_char (gfc_expr
*i
, gfc_expr
*kind
)
1163 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1165 if (kind_check (kind
, 1, BT_CHARACTER
) == FAILURE
)
1173 gfc_check_chdir (gfc_expr
*dir
)
1175 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
1177 if (kind_value_check (dir
, 0, gfc_default_character_kind
) == FAILURE
)
1185 gfc_check_chdir_sub (gfc_expr
*dir
, gfc_expr
*status
)
1187 if (type_check (dir
, 0, BT_CHARACTER
) == FAILURE
)
1189 if (kind_value_check (dir
, 0, gfc_default_character_kind
) == FAILURE
)
1195 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
1197 if (scalar_check (status
, 1) == FAILURE
)
1205 gfc_check_chmod (gfc_expr
*name
, gfc_expr
*mode
)
1207 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
1209 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
1212 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
1214 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
1222 gfc_check_chmod_sub (gfc_expr
*name
, gfc_expr
*mode
, gfc_expr
*status
)
1224 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
1226 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
1229 if (type_check (mode
, 1, BT_CHARACTER
) == FAILURE
)
1231 if (kind_value_check (mode
, 1, gfc_default_character_kind
) == FAILURE
)
1237 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
1240 if (scalar_check (status
, 2) == FAILURE
)
1248 gfc_check_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
1250 if (numeric_check (x
, 0) == FAILURE
)
1255 if (numeric_check (y
, 1) == FAILURE
)
1258 if (x
->ts
.type
== BT_COMPLEX
)
1260 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1261 "present if 'x' is COMPLEX",
1262 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1267 if (y
->ts
.type
== BT_COMPLEX
)
1269 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1270 "of either REAL or INTEGER",
1271 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1278 if (kind_check (kind
, 2, BT_COMPLEX
) == FAILURE
)
1281 if (!kind
&& gfc_option
.gfc_warn_conversion
1282 && x
->ts
.type
== BT_REAL
&& x
->ts
.kind
> gfc_default_real_kind
)
1283 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1284 "might loose precision, consider using the KIND argument",
1285 gfc_typename (&x
->ts
), gfc_default_real_kind
, &x
->where
);
1286 else if (y
&& !kind
&& gfc_option
.gfc_warn_conversion
1287 && y
->ts
.type
== BT_REAL
&& y
->ts
.kind
> gfc_default_real_kind
)
1288 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1289 "might loose precision, consider using the KIND argument",
1290 gfc_typename (&y
->ts
), gfc_default_real_kind
, &y
->where
);
1297 gfc_check_complex (gfc_expr
*x
, gfc_expr
*y
)
1299 if (int_or_real_check (x
, 0) == FAILURE
)
1301 if (scalar_check (x
, 0) == FAILURE
)
1304 if (int_or_real_check (y
, 1) == FAILURE
)
1306 if (scalar_check (y
, 1) == FAILURE
)
1314 gfc_check_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1316 if (logical_array_check (mask
, 0) == FAILURE
)
1318 if (dim_check (dim
, 1, false) == FAILURE
)
1320 if (dim_rank_check (dim
, mask
, 0) == FAILURE
)
1322 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
1324 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1325 "with KIND argument at %L",
1326 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1334 gfc_check_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1336 if (array_check (array
, 0) == FAILURE
)
1339 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1342 if (dim_check (dim
, 2, true) == FAILURE
)
1345 if (dim_rank_check (dim
, array
, false) == FAILURE
)
1348 if (array
->rank
== 1 || shift
->rank
== 0)
1350 if (scalar_check (shift
, 1) == FAILURE
)
1353 else if (shift
->rank
== array
->rank
- 1)
1358 else if (dim
->expr_type
== EXPR_CONSTANT
)
1359 gfc_extract_int (dim
, &d
);
1366 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1369 if (!identical_dimen_shape (array
, i
, shift
, j
))
1371 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1372 "invalid shape in dimension %d (%ld/%ld)",
1373 gfc_current_intrinsic_arg
[1]->name
,
1374 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1375 mpz_get_si (array
->shape
[i
]),
1376 mpz_get_si (shift
->shape
[j
]));
1386 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1387 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1388 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1397 gfc_check_ctime (gfc_expr
*time
)
1399 if (scalar_check (time
, 0) == FAILURE
)
1402 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
1409 gfc_try
gfc_check_datan2 (gfc_expr
*y
, gfc_expr
*x
)
1411 if (double_check (y
, 0) == FAILURE
|| double_check (x
, 1) == FAILURE
)
1418 gfc_check_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1420 if (numeric_check (x
, 0) == FAILURE
)
1425 if (numeric_check (y
, 1) == FAILURE
)
1428 if (x
->ts
.type
== BT_COMPLEX
)
1430 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1431 "present if 'x' is COMPLEX",
1432 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1437 if (y
->ts
.type
== BT_COMPLEX
)
1439 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1440 "of either REAL or INTEGER",
1441 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1452 gfc_check_dble (gfc_expr
*x
)
1454 if (numeric_check (x
, 0) == FAILURE
)
1462 gfc_check_digits (gfc_expr
*x
)
1464 if (int_or_real_check (x
, 0) == FAILURE
)
1472 gfc_check_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1474 switch (vector_a
->ts
.type
)
1477 if (type_check (vector_b
, 1, BT_LOGICAL
) == FAILURE
)
1484 if (numeric_check (vector_b
, 1) == FAILURE
)
1489 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1490 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
1491 gfc_current_intrinsic
, &vector_a
->where
);
1495 if (rank_check (vector_a
, 0, 1) == FAILURE
)
1498 if (rank_check (vector_b
, 1, 1) == FAILURE
)
1501 if (! identical_dimen_shape (vector_a
, 0, vector_b
, 0))
1503 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1504 "intrinsic 'dot_product'", gfc_current_intrinsic_arg
[0]->name
,
1505 gfc_current_intrinsic_arg
[1]->name
, &vector_a
->where
);
1514 gfc_check_dprod (gfc_expr
*x
, gfc_expr
*y
)
1516 if (type_check (x
, 0, BT_REAL
) == FAILURE
1517 || type_check (y
, 1, BT_REAL
) == FAILURE
)
1520 if (x
->ts
.kind
!= gfc_default_real_kind
)
1522 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1523 "real", gfc_current_intrinsic_arg
[0]->name
,
1524 gfc_current_intrinsic
, &x
->where
);
1528 if (y
->ts
.kind
!= gfc_default_real_kind
)
1530 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1531 "real", gfc_current_intrinsic_arg
[1]->name
,
1532 gfc_current_intrinsic
, &y
->where
);
1541 gfc_check_dshift (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*shift
)
1543 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1546 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1549 if (i
->is_boz
&& j
->is_boz
)
1551 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1552 "constants", &i
->where
, &j
->where
);
1556 if (!i
->is_boz
&& !j
->is_boz
&& same_type_check (i
, 0, j
, 1) == FAILURE
)
1559 if (type_check (shift
, 2, BT_INTEGER
) == FAILURE
)
1562 if (nonnegative_check ("SHIFT", shift
) == FAILURE
)
1567 if (less_than_bitsize1 ("J", j
, "SHIFT", shift
, true) == FAILURE
)
1569 i
->ts
.kind
= j
->ts
.kind
;
1573 if (less_than_bitsize1 ("I", i
, "SHIFT", shift
, true) == FAILURE
)
1575 j
->ts
.kind
= i
->ts
.kind
;
1583 gfc_check_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
1586 if (array_check (array
, 0) == FAILURE
)
1589 if (type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
1592 if (dim_check (dim
, 3, true) == FAILURE
)
1595 if (dim_rank_check (dim
, array
, false) == FAILURE
)
1598 if (array
->rank
== 1 || shift
->rank
== 0)
1600 if (scalar_check (shift
, 1) == FAILURE
)
1603 else if (shift
->rank
== array
->rank
- 1)
1608 else if (dim
->expr_type
== EXPR_CONSTANT
)
1609 gfc_extract_int (dim
, &d
);
1616 for (i
= 0, j
= 0; i
< array
->rank
; i
++)
1619 if (!identical_dimen_shape (array
, i
, shift
, j
))
1621 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1622 "invalid shape in dimension %d (%ld/%ld)",
1623 gfc_current_intrinsic_arg
[1]->name
,
1624 gfc_current_intrinsic
, &shift
->where
, i
+ 1,
1625 mpz_get_si (array
->shape
[i
]),
1626 mpz_get_si (shift
->shape
[j
]));
1636 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1637 "%d or be a scalar", gfc_current_intrinsic_arg
[1]->name
,
1638 gfc_current_intrinsic
, &shift
->where
, array
->rank
- 1);
1642 if (boundary
!= NULL
)
1644 if (same_type_check (array
, 0, boundary
, 2) == FAILURE
)
1647 if (array
->rank
== 1 || boundary
->rank
== 0)
1649 if (scalar_check (boundary
, 2) == FAILURE
)
1652 else if (boundary
->rank
== array
->rank
- 1)
1654 if (gfc_check_conformance (shift
, boundary
,
1655 "arguments '%s' and '%s' for "
1657 gfc_current_intrinsic_arg
[1]->name
,
1658 gfc_current_intrinsic_arg
[2]->name
,
1659 gfc_current_intrinsic
) == FAILURE
)
1664 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1665 "rank %d or be a scalar",
1666 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
1667 &shift
->where
, array
->rank
- 1);
1676 gfc_check_float (gfc_expr
*a
)
1678 if (type_check (a
, 0, BT_INTEGER
) == FAILURE
)
1681 if ((a
->ts
.kind
!= gfc_default_integer_kind
)
1682 && gfc_notify_std (GFC_STD_GNU
, "non-default INTEGER "
1683 "kind argument to %s intrinsic at %L",
1684 gfc_current_intrinsic
, &a
->where
) == FAILURE
)
1690 /* A single complex argument. */
1693 gfc_check_fn_c (gfc_expr
*a
)
1695 if (type_check (a
, 0, BT_COMPLEX
) == FAILURE
)
1701 /* A single real argument. */
1704 gfc_check_fn_r (gfc_expr
*a
)
1706 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
1712 /* A single double argument. */
1715 gfc_check_fn_d (gfc_expr
*a
)
1717 if (double_check (a
, 0) == FAILURE
)
1723 /* A single real or complex argument. */
1726 gfc_check_fn_rc (gfc_expr
*a
)
1728 if (real_or_complex_check (a
, 0) == FAILURE
)
1736 gfc_check_fn_rc2008 (gfc_expr
*a
)
1738 if (real_or_complex_check (a
, 0) == FAILURE
)
1741 if (a
->ts
.type
== BT_COMPLEX
1742 && gfc_notify_std (GFC_STD_F2008
, "COMPLEX argument '%s' "
1743 "argument of '%s' intrinsic at %L",
1744 gfc_current_intrinsic_arg
[0]->name
,
1745 gfc_current_intrinsic
, &a
->where
) == FAILURE
)
1753 gfc_check_fnum (gfc_expr
*unit
)
1755 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
1758 if (scalar_check (unit
, 0) == FAILURE
)
1766 gfc_check_huge (gfc_expr
*x
)
1768 if (int_or_real_check (x
, 0) == FAILURE
)
1776 gfc_check_hypot (gfc_expr
*x
, gfc_expr
*y
)
1778 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
1780 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
1787 /* Check that the single argument is an integer. */
1790 gfc_check_i (gfc_expr
*i
)
1792 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1800 gfc_check_iand (gfc_expr
*i
, gfc_expr
*j
)
1802 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1805 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1808 if (i
->ts
.kind
!= j
->ts
.kind
)
1810 if (gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1811 &i
->where
) == FAILURE
)
1820 gfc_check_ibits (gfc_expr
*i
, gfc_expr
*pos
, gfc_expr
*len
)
1822 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1825 if (type_check (pos
, 1, BT_INTEGER
) == FAILURE
)
1828 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
1831 if (nonnegative_check ("pos", pos
) == FAILURE
)
1834 if (nonnegative_check ("len", len
) == FAILURE
)
1837 if (less_than_bitsize2 ("i", i
, "pos", pos
, "len", len
) == FAILURE
)
1845 gfc_check_ichar_iachar (gfc_expr
*c
, gfc_expr
*kind
)
1849 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
1852 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1855 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1856 "with KIND argument at %L",
1857 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1860 if (c
->expr_type
== EXPR_VARIABLE
|| c
->expr_type
== EXPR_SUBSTRING
)
1866 /* Substring references don't have the charlength set. */
1868 while (ref
&& ref
->type
!= REF_SUBSTRING
)
1871 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
1875 /* Check that the argument is length one. Non-constant lengths
1876 can't be checked here, so assume they are ok. */
1877 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
)
1879 /* If we already have a length for this expression then use it. */
1880 if (c
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1882 i
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1889 start
= ref
->u
.ss
.start
;
1890 end
= ref
->u
.ss
.end
;
1893 if (end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
1894 || start
->expr_type
!= EXPR_CONSTANT
)
1897 i
= mpz_get_si (end
->value
.integer
) + 1
1898 - mpz_get_si (start
->value
.integer
);
1906 gfc_error ("Argument of %s at %L must be of length one",
1907 gfc_current_intrinsic
, &c
->where
);
1916 gfc_check_idnint (gfc_expr
*a
)
1918 if (double_check (a
, 0) == FAILURE
)
1926 gfc_check_ieor (gfc_expr
*i
, gfc_expr
*j
)
1928 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
1931 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
1934 if (i
->ts
.kind
!= j
->ts
.kind
)
1936 if (gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
1937 &i
->where
) == FAILURE
)
1946 gfc_check_index (gfc_expr
*string
, gfc_expr
*substring
, gfc_expr
*back
,
1949 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
1950 || type_check (substring
, 1, BT_CHARACTER
) == FAILURE
)
1953 if (back
!= NULL
&& type_check (back
, 2, BT_LOGICAL
) == FAILURE
)
1956 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
1958 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
1959 "with KIND argument at %L",
1960 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
1963 if (string
->ts
.kind
!= substring
->ts
.kind
)
1965 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1966 "kind as '%s'", gfc_current_intrinsic_arg
[1]->name
,
1967 gfc_current_intrinsic
, &substring
->where
,
1968 gfc_current_intrinsic_arg
[0]->name
);
1977 gfc_check_int (gfc_expr
*x
, gfc_expr
*kind
)
1979 if (numeric_check (x
, 0) == FAILURE
)
1982 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
1990 gfc_check_intconv (gfc_expr
*x
)
1992 if (numeric_check (x
, 0) == FAILURE
)
2000 gfc_check_ior (gfc_expr
*i
, gfc_expr
*j
)
2002 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
2005 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
2008 if (i
->ts
.kind
!= j
->ts
.kind
)
2010 if (gfc_notify_std (GFC_STD_GNU
, "Different type kinds at %L",
2011 &i
->where
) == FAILURE
)
2020 gfc_check_ishft (gfc_expr
*i
, gfc_expr
*shift
)
2022 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
2023 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
2026 if (less_than_bitsize1 ("I", i
, NULL
, shift
, true) == FAILURE
)
2034 gfc_check_ishftc (gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
2036 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
2037 || type_check (shift
, 1, BT_INTEGER
) == FAILURE
)
2044 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
2047 if (less_than_bitsize1 ("I", i
, "SIZE", size
, true) == FAILURE
)
2050 if (size
->expr_type
== EXPR_CONSTANT
)
2052 gfc_extract_int (size
, &i3
);
2055 gfc_error ("SIZE at %L must be positive", &size
->where
);
2059 if (shift
->expr_type
== EXPR_CONSTANT
)
2061 gfc_extract_int (shift
, &i2
);
2067 gfc_error ("The absolute value of SHIFT at %L must be less "
2068 "than or equal to SIZE at %L", &shift
->where
,
2075 else if (less_than_bitsize1 ("I", i
, NULL
, shift
, true) == FAILURE
)
2083 gfc_check_kill (gfc_expr
*pid
, gfc_expr
*sig
)
2085 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
2088 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
2096 gfc_check_kill_sub (gfc_expr
*pid
, gfc_expr
*sig
, gfc_expr
*status
)
2098 if (type_check (pid
, 0, BT_INTEGER
) == FAILURE
)
2101 if (scalar_check (pid
, 0) == FAILURE
)
2104 if (type_check (sig
, 1, BT_INTEGER
) == FAILURE
)
2107 if (scalar_check (sig
, 1) == FAILURE
)
2113 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2116 if (scalar_check (status
, 2) == FAILURE
)
2124 gfc_check_kind (gfc_expr
*x
)
2126 if (x
->ts
.type
== BT_DERIVED
)
2128 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2129 "non-derived type", gfc_current_intrinsic_arg
[0]->name
,
2130 gfc_current_intrinsic
, &x
->where
);
2139 gfc_check_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2141 if (array_check (array
, 0) == FAILURE
)
2144 if (dim_check (dim
, 1, false) == FAILURE
)
2147 if (dim_rank_check (dim
, array
, 1) == FAILURE
)
2150 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2152 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2153 "with KIND argument at %L",
2154 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2162 gfc_check_lcobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
2164 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2166 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2170 if (coarray_check (coarray
, 0) == FAILURE
)
2175 if (dim_check (dim
, 1, false) == FAILURE
)
2178 if (dim_corank_check (dim
, coarray
) == FAILURE
)
2182 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
2190 gfc_check_len_lentrim (gfc_expr
*s
, gfc_expr
*kind
)
2192 if (type_check (s
, 0, BT_CHARACTER
) == FAILURE
)
2195 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
2197 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2198 "with KIND argument at %L",
2199 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
2207 gfc_check_lge_lgt_lle_llt (gfc_expr
*a
, gfc_expr
*b
)
2209 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
2211 if (kind_value_check (a
, 0, gfc_default_character_kind
) == FAILURE
)
2214 if (type_check (b
, 1, BT_CHARACTER
) == FAILURE
)
2216 if (kind_value_check (b
, 1, gfc_default_character_kind
) == FAILURE
)
2224 gfc_check_link (gfc_expr
*path1
, gfc_expr
*path2
)
2226 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2228 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2231 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2233 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2241 gfc_check_link_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2243 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2245 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2248 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2250 if (kind_value_check (path2
, 0, gfc_default_character_kind
) == FAILURE
)
2256 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2259 if (scalar_check (status
, 2) == FAILURE
)
2267 gfc_check_loc (gfc_expr
*expr
)
2269 return variable_check (expr
, 0, true);
2274 gfc_check_symlnk (gfc_expr
*path1
, gfc_expr
*path2
)
2276 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2278 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2281 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2283 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2291 gfc_check_symlnk_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
2293 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
2295 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
2298 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
2300 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
2306 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
2309 if (scalar_check (status
, 2) == FAILURE
)
2317 gfc_check_logical (gfc_expr
*a
, gfc_expr
*kind
)
2319 if (type_check (a
, 0, BT_LOGICAL
) == FAILURE
)
2321 if (kind_check (kind
, 1, BT_LOGICAL
) == FAILURE
)
2328 /* Min/max family. */
2331 min_max_args (gfc_actual_arglist
*arg
)
2333 if (arg
== NULL
|| arg
->next
== NULL
)
2335 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2336 gfc_current_intrinsic
, gfc_current_intrinsic_where
);
2345 check_rest (bt type
, int kind
, gfc_actual_arglist
*arglist
)
2347 gfc_actual_arglist
*arg
, *tmp
;
2352 if (min_max_args (arglist
) == FAILURE
)
2355 for (arg
= arglist
, n
=1; arg
; arg
= arg
->next
, n
++)
2358 if (x
->ts
.type
!= type
|| x
->ts
.kind
!= kind
)
2360 if (x
->ts
.type
== type
)
2362 if (gfc_notify_std (GFC_STD_GNU
, "Different type "
2363 "kinds at %L", &x
->where
) == FAILURE
)
2368 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2369 "%s(%d)", n
, gfc_current_intrinsic
, &x
->where
,
2370 gfc_basic_typename (type
), kind
);
2375 for (tmp
= arglist
, m
=1; tmp
!= arg
; tmp
= tmp
->next
, m
++)
2376 if (gfc_check_conformance (tmp
->expr
, x
,
2377 "arguments 'a%d' and 'a%d' for "
2378 "intrinsic '%s'", m
, n
,
2379 gfc_current_intrinsic
) == FAILURE
)
2388 gfc_check_min_max (gfc_actual_arglist
*arg
)
2392 if (min_max_args (arg
) == FAILURE
)
2397 if (x
->ts
.type
== BT_CHARACTER
)
2399 if (gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
2400 "with CHARACTER argument at %L",
2401 gfc_current_intrinsic
, &x
->where
) == FAILURE
)
2404 else if (x
->ts
.type
!= BT_INTEGER
&& x
->ts
.type
!= BT_REAL
)
2406 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2407 "REAL or CHARACTER", gfc_current_intrinsic
, &x
->where
);
2411 return check_rest (x
->ts
.type
, x
->ts
.kind
, arg
);
2416 gfc_check_min_max_integer (gfc_actual_arglist
*arg
)
2418 return check_rest (BT_INTEGER
, gfc_default_integer_kind
, arg
);
2423 gfc_check_min_max_real (gfc_actual_arglist
*arg
)
2425 return check_rest (BT_REAL
, gfc_default_real_kind
, arg
);
2430 gfc_check_min_max_double (gfc_actual_arglist
*arg
)
2432 return check_rest (BT_REAL
, gfc_default_double_kind
, arg
);
2436 /* End of min/max family. */
2439 gfc_check_malloc (gfc_expr
*size
)
2441 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
2444 if (scalar_check (size
, 0) == FAILURE
)
2452 gfc_check_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
2454 if ((matrix_a
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_a
->ts
))
2456 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2457 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
2458 gfc_current_intrinsic
, &matrix_a
->where
);
2462 if ((matrix_b
->ts
.type
!= BT_LOGICAL
) && !gfc_numeric_ts (&matrix_b
->ts
))
2464 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2465 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
2466 gfc_current_intrinsic
, &matrix_b
->where
);
2470 if ((matrix_a
->ts
.type
== BT_LOGICAL
&& gfc_numeric_ts (&matrix_b
->ts
))
2471 || (gfc_numeric_ts (&matrix_a
->ts
) && matrix_b
->ts
.type
== BT_LOGICAL
))
2473 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2474 gfc_current_intrinsic
, &matrix_a
->where
,
2475 gfc_typename(&matrix_a
->ts
), gfc_typename(&matrix_b
->ts
));
2479 switch (matrix_a
->rank
)
2482 if (rank_check (matrix_b
, 1, 2) == FAILURE
)
2484 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2485 if (!identical_dimen_shape (matrix_a
, 0, matrix_b
, 0))
2487 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2488 "and '%s' at %L for intrinsic matmul",
2489 gfc_current_intrinsic_arg
[0]->name
,
2490 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2496 if (matrix_b
->rank
!= 2)
2498 if (rank_check (matrix_b
, 1, 1) == FAILURE
)
2501 /* matrix_b has rank 1 or 2 here. Common check for the cases
2502 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2503 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2504 if (!identical_dimen_shape (matrix_a
, 1, matrix_b
, 0))
2506 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2507 "dimension 1 for argument '%s' at %L for intrinsic "
2508 "matmul", gfc_current_intrinsic_arg
[0]->name
,
2509 gfc_current_intrinsic_arg
[1]->name
, &matrix_a
->where
);
2515 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2516 "1 or 2", gfc_current_intrinsic_arg
[0]->name
,
2517 gfc_current_intrinsic
, &matrix_a
->where
);
2525 /* Whoever came up with this interface was probably on something.
2526 The possibilities for the occupation of the second and third
2533 NULL MASK minloc(array, mask=m)
2536 I.e. in the case of minloc(array,mask), mask will be in the second
2537 position of the argument list and we'll have to fix that up. */
2540 gfc_check_minloc_maxloc (gfc_actual_arglist
*ap
)
2542 gfc_expr
*a
, *m
, *d
;
2545 if (int_or_real_check (a
, 0) == FAILURE
|| array_check (a
, 0) == FAILURE
)
2549 m
= ap
->next
->next
->expr
;
2551 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2552 && ap
->next
->name
== NULL
)
2556 ap
->next
->expr
= NULL
;
2557 ap
->next
->next
->expr
= m
;
2560 if (dim_check (d
, 1, false) == FAILURE
)
2563 if (dim_rank_check (d
, a
, 0) == FAILURE
)
2566 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
2570 && gfc_check_conformance (a
, m
,
2571 "arguments '%s' and '%s' for intrinsic %s",
2572 gfc_current_intrinsic_arg
[0]->name
,
2573 gfc_current_intrinsic_arg
[2]->name
,
2574 gfc_current_intrinsic
) == FAILURE
)
2581 /* Similar to minloc/maxloc, the argument list might need to be
2582 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2583 difference is that MINLOC/MAXLOC take an additional KIND argument.
2584 The possibilities are:
2590 NULL MASK minval(array, mask=m)
2593 I.e. in the case of minval(array,mask), mask will be in the second
2594 position of the argument list and we'll have to fix that up. */
2597 check_reduction (gfc_actual_arglist
*ap
)
2599 gfc_expr
*a
, *m
, *d
;
2603 m
= ap
->next
->next
->expr
;
2605 if (m
== NULL
&& d
!= NULL
&& d
->ts
.type
== BT_LOGICAL
2606 && ap
->next
->name
== NULL
)
2610 ap
->next
->expr
= NULL
;
2611 ap
->next
->next
->expr
= m
;
2614 if (dim_check (d
, 1, false) == FAILURE
)
2617 if (dim_rank_check (d
, a
, 0) == FAILURE
)
2620 if (m
!= NULL
&& type_check (m
, 2, BT_LOGICAL
) == FAILURE
)
2624 && gfc_check_conformance (a
, m
,
2625 "arguments '%s' and '%s' for intrinsic %s",
2626 gfc_current_intrinsic_arg
[0]->name
,
2627 gfc_current_intrinsic_arg
[2]->name
,
2628 gfc_current_intrinsic
) == FAILURE
)
2636 gfc_check_minval_maxval (gfc_actual_arglist
*ap
)
2638 if (int_or_real_check (ap
->expr
, 0) == FAILURE
2639 || array_check (ap
->expr
, 0) == FAILURE
)
2642 return check_reduction (ap
);
2647 gfc_check_product_sum (gfc_actual_arglist
*ap
)
2649 if (numeric_check (ap
->expr
, 0) == FAILURE
2650 || array_check (ap
->expr
, 0) == FAILURE
)
2653 return check_reduction (ap
);
2657 /* For IANY, IALL and IPARITY. */
2660 gfc_check_mask (gfc_expr
*i
, gfc_expr
*kind
)
2664 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
2667 if (nonnegative_check ("I", i
) == FAILURE
)
2670 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
2674 gfc_extract_int (kind
, &k
);
2676 k
= gfc_default_integer_kind
;
2678 if (less_than_bitsizekind ("I", i
, k
) == FAILURE
)
2686 gfc_check_transf_bit_intrins (gfc_actual_arglist
*ap
)
2688 if (ap
->expr
->ts
.type
!= BT_INTEGER
)
2690 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2691 gfc_current_intrinsic_arg
[0]->name
,
2692 gfc_current_intrinsic
, &ap
->expr
->where
);
2696 if (array_check (ap
->expr
, 0) == FAILURE
)
2699 return check_reduction (ap
);
2704 gfc_check_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
2706 if (same_type_check (tsource
, 0, fsource
, 1) == FAILURE
)
2709 if (type_check (mask
, 2, BT_LOGICAL
) == FAILURE
)
2712 if (tsource
->ts
.type
== BT_CHARACTER
)
2713 return gfc_check_same_strlen (tsource
, fsource
, "MERGE intrinsic");
2720 gfc_check_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask
)
2722 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
2725 if (type_check (j
, 1, BT_INTEGER
) == FAILURE
)
2728 if (type_check (mask
, 2, BT_INTEGER
) == FAILURE
)
2731 if (same_type_check (i
, 0, j
, 1) == FAILURE
)
2734 if (same_type_check (i
, 0, mask
, 2) == FAILURE
)
2742 gfc_check_move_alloc (gfc_expr
*from
, gfc_expr
*to
)
2744 if (variable_check (from
, 0, false) == FAILURE
)
2746 if (allocatable_check (from
, 0) == FAILURE
)
2748 if (gfc_is_coindexed (from
))
2750 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
2751 "coindexed", &from
->where
);
2755 if (variable_check (to
, 1, false) == FAILURE
)
2757 if (allocatable_check (to
, 1) == FAILURE
)
2759 if (gfc_is_coindexed (to
))
2761 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
2762 "coindexed", &to
->where
);
2766 if (from
->ts
.type
== BT_CLASS
&& to
->ts
.type
== BT_DERIVED
)
2768 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2769 "polymorphic if FROM is polymorphic",
2774 if (same_type_check (to
, 1, from
, 0) == FAILURE
)
2777 if (to
->rank
!= from
->rank
)
2779 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2780 "must have the same rank %d/%d", &to
->where
, from
->rank
,
2785 /* IR F08/0040; cf. 12-006A. */
2786 if (gfc_get_corank (to
) != gfc_get_corank (from
))
2788 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2789 "must have the same corank %d/%d", &to
->where
,
2790 gfc_get_corank (from
), gfc_get_corank (to
));
2794 if (to
->ts
.kind
!= from
->ts
.kind
)
2796 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L"
2797 " must be of the same kind %d/%d", &to
->where
, from
->ts
.kind
,
2802 /* CLASS arguments: Make sure the vtab of from is present. */
2803 if (to
->ts
.type
== BT_CLASS
)
2804 gfc_find_derived_vtab (from
->ts
.u
.derived
);
2811 gfc_check_nearest (gfc_expr
*x
, gfc_expr
*s
)
2813 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
2816 if (type_check (s
, 1, BT_REAL
) == FAILURE
)
2819 if (s
->expr_type
== EXPR_CONSTANT
)
2821 if (mpfr_sgn (s
->value
.real
) == 0)
2823 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2834 gfc_check_new_line (gfc_expr
*a
)
2836 if (type_check (a
, 0, BT_CHARACTER
) == FAILURE
)
2844 gfc_check_norm2 (gfc_expr
*array
, gfc_expr
*dim
)
2846 if (type_check (array
, 0, BT_REAL
) == FAILURE
)
2849 if (array_check (array
, 0) == FAILURE
)
2852 if (dim_rank_check (dim
, array
, false) == FAILURE
)
2859 gfc_check_null (gfc_expr
*mold
)
2861 symbol_attribute attr
;
2866 if (variable_check (mold
, 0, true) == FAILURE
)
2869 attr
= gfc_variable_attr (mold
, NULL
);
2871 if (!attr
.pointer
&& !attr
.proc_pointer
&& !attr
.allocatable
)
2873 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2874 "ALLOCATABLE or procedure pointer",
2875 gfc_current_intrinsic_arg
[0]->name
,
2876 gfc_current_intrinsic
, &mold
->where
);
2880 if (attr
.allocatable
2881 && gfc_notify_std (GFC_STD_F2003
, "NULL intrinsic with "
2882 "allocatable MOLD at %L", &mold
->where
) == FAILURE
)
2886 if (gfc_is_coindexed (mold
))
2888 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2889 "coindexed", gfc_current_intrinsic_arg
[0]->name
,
2890 gfc_current_intrinsic
, &mold
->where
);
2899 gfc_check_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
2901 if (array_check (array
, 0) == FAILURE
)
2904 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
2907 if (gfc_check_conformance (array
, mask
,
2908 "arguments '%s' and '%s' for intrinsic '%s'",
2909 gfc_current_intrinsic_arg
[0]->name
,
2910 gfc_current_intrinsic_arg
[1]->name
,
2911 gfc_current_intrinsic
) == FAILURE
)
2916 mpz_t array_size
, vector_size
;
2917 bool have_array_size
, have_vector_size
;
2919 if (same_type_check (array
, 0, vector
, 2) == FAILURE
)
2922 if (rank_check (vector
, 2, 1) == FAILURE
)
2925 /* VECTOR requires at least as many elements as MASK
2926 has .TRUE. values. */
2927 have_array_size
= gfc_array_size (array
, &array_size
) == SUCCESS
;
2928 have_vector_size
= gfc_array_size (vector
, &vector_size
) == SUCCESS
;
2930 if (have_vector_size
2931 && (mask
->expr_type
== EXPR_ARRAY
2932 || (mask
->expr_type
== EXPR_CONSTANT
2933 && have_array_size
)))
2935 int mask_true_values
= 0;
2937 if (mask
->expr_type
== EXPR_ARRAY
)
2939 gfc_constructor
*mask_ctor
;
2940 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
2943 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
2945 mask_true_values
= 0;
2949 if (mask_ctor
->expr
->value
.logical
)
2952 mask_ctor
= gfc_constructor_next (mask_ctor
);
2955 else if (mask
->expr_type
== EXPR_CONSTANT
&& mask
->value
.logical
)
2956 mask_true_values
= mpz_get_si (array_size
);
2958 if (mpz_get_si (vector_size
) < mask_true_values
)
2960 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2961 "provide at least as many elements as there "
2962 "are .TRUE. values in '%s' (%ld/%d)",
2963 gfc_current_intrinsic_arg
[2]->name
,
2964 gfc_current_intrinsic
, &vector
->where
,
2965 gfc_current_intrinsic_arg
[1]->name
,
2966 mpz_get_si (vector_size
), mask_true_values
);
2971 if (have_array_size
)
2972 mpz_clear (array_size
);
2973 if (have_vector_size
)
2974 mpz_clear (vector_size
);
2982 gfc_check_parity (gfc_expr
*mask
, gfc_expr
*dim
)
2984 if (type_check (mask
, 0, BT_LOGICAL
) == FAILURE
)
2987 if (array_check (mask
, 0) == FAILURE
)
2990 if (dim_rank_check (dim
, mask
, false) == FAILURE
)
2998 gfc_check_precision (gfc_expr
*x
)
3000 if (real_or_complex_check (x
, 0) == FAILURE
)
3008 gfc_check_present (gfc_expr
*a
)
3012 if (variable_check (a
, 0, true) == FAILURE
)
3015 sym
= a
->symtree
->n
.sym
;
3016 if (!sym
->attr
.dummy
)
3018 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3019 "dummy variable", gfc_current_intrinsic_arg
[0]->name
,
3020 gfc_current_intrinsic
, &a
->where
);
3024 if (!sym
->attr
.optional
)
3026 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3027 "an OPTIONAL dummy variable",
3028 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3033 /* 13.14.82 PRESENT(A)
3035 Argument. A shall be the name of an optional dummy argument that is
3036 accessible in the subprogram in which the PRESENT function reference
3040 && !(a
->ref
->next
== NULL
&& a
->ref
->type
== REF_ARRAY
3041 && (a
->ref
->u
.ar
.type
== AR_FULL
3042 || (a
->ref
->u
.ar
.type
== AR_ELEMENT
3043 && a
->ref
->u
.ar
.as
->rank
== 0))))
3045 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3046 "subobject of '%s'", gfc_current_intrinsic_arg
[0]->name
,
3047 gfc_current_intrinsic
, &a
->where
, sym
->name
);
3056 gfc_check_radix (gfc_expr
*x
)
3058 if (int_or_real_check (x
, 0) == FAILURE
)
3066 gfc_check_range (gfc_expr
*x
)
3068 if (numeric_check (x
, 0) == FAILURE
)
3076 gfc_check_rank (gfc_expr
*a ATTRIBUTE_UNUSED
)
3078 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3079 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3081 bool is_variable
= true;
3083 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3084 if (a
->expr_type
== EXPR_FUNCTION
)
3085 is_variable
= a
->value
.function
.esym
3086 ? a
->value
.function
.esym
->result
->attr
.pointer
3087 : a
->symtree
->n
.sym
->result
->attr
.pointer
;
3089 if (a
->expr_type
== EXPR_OP
|| a
->expr_type
== EXPR_NULL
3090 || a
->expr_type
== EXPR_COMPCALL
|| a
->expr_type
== EXPR_PPC
3093 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3094 "object", &a
->where
);
3102 /* real, float, sngl. */
3104 gfc_check_real (gfc_expr
*a
, gfc_expr
*kind
)
3106 if (numeric_check (a
, 0) == FAILURE
)
3109 if (kind_check (kind
, 1, BT_REAL
) == FAILURE
)
3117 gfc_check_rename (gfc_expr
*path1
, gfc_expr
*path2
)
3119 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
3121 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
3124 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
3126 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
3134 gfc_check_rename_sub (gfc_expr
*path1
, gfc_expr
*path2
, gfc_expr
*status
)
3136 if (type_check (path1
, 0, BT_CHARACTER
) == FAILURE
)
3138 if (kind_value_check (path1
, 0, gfc_default_character_kind
) == FAILURE
)
3141 if (type_check (path2
, 1, BT_CHARACTER
) == FAILURE
)
3143 if (kind_value_check (path2
, 1, gfc_default_character_kind
) == FAILURE
)
3149 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
3152 if (scalar_check (status
, 2) == FAILURE
)
3160 gfc_check_repeat (gfc_expr
*x
, gfc_expr
*y
)
3162 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
3165 if (scalar_check (x
, 0) == FAILURE
)
3168 if (type_check (y
, 0, BT_INTEGER
) == FAILURE
)
3171 if (scalar_check (y
, 1) == FAILURE
)
3179 gfc_check_reshape (gfc_expr
*source
, gfc_expr
*shape
,
3180 gfc_expr
*pad
, gfc_expr
*order
)
3186 if (array_check (source
, 0) == FAILURE
)
3189 if (rank_check (shape
, 1, 1) == FAILURE
)
3192 if (type_check (shape
, 1, BT_INTEGER
) == FAILURE
)
3195 if (gfc_array_size (shape
, &size
) != SUCCESS
)
3197 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3198 "array of constant size", &shape
->where
);
3202 shape_size
= mpz_get_ui (size
);
3205 if (shape_size
<= 0)
3207 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3208 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3212 else if (shape_size
> GFC_MAX_DIMENSIONS
)
3214 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3215 "than %d elements", &shape
->where
, GFC_MAX_DIMENSIONS
);
3218 else if (shape
->expr_type
== EXPR_ARRAY
)
3222 for (i
= 0; i
< shape_size
; ++i
)
3224 e
= gfc_constructor_lookup_expr (shape
->value
.constructor
, i
);
3225 if (e
->expr_type
!= EXPR_CONSTANT
)
3228 gfc_extract_int (e
, &extent
);
3231 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3232 "negative element (%d)",
3233 gfc_current_intrinsic_arg
[1]->name
,
3234 gfc_current_intrinsic
, &e
->where
, extent
);
3242 if (same_type_check (source
, 0, pad
, 2) == FAILURE
)
3245 if (array_check (pad
, 2) == FAILURE
)
3251 if (array_check (order
, 3) == FAILURE
)
3254 if (type_check (order
, 3, BT_INTEGER
) == FAILURE
)
3257 if (order
->expr_type
== EXPR_ARRAY
)
3259 int i
, order_size
, dim
, perm
[GFC_MAX_DIMENSIONS
];
3262 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; ++i
)
3265 gfc_array_size (order
, &size
);
3266 order_size
= mpz_get_ui (size
);
3269 if (order_size
!= shape_size
)
3271 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3272 "has wrong number of elements (%d/%d)",
3273 gfc_current_intrinsic_arg
[3]->name
,
3274 gfc_current_intrinsic
, &order
->where
,
3275 order_size
, shape_size
);
3279 for (i
= 1; i
<= order_size
; ++i
)
3281 e
= gfc_constructor_lookup_expr (order
->value
.constructor
, i
-1);
3282 if (e
->expr_type
!= EXPR_CONSTANT
)
3285 gfc_extract_int (e
, &dim
);
3287 if (dim
< 1 || dim
> order_size
)
3289 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3290 "has out-of-range dimension (%d)",
3291 gfc_current_intrinsic_arg
[3]->name
,
3292 gfc_current_intrinsic
, &e
->where
, dim
);
3296 if (perm
[dim
-1] != 0)
3298 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3299 "invalid permutation of dimensions (dimension "
3301 gfc_current_intrinsic_arg
[3]->name
,
3302 gfc_current_intrinsic
, &e
->where
, dim
);
3311 if (pad
== NULL
&& shape
->expr_type
== EXPR_ARRAY
3312 && gfc_is_constant_expr (shape
)
3313 && !(source
->expr_type
== EXPR_VARIABLE
&& source
->symtree
->n
.sym
->as
3314 && source
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
))
3316 /* Check the match in size between source and destination. */
3317 if (gfc_array_size (source
, &nelems
) == SUCCESS
)
3323 mpz_init_set_ui (size
, 1);
3324 for (c
= gfc_constructor_first (shape
->value
.constructor
);
3325 c
; c
= gfc_constructor_next (c
))
3326 mpz_mul (size
, size
, c
->expr
->value
.integer
);
3328 test
= mpz_cmp (nelems
, size
) < 0 && mpz_cmp_ui (size
, 0) > 0;
3334 gfc_error ("Without padding, there are not enough elements "
3335 "in the intrinsic RESHAPE source at %L to match "
3336 "the shape", &source
->where
);
3347 gfc_check_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3349 if (a
->ts
.type
!= BT_DERIVED
&& a
->ts
.type
!= BT_CLASS
)
3351 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3352 "cannot be of type %s",
3353 gfc_current_intrinsic_arg
[0]->name
,
3354 gfc_current_intrinsic
,
3355 &a
->where
, gfc_typename (&a
->ts
));
3359 if (!(gfc_type_is_extensible (a
->ts
.u
.derived
) || UNLIMITED_POLY (a
)))
3361 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3362 "must be of an extensible type",
3363 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3368 if (b
->ts
.type
!= BT_DERIVED
&& b
->ts
.type
!= BT_CLASS
)
3370 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3371 "cannot be of type %s",
3372 gfc_current_intrinsic_arg
[0]->name
,
3373 gfc_current_intrinsic
,
3374 &b
->where
, gfc_typename (&b
->ts
));
3378 if (!(gfc_type_is_extensible (b
->ts
.u
.derived
) || UNLIMITED_POLY (b
)))
3380 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3381 "must be of an extensible type",
3382 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
3392 gfc_check_scale (gfc_expr
*x
, gfc_expr
*i
)
3394 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3397 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
3405 gfc_check_scan (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
3407 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
3410 if (type_check (y
, 1, BT_CHARACTER
) == FAILURE
)
3413 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
3416 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
3418 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3419 "with KIND argument at %L",
3420 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3423 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
3431 gfc_check_secnds (gfc_expr
*r
)
3433 if (type_check (r
, 0, BT_REAL
) == FAILURE
)
3436 if (kind_value_check (r
, 0, 4) == FAILURE
)
3439 if (scalar_check (r
, 0) == FAILURE
)
3447 gfc_check_selected_char_kind (gfc_expr
*name
)
3449 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3452 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3455 if (scalar_check (name
, 0) == FAILURE
)
3463 gfc_check_selected_int_kind (gfc_expr
*r
)
3465 if (type_check (r
, 0, BT_INTEGER
) == FAILURE
)
3468 if (scalar_check (r
, 0) == FAILURE
)
3476 gfc_check_selected_real_kind (gfc_expr
*p
, gfc_expr
*r
, gfc_expr
*radix
)
3478 if (p
== NULL
&& r
== NULL
3479 && gfc_notify_std (GFC_STD_F2008
, "SELECTED_REAL_KIND with"
3480 " neither 'P' nor 'R' argument at %L",
3481 gfc_current_intrinsic_where
) == FAILURE
)
3486 if (type_check (p
, 0, BT_INTEGER
) == FAILURE
)
3489 if (scalar_check (p
, 0) == FAILURE
)
3495 if (type_check (r
, 1, BT_INTEGER
) == FAILURE
)
3498 if (scalar_check (r
, 1) == FAILURE
)
3504 if (type_check (radix
, 1, BT_INTEGER
) == FAILURE
)
3507 if (scalar_check (radix
, 1) == FAILURE
)
3510 if (gfc_notify_std (GFC_STD_F2008
, "'%s' intrinsic with "
3511 "RADIX argument at %L", gfc_current_intrinsic
,
3512 &radix
->where
) == FAILURE
)
3521 gfc_check_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3523 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
3526 if (type_check (i
, 1, BT_INTEGER
) == FAILURE
)
3534 gfc_check_shape (gfc_expr
*source
, gfc_expr
*kind
)
3538 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3541 ar
= gfc_find_array_ref (source
);
3543 if (ar
->as
&& ar
->as
->type
== AS_ASSUMED_SIZE
&& ar
->type
== AR_FULL
)
3545 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3546 "an assumed size array", &source
->where
);
3550 if (kind_check (kind
, 1, BT_INTEGER
) == FAILURE
)
3552 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3553 "with KIND argument at %L",
3554 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3562 gfc_check_shift (gfc_expr
*i
, gfc_expr
*shift
)
3564 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
3567 if (type_check (shift
, 0, BT_INTEGER
) == FAILURE
)
3570 if (nonnegative_check ("SHIFT", shift
) == FAILURE
)
3573 if (less_than_bitsize1 ("I", i
, "SHIFT", shift
, true) == FAILURE
)
3581 gfc_check_sign (gfc_expr
*a
, gfc_expr
*b
)
3583 if (int_or_real_check (a
, 0) == FAILURE
)
3586 if (same_type_check (a
, 0, b
, 1) == FAILURE
)
3594 gfc_check_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3596 if (array_check (array
, 0) == FAILURE
)
3599 if (dim_check (dim
, 1, true) == FAILURE
)
3602 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
3605 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
3607 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
3608 "with KIND argument at %L",
3609 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
3618 gfc_check_sizeof (gfc_expr
*arg
)
3620 if (arg
->ts
.type
== BT_PROCEDURE
)
3622 gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
3623 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3632 gfc_check_c_sizeof (gfc_expr
*arg
)
3634 if (gfc_verify_c_interop (&arg
->ts
) != SUCCESS
)
3636 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3637 "interoperable data entity",
3638 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
3647 gfc_check_sleep_sub (gfc_expr
*seconds
)
3649 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
3652 if (scalar_check (seconds
, 0) == FAILURE
)
3659 gfc_check_sngl (gfc_expr
*a
)
3661 if (type_check (a
, 0, BT_REAL
) == FAILURE
)
3664 if ((a
->ts
.kind
!= gfc_default_double_kind
)
3665 && gfc_notify_std (GFC_STD_GNU
, "non double precision "
3666 "REAL argument to %s intrinsic at %L",
3667 gfc_current_intrinsic
, &a
->where
) == FAILURE
)
3674 gfc_check_spread (gfc_expr
*source
, gfc_expr
*dim
, gfc_expr
*ncopies
)
3676 if (source
->rank
>= GFC_MAX_DIMENSIONS
)
3678 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3679 "than rank %d", gfc_current_intrinsic_arg
[0]->name
,
3680 gfc_current_intrinsic
, &source
->where
, GFC_MAX_DIMENSIONS
);
3688 if (dim_check (dim
, 1, false) == FAILURE
)
3691 /* dim_rank_check() does not apply here. */
3693 && dim
->expr_type
== EXPR_CONSTANT
3694 && (mpz_cmp_ui (dim
->value
.integer
, 1) < 0
3695 || mpz_cmp_ui (dim
->value
.integer
, source
->rank
+ 1) > 0))
3697 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3698 "dimension index", gfc_current_intrinsic_arg
[1]->name
,
3699 gfc_current_intrinsic
, &dim
->where
);
3703 if (type_check (ncopies
, 2, BT_INTEGER
) == FAILURE
)
3706 if (scalar_check (ncopies
, 2) == FAILURE
)
3713 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3717 gfc_check_fgetputc_sub (gfc_expr
*unit
, gfc_expr
*c
, gfc_expr
*status
)
3719 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3722 if (scalar_check (unit
, 0) == FAILURE
)
3725 if (type_check (c
, 1, BT_CHARACTER
) == FAILURE
)
3727 if (kind_value_check (c
, 1, gfc_default_character_kind
) == FAILURE
)
3733 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3734 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
3735 || scalar_check (status
, 2) == FAILURE
)
3743 gfc_check_fgetputc (gfc_expr
*unit
, gfc_expr
*c
)
3745 return gfc_check_fgetputc_sub (unit
, c
, NULL
);
3750 gfc_check_fgetput_sub (gfc_expr
*c
, gfc_expr
*status
)
3752 if (type_check (c
, 0, BT_CHARACTER
) == FAILURE
)
3754 if (kind_value_check (c
, 0, gfc_default_character_kind
) == FAILURE
)
3760 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
3761 || kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
3762 || scalar_check (status
, 1) == FAILURE
)
3770 gfc_check_fgetput (gfc_expr
*c
)
3772 return gfc_check_fgetput_sub (c
, NULL
);
3777 gfc_check_fseek_sub (gfc_expr
*unit
, gfc_expr
*offset
, gfc_expr
*whence
, gfc_expr
*status
)
3779 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3782 if (scalar_check (unit
, 0) == FAILURE
)
3785 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
3788 if (scalar_check (offset
, 1) == FAILURE
)
3791 if (type_check (whence
, 2, BT_INTEGER
) == FAILURE
)
3794 if (scalar_check (whence
, 2) == FAILURE
)
3800 if (type_check (status
, 3, BT_INTEGER
) == FAILURE
)
3803 if (kind_value_check (status
, 3, 4) == FAILURE
)
3806 if (scalar_check (status
, 3) == FAILURE
)
3815 gfc_check_fstat (gfc_expr
*unit
, gfc_expr
*array
)
3817 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3820 if (scalar_check (unit
, 0) == FAILURE
)
3823 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3824 || kind_value_check (unit
, 0, gfc_default_integer_kind
) == FAILURE
)
3827 if (array_check (array
, 1) == FAILURE
)
3835 gfc_check_fstat_sub (gfc_expr
*unit
, gfc_expr
*array
, gfc_expr
*status
)
3837 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3840 if (scalar_check (unit
, 0) == FAILURE
)
3843 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3844 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3847 if (array_check (array
, 1) == FAILURE
)
3853 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3854 || kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
3857 if (scalar_check (status
, 2) == FAILURE
)
3865 gfc_check_ftell (gfc_expr
*unit
)
3867 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3870 if (scalar_check (unit
, 0) == FAILURE
)
3878 gfc_check_ftell_sub (gfc_expr
*unit
, gfc_expr
*offset
)
3880 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
3883 if (scalar_check (unit
, 0) == FAILURE
)
3886 if (type_check (offset
, 1, BT_INTEGER
) == FAILURE
)
3889 if (scalar_check (offset
, 1) == FAILURE
)
3897 gfc_check_stat (gfc_expr
*name
, gfc_expr
*array
)
3899 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3901 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3904 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3905 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3908 if (array_check (array
, 1) == FAILURE
)
3916 gfc_check_stat_sub (gfc_expr
*name
, gfc_expr
*array
, gfc_expr
*status
)
3918 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
3920 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
3923 if (type_check (array
, 1, BT_INTEGER
) == FAILURE
3924 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3927 if (array_check (array
, 1) == FAILURE
)
3933 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
3934 || kind_value_check (array
, 1, gfc_default_integer_kind
) == FAILURE
)
3937 if (scalar_check (status
, 2) == FAILURE
)
3945 gfc_check_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
3949 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
3951 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3955 if (coarray_check (coarray
, 0) == FAILURE
)
3960 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3961 gfc_current_intrinsic_arg
[1]->name
, &sub
->where
);
3965 if (gfc_array_size (sub
, &nelems
) == SUCCESS
)
3967 int corank
= gfc_get_corank (coarray
);
3969 if (mpz_cmp_ui (nelems
, corank
) != 0)
3971 gfc_error ("The number of array elements of the SUB argument to "
3972 "IMAGE_INDEX at %L shall be %d (corank) not %d",
3973 &sub
->where
, corank
, (int) mpz_get_si (nelems
));
3985 gfc_check_this_image (gfc_expr
*coarray
, gfc_expr
*dim
)
3987 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
3989 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3993 if (dim
!= NULL
&& coarray
== NULL
)
3995 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3996 "intrinsic at %L", &dim
->where
);
4000 if (coarray
== NULL
)
4003 if (coarray_check (coarray
, 0) == FAILURE
)
4008 if (dim_check (dim
, 1, false) == FAILURE
)
4011 if (dim_corank_check (dim
, coarray
) == FAILURE
)
4018 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4019 by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
4022 gfc_calculate_transfer_sizes (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
,
4023 size_t *source_size
, size_t *result_size
,
4024 size_t *result_length_p
)
4026 size_t result_elt_size
;
4028 gfc_expr
*mold_element
;
4030 if (source
->expr_type
== EXPR_FUNCTION
)
4033 if (size
&& size
->expr_type
!= EXPR_CONSTANT
)
4036 /* Calculate the size of the source. */
4037 if (source
->expr_type
== EXPR_ARRAY
4038 && gfc_array_size (source
, &tmp
) == FAILURE
)
4041 *source_size
= gfc_target_expr_size (source
);
4042 if (*source_size
== 0)
4045 mold_element
= mold
->expr_type
== EXPR_ARRAY
4046 ? gfc_constructor_first (mold
->value
.constructor
)->expr
4049 /* Determine the size of the element. */
4050 result_elt_size
= gfc_target_expr_size (mold_element
);
4051 if (result_elt_size
== 0)
4054 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
4059 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
4062 result_length
= *source_size
/ result_elt_size
;
4063 if (result_length
* result_elt_size
< *source_size
)
4067 *result_size
= result_length
* result_elt_size
;
4068 if (result_length_p
)
4069 *result_length_p
= result_length
;
4072 *result_size
= result_elt_size
;
4079 gfc_check_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
4084 if (mold
->ts
.type
== BT_HOLLERITH
)
4086 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4087 &mold
->where
, gfc_basic_typename (BT_HOLLERITH
));
4093 if (type_check (size
, 2, BT_INTEGER
) == FAILURE
)
4096 if (scalar_check (size
, 2) == FAILURE
)
4099 if (nonoptional_check (size
, 2) == FAILURE
)
4103 if (!gfc_option
.warn_surprising
)
4106 /* If we can't calculate the sizes, we cannot check any more.
4107 Return SUCCESS for that case. */
4109 if (gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
4110 &result_size
, NULL
) == FAILURE
)
4113 if (source_size
< result_size
)
4114 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4115 "source size %ld < result size %ld", &source
->where
,
4116 (long) source_size
, (long) result_size
);
4123 gfc_check_transpose (gfc_expr
*matrix
)
4125 if (rank_check (matrix
, 0, 2) == FAILURE
)
4133 gfc_check_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4135 if (array_check (array
, 0) == FAILURE
)
4138 if (dim_check (dim
, 1, false) == FAILURE
)
4141 if (dim_rank_check (dim
, array
, 0) == FAILURE
)
4144 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
4146 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4147 "with KIND argument at %L",
4148 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
4156 gfc_check_ucobound (gfc_expr
*coarray
, gfc_expr
*dim
, gfc_expr
*kind
)
4158 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4160 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4164 if (coarray_check (coarray
, 0) == FAILURE
)
4169 if (dim_check (dim
, 1, false) == FAILURE
)
4172 if (dim_corank_check (dim
, coarray
) == FAILURE
)
4176 if (kind_check (kind
, 2, BT_INTEGER
) == FAILURE
)
4184 gfc_check_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
4188 if (rank_check (vector
, 0, 1) == FAILURE
)
4191 if (array_check (mask
, 1) == FAILURE
)
4194 if (type_check (mask
, 1, BT_LOGICAL
) == FAILURE
)
4197 if (same_type_check (vector
, 0, field
, 2) == FAILURE
)
4200 if (mask
->expr_type
== EXPR_ARRAY
4201 && gfc_array_size (vector
, &vector_size
) == SUCCESS
)
4203 int mask_true_count
= 0;
4204 gfc_constructor
*mask_ctor
;
4205 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4208 if (mask_ctor
->expr
->expr_type
!= EXPR_CONSTANT
)
4210 mask_true_count
= 0;
4214 if (mask_ctor
->expr
->value
.logical
)
4217 mask_ctor
= gfc_constructor_next (mask_ctor
);
4220 if (mpz_get_si (vector_size
) < mask_true_count
)
4222 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4223 "provide at least as many elements as there "
4224 "are .TRUE. values in '%s' (%ld/%d)",
4225 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4226 &vector
->where
, gfc_current_intrinsic_arg
[1]->name
,
4227 mpz_get_si (vector_size
), mask_true_count
);
4231 mpz_clear (vector_size
);
4234 if (mask
->rank
!= field
->rank
&& field
->rank
!= 0)
4236 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4237 "the same rank as '%s' or be a scalar",
4238 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
4239 &field
->where
, gfc_current_intrinsic_arg
[1]->name
);
4243 if (mask
->rank
== field
->rank
)
4246 for (i
= 0; i
< field
->rank
; i
++)
4247 if (! identical_dimen_shape (mask
, i
, field
, i
))
4249 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4250 "must have identical shape.",
4251 gfc_current_intrinsic_arg
[2]->name
,
4252 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4262 gfc_check_verify (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
, gfc_expr
*kind
)
4264 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
4267 if (same_type_check (x
, 0, y
, 1) == FAILURE
)
4270 if (z
!= NULL
&& type_check (z
, 2, BT_LOGICAL
) == FAILURE
)
4273 if (kind_check (kind
, 3, BT_INTEGER
) == FAILURE
)
4275 if (kind
&& gfc_notify_std (GFC_STD_F2003
, "'%s' intrinsic "
4276 "with KIND argument at %L",
4277 gfc_current_intrinsic
, &kind
->where
) == FAILURE
)
4285 gfc_check_trim (gfc_expr
*x
)
4287 if (type_check (x
, 0, BT_CHARACTER
) == FAILURE
)
4290 if (scalar_check (x
, 0) == FAILURE
)
4298 gfc_check_ttynam (gfc_expr
*unit
)
4300 if (scalar_check (unit
, 0) == FAILURE
)
4303 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4310 /* Common check function for the half a dozen intrinsics that have a
4311 single real argument. */
4314 gfc_check_x (gfc_expr
*x
)
4316 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
4323 /************* Check functions for intrinsic subroutines *************/
4326 gfc_check_cpu_time (gfc_expr
*time
)
4328 if (scalar_check (time
, 0) == FAILURE
)
4331 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
4334 if (variable_check (time
, 0, false) == FAILURE
)
4342 gfc_check_date_and_time (gfc_expr
*date
, gfc_expr
*time
,
4343 gfc_expr
*zone
, gfc_expr
*values
)
4347 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
4349 if (kind_value_check (date
, 0, gfc_default_character_kind
) == FAILURE
)
4351 if (scalar_check (date
, 0) == FAILURE
)
4353 if (variable_check (date
, 0, false) == FAILURE
)
4359 if (type_check (time
, 1, BT_CHARACTER
) == FAILURE
)
4361 if (kind_value_check (time
, 1, gfc_default_character_kind
) == FAILURE
)
4363 if (scalar_check (time
, 1) == FAILURE
)
4365 if (variable_check (time
, 1, false) == FAILURE
)
4371 if (type_check (zone
, 2, BT_CHARACTER
) == FAILURE
)
4373 if (kind_value_check (zone
, 2, gfc_default_character_kind
) == FAILURE
)
4375 if (scalar_check (zone
, 2) == FAILURE
)
4377 if (variable_check (zone
, 2, false) == FAILURE
)
4383 if (type_check (values
, 3, BT_INTEGER
) == FAILURE
)
4385 if (array_check (values
, 3) == FAILURE
)
4387 if (rank_check (values
, 3, 1) == FAILURE
)
4389 if (variable_check (values
, 3, false) == FAILURE
)
4398 gfc_check_mvbits (gfc_expr
*from
, gfc_expr
*frompos
, gfc_expr
*len
,
4399 gfc_expr
*to
, gfc_expr
*topos
)
4401 if (type_check (from
, 0, BT_INTEGER
) == FAILURE
)
4404 if (type_check (frompos
, 1, BT_INTEGER
) == FAILURE
)
4407 if (type_check (len
, 2, BT_INTEGER
) == FAILURE
)
4410 if (same_type_check (from
, 0, to
, 3) == FAILURE
)
4413 if (variable_check (to
, 3, false) == FAILURE
)
4416 if (type_check (topos
, 4, BT_INTEGER
) == FAILURE
)
4419 if (nonnegative_check ("frompos", frompos
) == FAILURE
)
4422 if (nonnegative_check ("topos", topos
) == FAILURE
)
4425 if (nonnegative_check ("len", len
) == FAILURE
)
4428 if (less_than_bitsize2 ("from", from
, "frompos", frompos
, "len", len
)
4432 if (less_than_bitsize2 ("to", to
, "topos", topos
, "len", len
) == FAILURE
)
4440 gfc_check_random_number (gfc_expr
*harvest
)
4442 if (type_check (harvest
, 0, BT_REAL
) == FAILURE
)
4445 if (variable_check (harvest
, 0, false) == FAILURE
)
4453 gfc_check_random_seed (gfc_expr
*size
, gfc_expr
*put
, gfc_expr
*get
)
4455 unsigned int nargs
= 0, kiss_size
;
4456 locus
*where
= NULL
;
4457 mpz_t put_size
, get_size
;
4458 bool have_gfc_real_16
; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4460 have_gfc_real_16
= gfc_validate_kind (BT_REAL
, 16, true) != -1;
4462 /* Keep the number of bytes in sync with kiss_size in
4463 libgfortran/intrinsics/random.c. */
4464 kiss_size
= (have_gfc_real_16
? 48 : 32) / gfc_default_integer_kind
;
4468 if (size
->expr_type
!= EXPR_VARIABLE
4469 || !size
->symtree
->n
.sym
->attr
.optional
)
4472 if (scalar_check (size
, 0) == FAILURE
)
4475 if (type_check (size
, 0, BT_INTEGER
) == FAILURE
)
4478 if (variable_check (size
, 0, false) == FAILURE
)
4481 if (kind_value_check (size
, 0, gfc_default_integer_kind
) == FAILURE
)
4487 if (put
->expr_type
!= EXPR_VARIABLE
4488 || !put
->symtree
->n
.sym
->attr
.optional
)
4491 where
= &put
->where
;
4494 if (array_check (put
, 1) == FAILURE
)
4497 if (rank_check (put
, 1, 1) == FAILURE
)
4500 if (type_check (put
, 1, BT_INTEGER
) == FAILURE
)
4503 if (kind_value_check (put
, 1, gfc_default_integer_kind
) == FAILURE
)
4506 if (gfc_array_size (put
, &put_size
) == SUCCESS
4507 && mpz_get_ui (put_size
) < kiss_size
)
4508 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4509 "too small (%i/%i)",
4510 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
4511 where
, (int) mpz_get_ui (put_size
), kiss_size
);
4516 if (get
->expr_type
!= EXPR_VARIABLE
4517 || !get
->symtree
->n
.sym
->attr
.optional
)
4520 where
= &get
->where
;
4523 if (array_check (get
, 2) == FAILURE
)
4526 if (rank_check (get
, 2, 1) == FAILURE
)
4529 if (type_check (get
, 2, BT_INTEGER
) == FAILURE
)
4532 if (variable_check (get
, 2, false) == FAILURE
)
4535 if (kind_value_check (get
, 2, gfc_default_integer_kind
) == FAILURE
)
4538 if (gfc_array_size (get
, &get_size
) == SUCCESS
4539 && mpz_get_ui (get_size
) < kiss_size
)
4540 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4541 "too small (%i/%i)",
4542 gfc_current_intrinsic_arg
[2]->name
, gfc_current_intrinsic
,
4543 where
, (int) mpz_get_ui (get_size
), kiss_size
);
4546 /* RANDOM_SEED may not have more than one non-optional argument. */
4548 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic
, where
);
4555 gfc_check_second_sub (gfc_expr
*time
)
4557 if (scalar_check (time
, 0) == FAILURE
)
4560 if (type_check (time
, 0, BT_REAL
) == FAILURE
)
4563 if (kind_value_check(time
, 0, 4) == FAILURE
)
4570 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
4571 count, count_rate, and count_max are all optional arguments */
4574 gfc_check_system_clock (gfc_expr
*count
, gfc_expr
*count_rate
,
4575 gfc_expr
*count_max
)
4579 if (scalar_check (count
, 0) == FAILURE
)
4582 if (type_check (count
, 0, BT_INTEGER
) == FAILURE
)
4585 if (variable_check (count
, 0, false) == FAILURE
)
4589 if (count_rate
!= NULL
)
4591 if (scalar_check (count_rate
, 1) == FAILURE
)
4594 if (type_check (count_rate
, 1, BT_INTEGER
) == FAILURE
)
4597 if (variable_check (count_rate
, 1, false) == FAILURE
)
4601 && same_type_check (count
, 0, count_rate
, 1) == FAILURE
)
4606 if (count_max
!= NULL
)
4608 if (scalar_check (count_max
, 2) == FAILURE
)
4611 if (type_check (count_max
, 2, BT_INTEGER
) == FAILURE
)
4614 if (variable_check (count_max
, 2, false) == FAILURE
)
4618 && same_type_check (count
, 0, count_max
, 2) == FAILURE
)
4621 if (count_rate
!= NULL
4622 && same_type_check (count_rate
, 1, count_max
, 2) == FAILURE
)
4631 gfc_check_irand (gfc_expr
*x
)
4636 if (scalar_check (x
, 0) == FAILURE
)
4639 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
4642 if (kind_value_check(x
, 0, 4) == FAILURE
)
4650 gfc_check_alarm_sub (gfc_expr
*seconds
, gfc_expr
*handler
, gfc_expr
*status
)
4652 if (scalar_check (seconds
, 0) == FAILURE
)
4654 if (type_check (seconds
, 0, BT_INTEGER
) == FAILURE
)
4657 if (int_or_proc_check (handler
, 1) == FAILURE
)
4659 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
4665 if (scalar_check (status
, 2) == FAILURE
)
4667 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
4669 if (kind_value_check (status
, 2, gfc_default_integer_kind
) == FAILURE
)
4677 gfc_check_rand (gfc_expr
*x
)
4682 if (scalar_check (x
, 0) == FAILURE
)
4685 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
4688 if (kind_value_check(x
, 0, 4) == FAILURE
)
4696 gfc_check_srand (gfc_expr
*x
)
4698 if (scalar_check (x
, 0) == FAILURE
)
4701 if (type_check (x
, 0, BT_INTEGER
) == FAILURE
)
4704 if (kind_value_check(x
, 0, 4) == FAILURE
)
4712 gfc_check_ctime_sub (gfc_expr
*time
, gfc_expr
*result
)
4714 if (scalar_check (time
, 0) == FAILURE
)
4716 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
4719 if (type_check (result
, 1, BT_CHARACTER
) == FAILURE
)
4721 if (kind_value_check (result
, 1, gfc_default_character_kind
) == FAILURE
)
4729 gfc_check_dtime_etime (gfc_expr
*x
)
4731 if (array_check (x
, 0) == FAILURE
)
4734 if (rank_check (x
, 0, 1) == FAILURE
)
4737 if (variable_check (x
, 0, false) == FAILURE
)
4740 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
4743 if (kind_value_check(x
, 0, 4) == FAILURE
)
4751 gfc_check_dtime_etime_sub (gfc_expr
*values
, gfc_expr
*time
)
4753 if (array_check (values
, 0) == FAILURE
)
4756 if (rank_check (values
, 0, 1) == FAILURE
)
4759 if (variable_check (values
, 0, false) == FAILURE
)
4762 if (type_check (values
, 0, BT_REAL
) == FAILURE
)
4765 if (kind_value_check(values
, 0, 4) == FAILURE
)
4768 if (scalar_check (time
, 1) == FAILURE
)
4771 if (type_check (time
, 1, BT_REAL
) == FAILURE
)
4774 if (kind_value_check(time
, 1, 4) == FAILURE
)
4782 gfc_check_fdate_sub (gfc_expr
*date
)
4784 if (type_check (date
, 0, BT_CHARACTER
) == FAILURE
)
4786 if (kind_value_check (date
, 0, gfc_default_character_kind
) == FAILURE
)
4794 gfc_check_gerror (gfc_expr
*msg
)
4796 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
4798 if (kind_value_check (msg
, 0, gfc_default_character_kind
) == FAILURE
)
4806 gfc_check_getcwd_sub (gfc_expr
*cwd
, gfc_expr
*status
)
4808 if (type_check (cwd
, 0, BT_CHARACTER
) == FAILURE
)
4810 if (kind_value_check (cwd
, 0, gfc_default_character_kind
) == FAILURE
)
4816 if (scalar_check (status
, 1) == FAILURE
)
4819 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
4827 gfc_check_getarg (gfc_expr
*pos
, gfc_expr
*value
)
4829 if (type_check (pos
, 0, BT_INTEGER
) == FAILURE
)
4832 if (pos
->ts
.kind
> gfc_default_integer_kind
)
4834 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4835 "not wider than the default kind (%d)",
4836 gfc_current_intrinsic_arg
[0]->name
, gfc_current_intrinsic
,
4837 &pos
->where
, gfc_default_integer_kind
);
4841 if (type_check (value
, 1, BT_CHARACTER
) == FAILURE
)
4843 if (kind_value_check (value
, 1, gfc_default_character_kind
) == FAILURE
)
4851 gfc_check_getlog (gfc_expr
*msg
)
4853 if (type_check (msg
, 0, BT_CHARACTER
) == FAILURE
)
4855 if (kind_value_check (msg
, 0, gfc_default_character_kind
) == FAILURE
)
4863 gfc_check_exit (gfc_expr
*status
)
4868 if (type_check (status
, 0, BT_INTEGER
) == FAILURE
)
4871 if (scalar_check (status
, 0) == FAILURE
)
4879 gfc_check_flush (gfc_expr
*unit
)
4884 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
4887 if (scalar_check (unit
, 0) == FAILURE
)
4895 gfc_check_free (gfc_expr
*i
)
4897 if (type_check (i
, 0, BT_INTEGER
) == FAILURE
)
4900 if (scalar_check (i
, 0) == FAILURE
)
4908 gfc_check_hostnm (gfc_expr
*name
)
4910 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4912 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4920 gfc_check_hostnm_sub (gfc_expr
*name
, gfc_expr
*status
)
4922 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
4924 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
4930 if (scalar_check (status
, 1) == FAILURE
)
4933 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
4941 gfc_check_itime_idate (gfc_expr
*values
)
4943 if (array_check (values
, 0) == FAILURE
)
4946 if (rank_check (values
, 0, 1) == FAILURE
)
4949 if (variable_check (values
, 0, false) == FAILURE
)
4952 if (type_check (values
, 0, BT_INTEGER
) == FAILURE
)
4955 if (kind_value_check(values
, 0, gfc_default_integer_kind
) == FAILURE
)
4963 gfc_check_ltime_gmtime (gfc_expr
*time
, gfc_expr
*values
)
4965 if (type_check (time
, 0, BT_INTEGER
) == FAILURE
)
4968 if (kind_value_check(time
, 0, gfc_default_integer_kind
) == FAILURE
)
4971 if (scalar_check (time
, 0) == FAILURE
)
4974 if (array_check (values
, 1) == FAILURE
)
4977 if (rank_check (values
, 1, 1) == FAILURE
)
4980 if (variable_check (values
, 1, false) == FAILURE
)
4983 if (type_check (values
, 1, BT_INTEGER
) == FAILURE
)
4986 if (kind_value_check(values
, 1, gfc_default_integer_kind
) == FAILURE
)
4994 gfc_check_ttynam_sub (gfc_expr
*unit
, gfc_expr
*name
)
4996 if (scalar_check (unit
, 0) == FAILURE
)
4999 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
5002 if (type_check (name
, 1, BT_CHARACTER
) == FAILURE
)
5004 if (kind_value_check (name
, 1, gfc_default_character_kind
) == FAILURE
)
5012 gfc_check_isatty (gfc_expr
*unit
)
5017 if (type_check (unit
, 0, BT_INTEGER
) == FAILURE
)
5020 if (scalar_check (unit
, 0) == FAILURE
)
5028 gfc_check_isnan (gfc_expr
*x
)
5030 if (type_check (x
, 0, BT_REAL
) == FAILURE
)
5038 gfc_check_perror (gfc_expr
*string
)
5040 if (type_check (string
, 0, BT_CHARACTER
) == FAILURE
)
5042 if (kind_value_check (string
, 0, gfc_default_character_kind
) == FAILURE
)
5050 gfc_check_umask (gfc_expr
*mask
)
5052 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
5055 if (scalar_check (mask
, 0) == FAILURE
)
5063 gfc_check_umask_sub (gfc_expr
*mask
, gfc_expr
*old
)
5065 if (type_check (mask
, 0, BT_INTEGER
) == FAILURE
)
5068 if (scalar_check (mask
, 0) == FAILURE
)
5074 if (scalar_check (old
, 1) == FAILURE
)
5077 if (type_check (old
, 1, BT_INTEGER
) == FAILURE
)
5085 gfc_check_unlink (gfc_expr
*name
)
5087 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
5089 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
5097 gfc_check_unlink_sub (gfc_expr
*name
, gfc_expr
*status
)
5099 if (type_check (name
, 0, BT_CHARACTER
) == FAILURE
)
5101 if (kind_value_check (name
, 0, gfc_default_character_kind
) == FAILURE
)
5107 if (scalar_check (status
, 1) == FAILURE
)
5110 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
5118 gfc_check_signal (gfc_expr
*number
, gfc_expr
*handler
)
5120 if (scalar_check (number
, 0) == FAILURE
)
5122 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
5125 if (int_or_proc_check (handler
, 1) == FAILURE
)
5127 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
5135 gfc_check_signal_sub (gfc_expr
*number
, gfc_expr
*handler
, gfc_expr
*status
)
5137 if (scalar_check (number
, 0) == FAILURE
)
5139 if (type_check (number
, 0, BT_INTEGER
) == FAILURE
)
5142 if (int_or_proc_check (handler
, 1) == FAILURE
)
5144 if (handler
->ts
.type
== BT_INTEGER
&& scalar_check (handler
, 1) == FAILURE
)
5150 if (type_check (status
, 2, BT_INTEGER
) == FAILURE
)
5152 if (scalar_check (status
, 2) == FAILURE
)
5160 gfc_check_system_sub (gfc_expr
*cmd
, gfc_expr
*status
)
5162 if (type_check (cmd
, 0, BT_CHARACTER
) == FAILURE
)
5164 if (kind_value_check (cmd
, 0, gfc_default_character_kind
) == FAILURE
)
5167 if (scalar_check (status
, 1) == FAILURE
)
5170 if (type_check (status
, 1, BT_INTEGER
) == FAILURE
)
5173 if (kind_value_check (status
, 1, gfc_default_integer_kind
) == FAILURE
)
5180 /* This is used for the GNU intrinsics AND, OR and XOR. */
5182 gfc_check_and (gfc_expr
*i
, gfc_expr
*j
)
5184 if (i
->ts
.type
!= BT_INTEGER
&& i
->ts
.type
!= BT_LOGICAL
)
5186 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5187 "or LOGICAL", gfc_current_intrinsic_arg
[0]->name
,
5188 gfc_current_intrinsic
, &i
->where
);
5192 if (j
->ts
.type
!= BT_INTEGER
&& j
->ts
.type
!= BT_LOGICAL
)
5194 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5195 "or LOGICAL", gfc_current_intrinsic_arg
[1]->name
,
5196 gfc_current_intrinsic
, &j
->where
);
5200 if (i
->ts
.type
!= j
->ts
.type
)
5202 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5203 "have the same type", gfc_current_intrinsic_arg
[0]->name
,
5204 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,
5209 if (scalar_check (i
, 0) == FAILURE
)
5212 if (scalar_check (j
, 1) == FAILURE
)
5220 gfc_check_storage_size (gfc_expr
*a ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
5225 if (type_check (kind
, 1, BT_INTEGER
) == FAILURE
)
5228 if (scalar_check (kind
, 1) == FAILURE
)
5231 if (kind
->expr_type
!= EXPR_CONSTANT
)
5233 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5234 gfc_current_intrinsic_arg
[1]->name
, gfc_current_intrinsic
,