2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* These functions check to see if an argument list is compatible with
24 a particular intrinsic function or subroutine. Presence of
25 required arguments has already been established, the argument list
26 has been sorted into the right order and has NULL arguments in the
27 correct places for missing optional arguments. */
33 #include "intrinsic.h"
34 #include "constructor.h"
37 /* Make sure an expression is a scalar. */
40 scalar_check (gfc_expr *e, int n)
45 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
46 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
52 /* Check the type of an expression. */
55 type_check (gfc_expr *e, int n, bt type)
57 if (e->ts.type == type)
60 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
61 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
62 gfc_basic_typename (type));
68 /* Check that the expression is a numeric type. */
71 numeric_check (gfc_expr *e, int n)
73 if (gfc_numeric_ts (&e->ts))
76 /* If the expression has not got a type, check if its namespace can
77 offer a default type. */
78 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
79 && e->symtree->n.sym->ts.type == BT_UNKNOWN
80 && gfc_set_default_type (e->symtree->n.sym, 0,
81 e->symtree->n.sym->ns) == SUCCESS
82 && gfc_numeric_ts (&e->symtree->n.sym->ts))
84 e->ts = e->symtree->n.sym->ts;
88 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
89 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
95 /* Check that an expression is integer or real. */
98 int_or_real_check (gfc_expr *e, int n)
100 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
102 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
103 "or REAL", gfc_current_intrinsic_arg[n],
104 gfc_current_intrinsic, &e->where);
112 /* Check that an expression is real or complex. */
115 real_or_complex_check (gfc_expr *e, int n)
117 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
119 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
120 "or COMPLEX", gfc_current_intrinsic_arg[n],
121 gfc_current_intrinsic, &e->where);
129 /* Check that the expression is an optional constant integer
130 and that it specifies a valid kind for that type. */
133 kind_check (gfc_expr *k, int n, bt type)
140 if (type_check (k, n, BT_INTEGER) == FAILURE)
143 if (scalar_check (k, n) == FAILURE)
146 if (k->expr_type != EXPR_CONSTANT)
148 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
149 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
154 if (gfc_extract_int (k, &kind) != NULL
155 || gfc_validate_kind (type, kind, true) < 0)
157 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
166 /* Make sure the expression is a double precision real. */
169 double_check (gfc_expr *d, int n)
171 if (type_check (d, n, BT_REAL) == FAILURE)
174 if (d->ts.kind != gfc_default_double_kind)
176 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
177 "precision", gfc_current_intrinsic_arg[n],
178 gfc_current_intrinsic, &d->where);
186 /* Check whether an expression is a coarray (without array designator). */
189 is_coarray (gfc_expr *e)
191 bool coarray = false;
194 if (e->expr_type != EXPR_VARIABLE)
197 coarray = e->symtree->n.sym->attr.codimension;
199 for (ref = e->ref; ref; ref = ref->next)
201 if (ref->type == REF_COMPONENT)
202 coarray = ref->u.c.component->attr.codimension;
203 else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
204 || ref->u.ar.codimen != 0)
212 /* Make sure the expression is a logical array. */
215 logical_array_check (gfc_expr *array, int n)
217 if (array->ts.type != BT_LOGICAL || array->rank == 0)
219 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
220 "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
229 /* Make sure an expression is an array. */
232 array_check (gfc_expr *e, int n)
237 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
238 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
244 /* Make sure two expressions have the same type. */
247 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
249 if (gfc_compare_types (&e->ts, &f->ts))
252 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
253 "and kind as '%s'", gfc_current_intrinsic_arg[m],
254 gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
260 /* Make sure that an expression has a certain (nonzero) rank. */
263 rank_check (gfc_expr *e, int n, int rank)
268 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
269 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
276 /* Make sure a variable expression is not an optional dummy argument. */
279 nonoptional_check (gfc_expr *e, int n)
281 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
283 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
284 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
288 /* TODO: Recursive check on nonoptional variables? */
294 /* Check that an expression has a particular kind. */
297 kind_value_check (gfc_expr *e, int n, int k)
302 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
303 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
310 /* Make sure an expression is a variable. */
313 variable_check (gfc_expr *e, int n)
315 if ((e->expr_type == EXPR_VARIABLE
316 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
317 || (e->expr_type == EXPR_FUNCTION
318 && e->symtree->n.sym->result == e->symtree->n.sym))
321 if (e->expr_type == EXPR_VARIABLE
322 && e->symtree->n.sym->attr.intent == INTENT_IN)
324 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
325 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
330 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
331 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
337 /* Check the common DIM parameter for correctness. */
340 dim_check (gfc_expr *dim, int n, bool optional)
345 if (type_check (dim, n, BT_INTEGER) == FAILURE)
348 if (scalar_check (dim, n) == FAILURE)
351 if (!optional && nonoptional_check (dim, n) == FAILURE)
358 /* If a coarray DIM parameter is a constant, make sure that it is greater than
359 zero and less than or equal to the corank of the given array. */
362 dim_corank_check (gfc_expr *dim, gfc_expr *array)
367 gcc_assert (array->expr_type == EXPR_VARIABLE);
369 if (dim->expr_type != EXPR_CONSTANT)
372 ar = gfc_find_array_ref (array);
373 corank = ar->as->corank;
375 if (mpz_cmp_ui (dim->value.integer, 1) < 0
376 || mpz_cmp_ui (dim->value.integer, corank) > 0)
378 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
379 "codimension index", gfc_current_intrinsic, &dim->where);
388 /* If a DIM parameter is a constant, make sure that it is greater than
389 zero and less than or equal to the rank of the given array. If
390 allow_assumed is zero then dim must be less than the rank of the array
391 for assumed size arrays. */
394 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
402 if (dim->expr_type != EXPR_CONSTANT
403 || (array->expr_type != EXPR_VARIABLE
404 && array->expr_type != EXPR_ARRAY))
408 if (array->expr_type == EXPR_VARIABLE)
410 ar = gfc_find_array_ref (array);
411 if (ar->as->type == AS_ASSUMED_SIZE
413 && ar->type != AR_ELEMENT
414 && ar->type != AR_SECTION)
418 if (mpz_cmp_ui (dim->value.integer, 1) < 0
419 || mpz_cmp_ui (dim->value.integer, rank) > 0)
421 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
422 "dimension index", gfc_current_intrinsic, &dim->where);
431 /* Compare the size of a along dimension ai with the size of b along
432 dimension bi, returning 0 if they are known not to be identical,
433 and 1 if they are identical, or if this cannot be determined. */
436 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
438 mpz_t a_size, b_size;
441 gcc_assert (a->rank > ai);
442 gcc_assert (b->rank > bi);
446 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
448 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
450 if (mpz_cmp (a_size, b_size) != 0)
461 /* Check whether two character expressions have the same length;
462 returns SUCCESS if they have or if the length cannot be determined. */
465 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
470 if (a->ts.u.cl && a->ts.u.cl->length
471 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
472 len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
473 else if (a->expr_type == EXPR_CONSTANT
474 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
475 len_a = a->value.character.length;
479 if (b->ts.u.cl && b->ts.u.cl->length
480 && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
481 len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
482 else if (b->expr_type == EXPR_CONSTANT
483 && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
484 len_b = b->value.character.length;
491 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
492 len_a, len_b, name, &a->where);
497 /***** Check functions *****/
499 /* Check subroutine suitable for intrinsics taking a real argument and
500 a kind argument for the result. */
503 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
505 if (type_check (a, 0, BT_REAL) == FAILURE)
507 if (kind_check (kind, 1, type) == FAILURE)
514 /* Check subroutine suitable for ceiling, floor and nint. */
517 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
519 return check_a_kind (a, kind, BT_INTEGER);
523 /* Check subroutine suitable for aint, anint. */
526 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
528 return check_a_kind (a, kind, BT_REAL);
533 gfc_check_abs (gfc_expr *a)
535 if (numeric_check (a, 0) == FAILURE)
543 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
545 if (type_check (a, 0, BT_INTEGER) == FAILURE)
547 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
555 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
557 if (type_check (name, 0, BT_CHARACTER) == FAILURE
558 || scalar_check (name, 0) == FAILURE)
560 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
563 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
564 || scalar_check (mode, 1) == FAILURE)
566 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
574 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
576 if (logical_array_check (mask, 0) == FAILURE)
579 if (dim_check (dim, 1, false) == FAILURE)
582 if (dim_rank_check (dim, mask, 0) == FAILURE)
590 gfc_check_allocated (gfc_expr *array)
592 symbol_attribute attr;
594 if (variable_check (array, 0) == FAILURE)
597 attr = gfc_variable_attr (array, NULL);
598 if (!attr.allocatable)
600 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
601 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
610 /* Common check function where the first argument must be real or
611 integer and the second argument must be the same as the first. */
614 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
616 if (int_or_real_check (a, 0) == FAILURE)
619 if (a->ts.type != p->ts.type)
621 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
622 "have the same type", gfc_current_intrinsic_arg[0],
623 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
628 if (a->ts.kind != p->ts.kind)
630 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
631 &p->where) == FAILURE)
640 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
642 if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
650 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
652 symbol_attribute attr1, attr2;
657 where = &pointer->where;
659 if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
660 attr1 = gfc_expr_attr (pointer);
661 else if (pointer->expr_type == EXPR_NULL)
664 gcc_assert (0); /* Pointer must be a variable or a function. */
666 if (!attr1.pointer && !attr1.proc_pointer)
668 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
669 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
674 /* Target argument is optional. */
678 where = &target->where;
679 if (target->expr_type == EXPR_NULL)
682 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
683 attr2 = gfc_expr_attr (target);
686 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
687 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
688 gfc_current_intrinsic, &target->where);
692 if (attr1.pointer && !attr2.pointer && !attr2.target)
694 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
695 "or a TARGET", gfc_current_intrinsic_arg[1],
696 gfc_current_intrinsic, &target->where);
701 if (same_type_check (pointer, 0, target, 1) == FAILURE)
703 if (rank_check (target, 0, pointer->rank) == FAILURE)
705 if (target->rank > 0)
707 for (i = 0; i < target->rank; i++)
708 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
710 gfc_error ("Array section with a vector subscript at %L shall not "
711 "be the target of a pointer",
721 gfc_error ("NULL pointer at %L is not permitted as actual argument "
722 "of '%s' intrinsic function", where, gfc_current_intrinsic);
729 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
731 /* gfc_notify_std would be a wast of time as the return value
732 is seemingly used only for the generic resolution. The error
733 will be: Too many arguments. */
734 if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
737 return gfc_check_atan2 (y, x);
742 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
744 if (type_check (y, 0, BT_REAL) == FAILURE)
746 if (same_type_check (y, 0, x, 1) == FAILURE)
753 /* BESJN and BESYN functions. */
756 gfc_check_besn (gfc_expr *n, gfc_expr *x)
758 if (type_check (n, 0, BT_INTEGER) == FAILURE)
761 if (type_check (x, 1, BT_REAL) == FAILURE)
769 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
771 if (type_check (i, 0, BT_INTEGER) == FAILURE)
773 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
781 gfc_check_char (gfc_expr *i, gfc_expr *kind)
783 if (type_check (i, 0, BT_INTEGER) == FAILURE)
785 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
793 gfc_check_chdir (gfc_expr *dir)
795 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
797 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
805 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
807 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
809 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
815 if (type_check (status, 1, BT_INTEGER) == FAILURE)
817 if (scalar_check (status, 1) == FAILURE)
825 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
827 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
829 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
832 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
834 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
842 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
844 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
846 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
849 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
851 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
857 if (type_check (status, 2, BT_INTEGER) == FAILURE)
860 if (scalar_check (status, 2) == FAILURE)
868 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
870 if (numeric_check (x, 0) == FAILURE)
875 if (numeric_check (y, 1) == FAILURE)
878 if (x->ts.type == BT_COMPLEX)
880 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
881 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
882 gfc_current_intrinsic, &y->where);
886 if (y->ts.type == BT_COMPLEX)
888 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
889 "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
890 gfc_current_intrinsic, &y->where);
896 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
904 gfc_check_complex (gfc_expr *x, gfc_expr *y)
906 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
908 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
909 "or REAL", gfc_current_intrinsic_arg[0],
910 gfc_current_intrinsic, &x->where);
913 if (scalar_check (x, 0) == FAILURE)
916 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
918 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
919 "or REAL", gfc_current_intrinsic_arg[1],
920 gfc_current_intrinsic, &y->where);
923 if (scalar_check (y, 1) == FAILURE)
931 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
933 if (logical_array_check (mask, 0) == FAILURE)
935 if (dim_check (dim, 1, false) == FAILURE)
937 if (dim_rank_check (dim, mask, 0) == FAILURE)
939 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
941 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
942 "with KIND argument at %L",
943 gfc_current_intrinsic, &kind->where) == FAILURE)
951 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
953 if (array_check (array, 0) == FAILURE)
956 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
959 if (dim_check (dim, 2, true) == FAILURE)
962 if (dim_rank_check (dim, array, false) == FAILURE)
965 if (array->rank == 1 || shift->rank == 0)
967 if (scalar_check (shift, 1) == FAILURE)
970 else if (shift->rank == array->rank - 1)
975 else if (dim->expr_type == EXPR_CONSTANT)
976 gfc_extract_int (dim, &d);
983 for (i = 0, j = 0; i < array->rank; i++)
986 if (!identical_dimen_shape (array, i, shift, j))
988 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
989 "invalid shape in dimension %d (%ld/%ld)",
990 gfc_current_intrinsic_arg[1],
991 gfc_current_intrinsic, &shift->where, i + 1,
992 mpz_get_si (array->shape[i]),
993 mpz_get_si (shift->shape[j]));
1003 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1004 "%d or be a scalar", gfc_current_intrinsic_arg[1],
1005 gfc_current_intrinsic, &shift->where, array->rank - 1);
1014 gfc_check_ctime (gfc_expr *time)
1016 if (scalar_check (time, 0) == FAILURE)
1019 if (type_check (time, 0, BT_INTEGER) == FAILURE)
1026 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
1028 if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
1035 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
1037 if (numeric_check (x, 0) == FAILURE)
1042 if (numeric_check (y, 1) == FAILURE)
1045 if (x->ts.type == BT_COMPLEX)
1047 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1048 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
1049 gfc_current_intrinsic, &y->where);
1053 if (y->ts.type == BT_COMPLEX)
1055 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1056 "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
1057 gfc_current_intrinsic, &y->where);
1067 gfc_check_dble (gfc_expr *x)
1069 if (numeric_check (x, 0) == FAILURE)
1077 gfc_check_digits (gfc_expr *x)
1079 if (int_or_real_check (x, 0) == FAILURE)
1087 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1089 switch (vector_a->ts.type)
1092 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1099 if (numeric_check (vector_b, 1) == FAILURE)
1104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1105 "or LOGICAL", gfc_current_intrinsic_arg[0],
1106 gfc_current_intrinsic, &vector_a->where);
1110 if (rank_check (vector_a, 0, 1) == FAILURE)
1113 if (rank_check (vector_b, 1, 1) == FAILURE)
1116 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1118 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1119 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
1120 gfc_current_intrinsic_arg[1], &vector_a->where);
1129 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1131 if (type_check (x, 0, BT_REAL) == FAILURE
1132 || type_check (y, 1, BT_REAL) == FAILURE)
1135 if (x->ts.kind != gfc_default_real_kind)
1137 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1138 "real", gfc_current_intrinsic_arg[0],
1139 gfc_current_intrinsic, &x->where);
1143 if (y->ts.kind != gfc_default_real_kind)
1145 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1146 "real", gfc_current_intrinsic_arg[1],
1147 gfc_current_intrinsic, &y->where);
1156 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1159 if (array_check (array, 0) == FAILURE)
1162 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1165 if (dim_check (dim, 3, true) == FAILURE)
1168 if (dim_rank_check (dim, array, false) == FAILURE)
1171 if (array->rank == 1 || shift->rank == 0)
1173 if (scalar_check (shift, 1) == FAILURE)
1176 else if (shift->rank == array->rank - 1)
1181 else if (dim->expr_type == EXPR_CONSTANT)
1182 gfc_extract_int (dim, &d);
1189 for (i = 0, j = 0; i < array->rank; i++)
1192 if (!identical_dimen_shape (array, i, shift, j))
1194 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1195 "invalid shape in dimension %d (%ld/%ld)",
1196 gfc_current_intrinsic_arg[1],
1197 gfc_current_intrinsic, &shift->where, i + 1,
1198 mpz_get_si (array->shape[i]),
1199 mpz_get_si (shift->shape[j]));
1209 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1210 "%d or be a scalar", gfc_current_intrinsic_arg[1],
1211 gfc_current_intrinsic, &shift->where, array->rank - 1);
1215 if (boundary != NULL)
1217 if (same_type_check (array, 0, boundary, 2) == FAILURE)
1220 if (array->rank == 1 || boundary->rank == 0)
1222 if (scalar_check (boundary, 2) == FAILURE)
1225 else if (boundary->rank == array->rank - 1)
1227 if (gfc_check_conformance (shift, boundary,
1228 "arguments '%s' and '%s' for "
1230 gfc_current_intrinsic_arg[1],
1231 gfc_current_intrinsic_arg[2],
1232 gfc_current_intrinsic ) == FAILURE)
1237 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1238 "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
1239 gfc_current_intrinsic, &shift->where, array->rank - 1);
1248 gfc_check_float (gfc_expr *a)
1250 if (type_check (a, 0, BT_INTEGER) == FAILURE)
1253 if ((a->ts.kind != gfc_default_integer_kind)
1254 && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER"
1255 "kind argument to %s intrinsic at %L",
1256 gfc_current_intrinsic, &a->where) == FAILURE )
1262 /* A single complex argument. */
1265 gfc_check_fn_c (gfc_expr *a)
1267 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1273 /* A single real argument. */
1276 gfc_check_fn_r (gfc_expr *a)
1278 if (type_check (a, 0, BT_REAL) == FAILURE)
1284 /* A single double argument. */
1287 gfc_check_fn_d (gfc_expr *a)
1289 if (double_check (a, 0) == FAILURE)
1295 /* A single real or complex argument. */
1298 gfc_check_fn_rc (gfc_expr *a)
1300 if (real_or_complex_check (a, 0) == FAILURE)
1308 gfc_check_fn_rc2008 (gfc_expr *a)
1310 if (real_or_complex_check (a, 0) == FAILURE)
1313 if (a->ts.type == BT_COMPLEX
1314 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
1315 "argument of '%s' intrinsic at %L",
1316 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1317 &a->where) == FAILURE)
1325 gfc_check_fnum (gfc_expr *unit)
1327 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1330 if (scalar_check (unit, 0) == FAILURE)
1338 gfc_check_huge (gfc_expr *x)
1340 if (int_or_real_check (x, 0) == FAILURE)
1348 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1350 if (type_check (x, 0, BT_REAL) == FAILURE)
1352 if (same_type_check (x, 0, y, 1) == FAILURE)
1359 /* Check that the single argument is an integer. */
1362 gfc_check_i (gfc_expr *i)
1364 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1372 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1374 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1377 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1380 if (i->ts.kind != j->ts.kind)
1382 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1383 &i->where) == FAILURE)
1392 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1394 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1397 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1405 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1407 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1410 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1413 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1421 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1423 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1426 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1434 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1438 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1441 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1444 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1445 "with KIND argument at %L",
1446 gfc_current_intrinsic, &kind->where) == FAILURE)
1449 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1455 /* Substring references don't have the charlength set. */
1457 while (ref && ref->type != REF_SUBSTRING)
1460 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1464 /* Check that the argument is length one. Non-constant lengths
1465 can't be checked here, so assume they are ok. */
1466 if (c->ts.u.cl && c->ts.u.cl->length)
1468 /* If we already have a length for this expression then use it. */
1469 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1471 i = mpz_get_si (c->ts.u.cl->length->value.integer);
1478 start = ref->u.ss.start;
1479 end = ref->u.ss.end;
1482 if (end == NULL || end->expr_type != EXPR_CONSTANT
1483 || start->expr_type != EXPR_CONSTANT)
1486 i = mpz_get_si (end->value.integer) + 1
1487 - mpz_get_si (start->value.integer);
1495 gfc_error ("Argument of %s at %L must be of length one",
1496 gfc_current_intrinsic, &c->where);
1505 gfc_check_idnint (gfc_expr *a)
1507 if (double_check (a, 0) == FAILURE)
1515 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1517 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1520 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1523 if (i->ts.kind != j->ts.kind)
1525 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1526 &i->where) == FAILURE)
1535 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1538 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1539 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1542 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1545 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1547 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1548 "with KIND argument at %L",
1549 gfc_current_intrinsic, &kind->where) == FAILURE)
1552 if (string->ts.kind != substring->ts.kind)
1554 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1555 "kind as '%s'", gfc_current_intrinsic_arg[1],
1556 gfc_current_intrinsic, &substring->where,
1557 gfc_current_intrinsic_arg[0]);
1566 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1568 if (numeric_check (x, 0) == FAILURE)
1571 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1579 gfc_check_intconv (gfc_expr *x)
1581 if (numeric_check (x, 0) == FAILURE)
1589 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1591 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1594 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1597 if (i->ts.kind != j->ts.kind)
1599 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1600 &i->where) == FAILURE)
1609 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1611 if (type_check (i, 0, BT_INTEGER) == FAILURE
1612 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1620 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1622 if (type_check (i, 0, BT_INTEGER) == FAILURE
1623 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1626 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1634 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1636 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1639 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1647 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1649 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1652 if (scalar_check (pid, 0) == FAILURE)
1655 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1658 if (scalar_check (sig, 1) == FAILURE)
1664 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1667 if (scalar_check (status, 2) == FAILURE)
1675 gfc_check_kind (gfc_expr *x)
1677 if (x->ts.type == BT_DERIVED)
1679 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1680 "non-derived type", gfc_current_intrinsic_arg[0],
1681 gfc_current_intrinsic, &x->where);
1690 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1692 if (array_check (array, 0) == FAILURE)
1695 if (dim_check (dim, 1, false) == FAILURE)
1698 if (dim_rank_check (dim, array, 1) == FAILURE)
1701 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1703 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1704 "with KIND argument at %L",
1705 gfc_current_intrinsic, &kind->where) == FAILURE)
1713 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
1715 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1717 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1721 if (!is_coarray (coarray))
1723 gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND "
1724 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
1730 if (dim_check (dim, 1, false) == FAILURE)
1733 if (dim_corank_check (dim, coarray) == FAILURE)
1737 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1745 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
1747 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
1750 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1752 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1753 "with KIND argument at %L",
1754 gfc_current_intrinsic, &kind->where) == FAILURE)
1762 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
1764 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1766 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
1769 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
1771 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
1779 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1781 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1783 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1786 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1788 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1796 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1798 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1800 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1803 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1805 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
1811 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1814 if (scalar_check (status, 2) == FAILURE)
1822 gfc_check_loc (gfc_expr *expr)
1824 return variable_check (expr, 0);
1829 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1831 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1833 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1836 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1838 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1846 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1848 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1850 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1853 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1855 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1861 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1864 if (scalar_check (status, 2) == FAILURE)
1872 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1874 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1876 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1883 /* Min/max family. */
1886 min_max_args (gfc_actual_arglist *arg)
1888 if (arg == NULL || arg->next == NULL)
1890 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1891 gfc_current_intrinsic, gfc_current_intrinsic_where);
1900 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
1902 gfc_actual_arglist *arg, *tmp;
1907 if (min_max_args (arglist) == FAILURE)
1910 for (arg = arglist, n=1; arg; arg = arg->next, n++)
1913 if (x->ts.type != type || x->ts.kind != kind)
1915 if (x->ts.type == type)
1917 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1918 "kinds at %L", &x->where) == FAILURE)
1923 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1924 "%s(%d)", n, gfc_current_intrinsic, &x->where,
1925 gfc_basic_typename (type), kind);
1930 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
1931 if (gfc_check_conformance (tmp->expr, x,
1932 "arguments 'a%d' and 'a%d' for "
1933 "intrinsic '%s'", m, n,
1934 gfc_current_intrinsic) == FAILURE)
1943 gfc_check_min_max (gfc_actual_arglist *arg)
1947 if (min_max_args (arg) == FAILURE)
1952 if (x->ts.type == BT_CHARACTER)
1954 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1955 "with CHARACTER argument at %L",
1956 gfc_current_intrinsic, &x->where) == FAILURE)
1959 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1961 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1962 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
1966 return check_rest (x->ts.type, x->ts.kind, arg);
1971 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1973 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1978 gfc_check_min_max_real (gfc_actual_arglist *arg)
1980 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1985 gfc_check_min_max_double (gfc_actual_arglist *arg)
1987 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1991 /* End of min/max family. */
1994 gfc_check_malloc (gfc_expr *size)
1996 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1999 if (scalar_check (size, 0) == FAILURE)
2007 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
2009 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
2011 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2012 "or LOGICAL", gfc_current_intrinsic_arg[0],
2013 gfc_current_intrinsic, &matrix_a->where);
2017 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2019 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2020 "or LOGICAL", gfc_current_intrinsic_arg[1],
2021 gfc_current_intrinsic, &matrix_b->where);
2025 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2026 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2028 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2029 gfc_current_intrinsic, &matrix_a->where,
2030 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2034 switch (matrix_a->rank)
2037 if (rank_check (matrix_b, 1, 2) == FAILURE)
2039 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2040 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2042 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2043 "and '%s' at %L for intrinsic matmul",
2044 gfc_current_intrinsic_arg[0],
2045 gfc_current_intrinsic_arg[1], &matrix_a->where);
2051 if (matrix_b->rank != 2)
2053 if (rank_check (matrix_b, 1, 1) == FAILURE)
2056 /* matrix_b has rank 1 or 2 here. Common check for the cases
2057 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2058 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2059 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2061 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2062 "dimension 1 for argument '%s' at %L for intrinsic "
2063 "matmul", gfc_current_intrinsic_arg[0],
2064 gfc_current_intrinsic_arg[1], &matrix_a->where);
2070 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2071 "1 or 2", gfc_current_intrinsic_arg[0],
2072 gfc_current_intrinsic, &matrix_a->where);
2080 /* Whoever came up with this interface was probably on something.
2081 The possibilities for the occupation of the second and third
2088 NULL MASK minloc(array, mask=m)
2091 I.e. in the case of minloc(array,mask), mask will be in the second
2092 position of the argument list and we'll have to fix that up. */
2095 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2097 gfc_expr *a, *m, *d;
2100 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
2104 m = ap->next->next->expr;
2106 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2107 && ap->next->name == NULL)
2111 ap->next->expr = NULL;
2112 ap->next->next->expr = m;
2115 if (dim_check (d, 1, false) == FAILURE)
2118 if (dim_rank_check (d, a, 0) == FAILURE)
2121 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2125 && gfc_check_conformance (a, m,
2126 "arguments '%s' and '%s' for intrinsic %s",
2127 gfc_current_intrinsic_arg[0],
2128 gfc_current_intrinsic_arg[2],
2129 gfc_current_intrinsic ) == FAILURE)
2136 /* Similar to minloc/maxloc, the argument list might need to be
2137 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2138 difference is that MINLOC/MAXLOC take an additional KIND argument.
2139 The possibilities are:
2145 NULL MASK minval(array, mask=m)
2148 I.e. in the case of minval(array,mask), mask will be in the second
2149 position of the argument list and we'll have to fix that up. */
2152 check_reduction (gfc_actual_arglist *ap)
2154 gfc_expr *a, *m, *d;
2158 m = ap->next->next->expr;
2160 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2161 && ap->next->name == NULL)
2165 ap->next->expr = NULL;
2166 ap->next->next->expr = m;
2169 if (dim_check (d, 1, false) == FAILURE)
2172 if (dim_rank_check (d, a, 0) == FAILURE)
2175 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2179 && gfc_check_conformance (a, m,
2180 "arguments '%s' and '%s' for intrinsic %s",
2181 gfc_current_intrinsic_arg[0],
2182 gfc_current_intrinsic_arg[2],
2183 gfc_current_intrinsic) == FAILURE)
2191 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2193 if (int_or_real_check (ap->expr, 0) == FAILURE
2194 || array_check (ap->expr, 0) == FAILURE)
2197 return check_reduction (ap);
2202 gfc_check_product_sum (gfc_actual_arglist *ap)
2204 if (numeric_check (ap->expr, 0) == FAILURE
2205 || array_check (ap->expr, 0) == FAILURE)
2208 return check_reduction (ap);
2213 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2215 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2218 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2221 if (tsource->ts.type == BT_CHARACTER)
2222 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2229 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2231 symbol_attribute attr;
2233 if (variable_check (from, 0) == FAILURE)
2236 attr = gfc_variable_attr (from, NULL);
2237 if (!attr.allocatable)
2239 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2240 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2245 if (variable_check (to, 0) == FAILURE)
2248 attr = gfc_variable_attr (to, NULL);
2249 if (!attr.allocatable)
2251 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2252 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2257 if (same_type_check (to, 1, from, 0) == FAILURE)
2260 if (to->rank != from->rank)
2262 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2263 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
2264 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2265 &to->where, from->rank, to->rank);
2269 if (to->ts.kind != from->ts.kind)
2271 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2272 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
2273 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2274 &to->where, from->ts.kind, to->ts.kind);
2283 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2285 if (type_check (x, 0, BT_REAL) == FAILURE)
2288 if (type_check (s, 1, BT_REAL) == FAILURE)
2296 gfc_check_new_line (gfc_expr *a)
2298 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2306 gfc_check_null (gfc_expr *mold)
2308 symbol_attribute attr;
2313 if (variable_check (mold, 0) == FAILURE)
2316 attr = gfc_variable_attr (mold, NULL);
2318 if (!attr.pointer && !attr.proc_pointer)
2320 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2321 gfc_current_intrinsic_arg[0],
2322 gfc_current_intrinsic, &mold->where);
2331 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2333 if (array_check (array, 0) == FAILURE)
2336 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2339 if (gfc_check_conformance (array, mask,
2340 "arguments '%s' and '%s' for intrinsic '%s'",
2341 gfc_current_intrinsic_arg[0],
2342 gfc_current_intrinsic_arg[1],
2343 gfc_current_intrinsic) == FAILURE)
2348 mpz_t array_size, vector_size;
2349 bool have_array_size, have_vector_size;
2351 if (same_type_check (array, 0, vector, 2) == FAILURE)
2354 if (rank_check (vector, 2, 1) == FAILURE)
2357 /* VECTOR requires at least as many elements as MASK
2358 has .TRUE. values. */
2359 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2360 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2362 if (have_vector_size
2363 && (mask->expr_type == EXPR_ARRAY
2364 || (mask->expr_type == EXPR_CONSTANT
2365 && have_array_size)))
2367 int mask_true_values = 0;
2369 if (mask->expr_type == EXPR_ARRAY)
2371 gfc_constructor *mask_ctor;
2372 mask_ctor = gfc_constructor_first (mask->value.constructor);
2375 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2377 mask_true_values = 0;
2381 if (mask_ctor->expr->value.logical)
2384 mask_ctor = gfc_constructor_next (mask_ctor);
2387 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2388 mask_true_values = mpz_get_si (array_size);
2390 if (mpz_get_si (vector_size) < mask_true_values)
2392 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2393 "provide at least as many elements as there "
2394 "are .TRUE. values in '%s' (%ld/%d)",
2395 gfc_current_intrinsic_arg[2],gfc_current_intrinsic,
2396 &vector->where, gfc_current_intrinsic_arg[1],
2397 mpz_get_si (vector_size), mask_true_values);
2402 if (have_array_size)
2403 mpz_clear (array_size);
2404 if (have_vector_size)
2405 mpz_clear (vector_size);
2413 gfc_check_precision (gfc_expr *x)
2415 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
2417 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2418 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
2419 gfc_current_intrinsic, &x->where);
2428 gfc_check_present (gfc_expr *a)
2432 if (variable_check (a, 0) == FAILURE)
2435 sym = a->symtree->n.sym;
2436 if (!sym->attr.dummy)
2438 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2439 "dummy variable", gfc_current_intrinsic_arg[0],
2440 gfc_current_intrinsic, &a->where);
2444 if (!sym->attr.optional)
2446 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2447 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2448 gfc_current_intrinsic, &a->where);
2452 /* 13.14.82 PRESENT(A)
2454 Argument. A shall be the name of an optional dummy argument that is
2455 accessible in the subprogram in which the PRESENT function reference
2459 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2460 && a->ref->u.ar.type == AR_FULL))
2462 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2463 "subobject of '%s'", gfc_current_intrinsic_arg[0],
2464 gfc_current_intrinsic, &a->where, sym->name);
2473 gfc_check_radix (gfc_expr *x)
2475 if (int_or_real_check (x, 0) == FAILURE)
2483 gfc_check_range (gfc_expr *x)
2485 if (numeric_check (x, 0) == FAILURE)
2492 /* real, float, sngl. */
2494 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2496 if (numeric_check (a, 0) == FAILURE)
2499 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2507 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2509 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2511 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2514 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2516 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2524 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2526 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2528 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2531 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2533 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2539 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2542 if (scalar_check (status, 2) == FAILURE)
2550 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2552 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2555 if (scalar_check (x, 0) == FAILURE)
2558 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2561 if (scalar_check (y, 1) == FAILURE)
2569 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2570 gfc_expr *pad, gfc_expr *order)
2576 if (array_check (source, 0) == FAILURE)
2579 if (rank_check (shape, 1, 1) == FAILURE)
2582 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2585 if (gfc_array_size (shape, &size) != SUCCESS)
2587 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2588 "array of constant size", &shape->where);
2592 shape_size = mpz_get_ui (size);
2595 if (shape_size <= 0)
2597 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
2598 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2602 else if (shape_size > GFC_MAX_DIMENSIONS)
2604 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2605 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2608 else if (shape->expr_type == EXPR_ARRAY)
2612 for (i = 0; i < shape_size; ++i)
2614 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
2615 if (e->expr_type != EXPR_CONSTANT)
2618 gfc_extract_int (e, &extent);
2621 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2622 "negative element (%d)", gfc_current_intrinsic_arg[1],
2623 gfc_current_intrinsic, &e->where, extent);
2631 if (same_type_check (source, 0, pad, 2) == FAILURE)
2634 if (array_check (pad, 2) == FAILURE)
2640 if (array_check (order, 3) == FAILURE)
2643 if (type_check (order, 3, BT_INTEGER) == FAILURE)
2646 if (order->expr_type == EXPR_ARRAY)
2648 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
2651 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
2654 gfc_array_size (order, &size);
2655 order_size = mpz_get_ui (size);
2658 if (order_size != shape_size)
2660 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2661 "has wrong number of elements (%d/%d)",
2662 gfc_current_intrinsic_arg[3],
2663 gfc_current_intrinsic, &order->where,
2664 order_size, shape_size);
2668 for (i = 1; i <= order_size; ++i)
2670 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
2671 if (e->expr_type != EXPR_CONSTANT)
2674 gfc_extract_int (e, &dim);
2676 if (dim < 1 || dim > order_size)
2678 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2679 "has out-of-range dimension (%d)",
2680 gfc_current_intrinsic_arg[3],
2681 gfc_current_intrinsic, &e->where, dim);
2685 if (perm[dim-1] != 0)
2687 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2688 "invalid permutation of dimensions (dimension "
2689 "'%d' duplicated)", gfc_current_intrinsic_arg[3],
2690 gfc_current_intrinsic, &e->where, dim);
2699 if (pad == NULL && shape->expr_type == EXPR_ARRAY
2700 && gfc_is_constant_expr (shape)
2701 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2702 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2704 /* Check the match in size between source and destination. */
2705 if (gfc_array_size (source, &nelems) == SUCCESS)
2711 mpz_init_set_ui (size, 1);
2712 for (c = gfc_constructor_first (shape->value.constructor);
2713 c; c = gfc_constructor_next (c))
2714 mpz_mul (size, size, c->expr->value.integer);
2716 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2722 gfc_error ("Without padding, there are not enough elements "
2723 "in the intrinsic RESHAPE source at %L to match "
2724 "the shape", &source->where);
2735 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
2738 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
2740 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2741 "must be of a derived type", gfc_current_intrinsic_arg[0],
2742 gfc_current_intrinsic, &a->where);
2746 if (!gfc_type_is_extensible (a->ts.u.derived))
2748 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2749 "must be of an extensible type", gfc_current_intrinsic_arg[0],
2750 gfc_current_intrinsic, &a->where);
2754 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
2756 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2757 "must be of a derived type", gfc_current_intrinsic_arg[1],
2758 gfc_current_intrinsic, &b->where);
2762 if (!gfc_type_is_extensible (b->ts.u.derived))
2764 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2765 "must be of an extensible type", gfc_current_intrinsic_arg[1],
2766 gfc_current_intrinsic, &b->where);
2775 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2777 if (type_check (x, 0, BT_REAL) == FAILURE)
2780 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2788 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2790 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2793 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2796 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2799 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2801 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2802 "with KIND argument at %L",
2803 gfc_current_intrinsic, &kind->where) == FAILURE)
2806 if (same_type_check (x, 0, y, 1) == FAILURE)
2814 gfc_check_secnds (gfc_expr *r)
2816 if (type_check (r, 0, BT_REAL) == FAILURE)
2819 if (kind_value_check (r, 0, 4) == FAILURE)
2822 if (scalar_check (r, 0) == FAILURE)
2830 gfc_check_selected_char_kind (gfc_expr *name)
2832 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2835 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
2838 if (scalar_check (name, 0) == FAILURE)
2846 gfc_check_selected_int_kind (gfc_expr *r)
2848 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2851 if (scalar_check (r, 0) == FAILURE)
2859 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2861 if (p == NULL && r == NULL)
2863 gfc_error ("Missing arguments to %s intrinsic at %L",
2864 gfc_current_intrinsic, gfc_current_intrinsic_where);
2869 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2872 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2880 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2882 if (type_check (x, 0, BT_REAL) == FAILURE)
2885 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2893 gfc_check_shape (gfc_expr *source)
2897 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2900 ar = gfc_find_array_ref (source);
2902 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
2904 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2905 "an assumed size array", &source->where);
2914 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2916 if (int_or_real_check (a, 0) == FAILURE)
2919 if (same_type_check (a, 0, b, 1) == FAILURE)
2927 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2929 if (array_check (array, 0) == FAILURE)
2932 if (dim_check (dim, 1, true) == FAILURE)
2935 if (dim_rank_check (dim, array, 0) == FAILURE)
2938 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2940 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2941 "with KIND argument at %L",
2942 gfc_current_intrinsic, &kind->where) == FAILURE)
2951 gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
2958 gfc_check_sleep_sub (gfc_expr *seconds)
2960 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2963 if (scalar_check (seconds, 0) == FAILURE)
2970 gfc_check_sngl (gfc_expr *a)
2972 if (type_check (a, 0, BT_REAL) == FAILURE)
2975 if ((a->ts.kind != gfc_default_double_kind)
2976 && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision"
2977 "REAL argument to %s intrinsic at %L",
2978 gfc_current_intrinsic, &a->where) == FAILURE)
2985 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2987 if (source->rank >= GFC_MAX_DIMENSIONS)
2989 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2990 "than rank %d", gfc_current_intrinsic_arg[0],
2991 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2999 if (dim_check (dim, 1, false) == FAILURE)
3002 /* dim_rank_check() does not apply here. */
3004 && dim->expr_type == EXPR_CONSTANT
3005 && (mpz_cmp_ui (dim->value.integer, 1) < 0
3006 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
3008 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3009 "dimension index", gfc_current_intrinsic_arg[1],
3010 gfc_current_intrinsic, &dim->where);
3014 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
3017 if (scalar_check (ncopies, 2) == FAILURE)
3024 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3028 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3030 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3033 if (scalar_check (unit, 0) == FAILURE)
3036 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3038 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3044 if (type_check (status, 2, BT_INTEGER) == FAILURE
3045 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3046 || scalar_check (status, 2) == FAILURE)
3054 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3056 return gfc_check_fgetputc_sub (unit, c, NULL);
3061 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3063 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3065 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3071 if (type_check (status, 1, BT_INTEGER) == FAILURE
3072 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3073 || scalar_check (status, 1) == FAILURE)
3081 gfc_check_fgetput (gfc_expr *c)
3083 return gfc_check_fgetput_sub (c, NULL);
3088 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3090 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3093 if (scalar_check (unit, 0) == FAILURE)
3096 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3099 if (scalar_check (offset, 1) == FAILURE)
3102 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3105 if (scalar_check (whence, 2) == FAILURE)
3111 if (type_check (status, 3, BT_INTEGER) == FAILURE)
3114 if (kind_value_check (status, 3, 4) == FAILURE)
3117 if (scalar_check (status, 3) == FAILURE)
3126 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
3128 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3131 if (scalar_check (unit, 0) == FAILURE)
3134 if (type_check (array, 1, BT_INTEGER) == FAILURE
3135 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
3138 if (array_check (array, 1) == FAILURE)
3146 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3148 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3151 if (scalar_check (unit, 0) == FAILURE)
3154 if (type_check (array, 1, BT_INTEGER) == FAILURE
3155 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3158 if (array_check (array, 1) == FAILURE)
3164 if (type_check (status, 2, BT_INTEGER) == FAILURE
3165 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3168 if (scalar_check (status, 2) == FAILURE)
3176 gfc_check_ftell (gfc_expr *unit)
3178 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3181 if (scalar_check (unit, 0) == FAILURE)
3189 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3191 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3194 if (scalar_check (unit, 0) == FAILURE)
3197 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3200 if (scalar_check (offset, 1) == FAILURE)
3208 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3210 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3212 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3215 if (type_check (array, 1, BT_INTEGER) == FAILURE
3216 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3219 if (array_check (array, 1) == FAILURE)
3227 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3229 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3231 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3234 if (type_check (array, 1, BT_INTEGER) == FAILURE
3235 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3238 if (array_check (array, 1) == FAILURE)
3244 if (type_check (status, 2, BT_INTEGER) == FAILURE
3245 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3248 if (scalar_check (status, 2) == FAILURE)
3256 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3258 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3260 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3264 if (!is_coarray (coarray))
3266 gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX "
3267 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
3273 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3274 gfc_current_intrinsic_arg[1], &sub->where);
3283 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3285 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3287 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3291 if (dim != NULL && coarray == NULL)
3293 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3294 "intrinsic at %L", &dim->where);
3298 if (coarray == NULL)
3301 if (!is_coarray (coarray))
3303 gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE "
3304 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
3310 if (dim_check (dim, 1, false) == FAILURE)
3313 if (dim_corank_check (dim, coarray) == FAILURE)
3322 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
3323 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
3325 if (mold->ts.type == BT_HOLLERITH)
3327 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3328 &mold->where, gfc_basic_typename (BT_HOLLERITH));
3334 if (type_check (size, 2, BT_INTEGER) == FAILURE)
3337 if (scalar_check (size, 2) == FAILURE)
3340 if (nonoptional_check (size, 2) == FAILURE)
3349 gfc_check_transpose (gfc_expr *matrix)
3351 if (rank_check (matrix, 0, 2) == FAILURE)
3359 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3361 if (array_check (array, 0) == FAILURE)
3364 if (dim_check (dim, 1, false) == FAILURE)
3367 if (dim_rank_check (dim, array, 0) == FAILURE)
3370 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3372 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3373 "with KIND argument at %L",
3374 gfc_current_intrinsic, &kind->where) == FAILURE)
3382 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
3384 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3386 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3390 if (!is_coarray (coarray))
3392 gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND "
3393 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
3399 if (dim_check (dim, 1, false) == FAILURE)
3402 if (dim_corank_check (dim, coarray) == FAILURE)
3406 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3414 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
3418 if (rank_check (vector, 0, 1) == FAILURE)
3421 if (array_check (mask, 1) == FAILURE)
3424 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
3427 if (same_type_check (vector, 0, field, 2) == FAILURE)
3430 if (mask->expr_type == EXPR_ARRAY
3431 && gfc_array_size (vector, &vector_size) == SUCCESS)
3433 int mask_true_count = 0;
3434 gfc_constructor *mask_ctor;
3435 mask_ctor = gfc_constructor_first (mask->value.constructor);
3438 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
3440 mask_true_count = 0;
3444 if (mask_ctor->expr->value.logical)
3447 mask_ctor = gfc_constructor_next (mask_ctor);
3450 if (mpz_get_si (vector_size) < mask_true_count)
3452 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3453 "provide at least as many elements as there "
3454 "are .TRUE. values in '%s' (%ld/%d)",
3455 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3456 &vector->where, gfc_current_intrinsic_arg[1],
3457 mpz_get_si (vector_size), mask_true_count);
3461 mpz_clear (vector_size);
3464 if (mask->rank != field->rank && field->rank != 0)
3466 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
3467 "the same rank as '%s' or be a scalar",
3468 gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
3469 &field->where, gfc_current_intrinsic_arg[1]);
3473 if (mask->rank == field->rank)
3476 for (i = 0; i < field->rank; i++)
3477 if (! identical_dimen_shape (mask, i, field, i))
3479 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
3480 "must have identical shape.",
3481 gfc_current_intrinsic_arg[2],
3482 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3492 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3494 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3497 if (same_type_check (x, 0, y, 1) == FAILURE)
3500 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3503 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3505 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3506 "with KIND argument at %L",
3507 gfc_current_intrinsic, &kind->where) == FAILURE)
3515 gfc_check_trim (gfc_expr *x)
3517 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3520 if (scalar_check (x, 0) == FAILURE)
3528 gfc_check_ttynam (gfc_expr *unit)
3530 if (scalar_check (unit, 0) == FAILURE)
3533 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3540 /* Common check function for the half a dozen intrinsics that have a
3541 single real argument. */
3544 gfc_check_x (gfc_expr *x)
3546 if (type_check (x, 0, BT_REAL) == FAILURE)
3553 /************* Check functions for intrinsic subroutines *************/
3556 gfc_check_cpu_time (gfc_expr *time)
3558 if (scalar_check (time, 0) == FAILURE)
3561 if (type_check (time, 0, BT_REAL) == FAILURE)
3564 if (variable_check (time, 0) == FAILURE)
3572 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
3573 gfc_expr *zone, gfc_expr *values)
3577 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3579 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3581 if (scalar_check (date, 0) == FAILURE)
3583 if (variable_check (date, 0) == FAILURE)
3589 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
3591 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
3593 if (scalar_check (time, 1) == FAILURE)
3595 if (variable_check (time, 1) == FAILURE)
3601 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
3603 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
3605 if (scalar_check (zone, 2) == FAILURE)
3607 if (variable_check (zone, 2) == FAILURE)
3613 if (type_check (values, 3, BT_INTEGER) == FAILURE)
3615 if (array_check (values, 3) == FAILURE)
3617 if (rank_check (values, 3, 1) == FAILURE)
3619 if (variable_check (values, 3) == FAILURE)
3628 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
3629 gfc_expr *to, gfc_expr *topos)
3631 if (type_check (from, 0, BT_INTEGER) == FAILURE)
3634 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
3637 if (type_check (len, 2, BT_INTEGER) == FAILURE)
3640 if (same_type_check (from, 0, to, 3) == FAILURE)
3643 if (variable_check (to, 3) == FAILURE)
3646 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
3654 gfc_check_random_number (gfc_expr *harvest)
3656 if (type_check (harvest, 0, BT_REAL) == FAILURE)
3659 if (variable_check (harvest, 0) == FAILURE)
3667 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
3669 unsigned int nargs = 0, kiss_size;
3670 locus *where = NULL;
3671 mpz_t put_size, get_size;
3672 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
3674 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
3676 /* Keep the number of bytes in sync with kiss_size in
3677 libgfortran/intrinsics/random.c. */
3678 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
3682 if (size->expr_type != EXPR_VARIABLE
3683 || !size->symtree->n.sym->attr.optional)
3686 if (scalar_check (size, 0) == FAILURE)
3689 if (type_check (size, 0, BT_INTEGER) == FAILURE)
3692 if (variable_check (size, 0) == FAILURE)
3695 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3701 if (put->expr_type != EXPR_VARIABLE
3702 || !put->symtree->n.sym->attr.optional)
3705 where = &put->where;
3708 if (array_check (put, 1) == FAILURE)
3711 if (rank_check (put, 1, 1) == FAILURE)
3714 if (type_check (put, 1, BT_INTEGER) == FAILURE)
3717 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3720 if (gfc_array_size (put, &put_size) == SUCCESS
3721 && mpz_get_ui (put_size) < kiss_size)
3722 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3723 "too small (%i/%i)",
3724 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
3725 (int) mpz_get_ui (put_size), kiss_size);
3730 if (get->expr_type != EXPR_VARIABLE
3731 || !get->symtree->n.sym->attr.optional)
3734 where = &get->where;
3737 if (array_check (get, 2) == FAILURE)
3740 if (rank_check (get, 2, 1) == FAILURE)
3743 if (type_check (get, 2, BT_INTEGER) == FAILURE)
3746 if (variable_check (get, 2) == FAILURE)
3749 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3752 if (gfc_array_size (get, &get_size) == SUCCESS
3753 && mpz_get_ui (get_size) < kiss_size)
3754 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3755 "too small (%i/%i)",
3756 gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
3757 (int) mpz_get_ui (get_size), kiss_size);
3760 /* RANDOM_SEED may not have more than one non-optional argument. */
3762 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3769 gfc_check_second_sub (gfc_expr *time)
3771 if (scalar_check (time, 0) == FAILURE)
3774 if (type_check (time, 0, BT_REAL) == FAILURE)
3777 if (kind_value_check(time, 0, 4) == FAILURE)
3784 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3785 count, count_rate, and count_max are all optional arguments */
3788 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3789 gfc_expr *count_max)
3793 if (scalar_check (count, 0) == FAILURE)
3796 if (type_check (count, 0, BT_INTEGER) == FAILURE)
3799 if (variable_check (count, 0) == FAILURE)
3803 if (count_rate != NULL)
3805 if (scalar_check (count_rate, 1) == FAILURE)
3808 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3811 if (variable_check (count_rate, 1) == FAILURE)
3815 && same_type_check (count, 0, count_rate, 1) == FAILURE)
3820 if (count_max != NULL)
3822 if (scalar_check (count_max, 2) == FAILURE)
3825 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3828 if (variable_check (count_max, 2) == FAILURE)
3832 && same_type_check (count, 0, count_max, 2) == FAILURE)
3835 if (count_rate != NULL
3836 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3845 gfc_check_irand (gfc_expr *x)
3850 if (scalar_check (x, 0) == FAILURE)
3853 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3856 if (kind_value_check(x, 0, 4) == FAILURE)
3864 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3866 if (scalar_check (seconds, 0) == FAILURE)
3869 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3872 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3874 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3875 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3876 gfc_current_intrinsic, &handler->where);
3880 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3886 if (scalar_check (status, 2) == FAILURE)
3889 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3892 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3900 gfc_check_rand (gfc_expr *x)
3905 if (scalar_check (x, 0) == FAILURE)
3908 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3911 if (kind_value_check(x, 0, 4) == FAILURE)
3919 gfc_check_srand (gfc_expr *x)
3921 if (scalar_check (x, 0) == FAILURE)
3924 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3927 if (kind_value_check(x, 0, 4) == FAILURE)
3935 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3937 if (scalar_check (time, 0) == FAILURE)
3939 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3942 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3944 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
3952 gfc_check_dtime_etime (gfc_expr *x)
3954 if (array_check (x, 0) == FAILURE)
3957 if (rank_check (x, 0, 1) == FAILURE)
3960 if (variable_check (x, 0) == FAILURE)
3963 if (type_check (x, 0, BT_REAL) == FAILURE)
3966 if (kind_value_check(x, 0, 4) == FAILURE)
3974 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3976 if (array_check (values, 0) == FAILURE)
3979 if (rank_check (values, 0, 1) == FAILURE)
3982 if (variable_check (values, 0) == FAILURE)
3985 if (type_check (values, 0, BT_REAL) == FAILURE)
3988 if (kind_value_check(values, 0, 4) == FAILURE)
3991 if (scalar_check (time, 1) == FAILURE)
3994 if (type_check (time, 1, BT_REAL) == FAILURE)
3997 if (kind_value_check(time, 1, 4) == FAILURE)
4005 gfc_check_fdate_sub (gfc_expr *date)
4007 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4009 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4017 gfc_check_gerror (gfc_expr *msg)
4019 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4021 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4029 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4031 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4033 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4039 if (scalar_check (status, 1) == FAILURE)
4042 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4050 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4052 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4055 if (pos->ts.kind > gfc_default_integer_kind)
4057 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4058 "not wider than the default kind (%d)",
4059 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
4060 &pos->where, gfc_default_integer_kind);
4064 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4066 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4074 gfc_check_getlog (gfc_expr *msg)
4076 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4078 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4086 gfc_check_exit (gfc_expr *status)
4091 if (type_check (status, 0, BT_INTEGER) == FAILURE)
4094 if (scalar_check (status, 0) == FAILURE)
4102 gfc_check_flush (gfc_expr *unit)
4107 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4110 if (scalar_check (unit, 0) == FAILURE)
4118 gfc_check_free (gfc_expr *i)
4120 if (type_check (i, 0, BT_INTEGER) == FAILURE)
4123 if (scalar_check (i, 0) == FAILURE)
4131 gfc_check_hostnm (gfc_expr *name)
4133 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4135 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4143 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4145 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4147 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4153 if (scalar_check (status, 1) == FAILURE)
4156 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4164 gfc_check_itime_idate (gfc_expr *values)
4166 if (array_check (values, 0) == FAILURE)
4169 if (rank_check (values, 0, 1) == FAILURE)
4172 if (variable_check (values, 0) == FAILURE)
4175 if (type_check (values, 0, BT_INTEGER) == FAILURE)
4178 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4186 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4188 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4191 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4194 if (scalar_check (time, 0) == FAILURE)
4197 if (array_check (values, 1) == FAILURE)
4200 if (rank_check (values, 1, 1) == FAILURE)
4203 if (variable_check (values, 1) == FAILURE)
4206 if (type_check (values, 1, BT_INTEGER) == FAILURE)
4209 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4217 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4219 if (scalar_check (unit, 0) == FAILURE)
4222 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4225 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4227 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4235 gfc_check_isatty (gfc_expr *unit)
4240 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4243 if (scalar_check (unit, 0) == FAILURE)
4251 gfc_check_isnan (gfc_expr *x)
4253 if (type_check (x, 0, BT_REAL) == FAILURE)
4261 gfc_check_perror (gfc_expr *string)
4263 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
4265 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
4273 gfc_check_umask (gfc_expr *mask)
4275 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4278 if (scalar_check (mask, 0) == FAILURE)
4286 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
4288 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4291 if (scalar_check (mask, 0) == FAILURE)
4297 if (scalar_check (old, 1) == FAILURE)
4300 if (type_check (old, 1, BT_INTEGER) == FAILURE)
4308 gfc_check_unlink (gfc_expr *name)
4310 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4312 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4320 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
4322 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4324 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4330 if (scalar_check (status, 1) == FAILURE)
4333 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4341 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
4343 if (scalar_check (number, 0) == FAILURE)
4346 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4349 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4351 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4352 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4353 gfc_current_intrinsic, &handler->where);
4357 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4365 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
4367 if (scalar_check (number, 0) == FAILURE)
4370 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4373 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4375 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4376 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4377 gfc_current_intrinsic, &handler->where);
4381 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4387 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4390 if (scalar_check (status, 2) == FAILURE)
4398 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
4400 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
4402 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
4405 if (scalar_check (status, 1) == FAILURE)
4408 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4411 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
4418 /* This is used for the GNU intrinsics AND, OR and XOR. */
4420 gfc_check_and (gfc_expr *i, gfc_expr *j)
4422 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
4424 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4425 "or LOGICAL", gfc_current_intrinsic_arg[0],
4426 gfc_current_intrinsic, &i->where);
4430 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
4432 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4433 "or LOGICAL", gfc_current_intrinsic_arg[1],
4434 gfc_current_intrinsic, &j->where);
4438 if (i->ts.type != j->ts.type)
4440 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
4441 "have the same type", gfc_current_intrinsic_arg[0],
4442 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
4447 if (scalar_check (i, 0) == FAILURE)
4450 if (scalar_check (j, 1) == FAILURE)