2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
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"
36 /* Check the type of an expression. */
39 type_check (gfc_expr *e, int n, bt type)
41 if (e->ts.type == type)
44 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
45 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
46 gfc_basic_typename (type));
52 /* Check that the expression is a numeric type. */
55 numeric_check (gfc_expr *e, int n)
57 if (gfc_numeric_ts (&e->ts))
60 /* If the expression has not got a type, check if its namespace can
61 offer a default type. */
62 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
63 && e->symtree->n.sym->ts.type == BT_UNKNOWN
64 && gfc_set_default_type (e->symtree->n.sym, 0,
65 e->symtree->n.sym->ns) == SUCCESS
66 && gfc_numeric_ts (&e->symtree->n.sym->ts))
68 e->ts = e->symtree->n.sym->ts;
72 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
73 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
79 /* Check that an expression is integer or real. */
82 int_or_real_check (gfc_expr *e, int n)
84 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
86 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
87 "or REAL", gfc_current_intrinsic_arg[n],
88 gfc_current_intrinsic, &e->where);
96 /* Check that an expression is real or complex. */
99 real_or_complex_check (gfc_expr *e, int n)
101 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
103 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
104 "or COMPLEX", gfc_current_intrinsic_arg[n],
105 gfc_current_intrinsic, &e->where);
113 /* Check that the expression is an optional constant integer
114 and that it specifies a valid kind for that type. */
117 kind_check (gfc_expr *k, int n, bt type)
124 if (type_check (k, n, BT_INTEGER) == FAILURE)
127 if (k->expr_type != EXPR_CONSTANT)
129 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
130 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
135 if (gfc_extract_int (k, &kind) != NULL
136 || gfc_validate_kind (type, kind, true) < 0)
138 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
147 /* Make sure the expression is a double precision real. */
150 double_check (gfc_expr *d, int n)
152 if (type_check (d, n, BT_REAL) == FAILURE)
155 if (d->ts.kind != gfc_default_double_kind)
157 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
158 "precision", gfc_current_intrinsic_arg[n],
159 gfc_current_intrinsic, &d->where);
167 /* Make sure the expression is a logical array. */
170 logical_array_check (gfc_expr *array, int n)
172 if (array->ts.type != BT_LOGICAL || array->rank == 0)
174 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
175 "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
184 /* Make sure an expression is an array. */
187 array_check (gfc_expr *e, int n)
192 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
193 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
199 /* Make sure an expression is a scalar. */
202 scalar_check (gfc_expr *e, int n)
207 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
208 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
214 /* Make sure two expressions have the same type. */
217 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
219 if (gfc_compare_types (&e->ts, &f->ts))
222 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
223 "and kind as '%s'", gfc_current_intrinsic_arg[m],
224 gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
230 /* Make sure that an expression has a certain (nonzero) rank. */
233 rank_check (gfc_expr *e, int n, int rank)
238 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
239 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
246 /* Make sure a variable expression is not an optional dummy argument. */
249 nonoptional_check (gfc_expr *e, int n)
251 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
253 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
254 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
258 /* TODO: Recursive check on nonoptional variables? */
264 /* Check that an expression has a particular kind. */
267 kind_value_check (gfc_expr *e, int n, int k)
272 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
273 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
280 /* Make sure an expression is a variable. */
283 variable_check (gfc_expr *e, int n)
285 if ((e->expr_type == EXPR_VARIABLE
286 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
287 || (e->expr_type == EXPR_FUNCTION
288 && e->symtree->n.sym->result == e->symtree->n.sym))
291 if (e->expr_type == EXPR_VARIABLE
292 && e->symtree->n.sym->attr.intent == INTENT_IN)
294 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
295 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
300 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
301 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
307 /* Check the common DIM parameter for correctness. */
310 dim_check (gfc_expr *dim, int n, int optional)
312 if (optional && dim == NULL)
317 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
318 gfc_current_intrinsic, gfc_current_intrinsic_where);
322 if (type_check (dim, n, BT_INTEGER) == FAILURE)
325 if (scalar_check (dim, n) == FAILURE)
328 if (nonoptional_check (dim, n) == FAILURE)
335 /* If a DIM parameter is a constant, make sure that it is greater than
336 zero and less than or equal to the rank of the given array. If
337 allow_assumed is zero then dim must be less than the rank of the array
338 for assumed size arrays. */
341 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
346 if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
349 ar = gfc_find_array_ref (array);
351 if (ar->as->type == AS_ASSUMED_SIZE
353 && ar->type != AR_ELEMENT
354 && ar->type != AR_SECTION)
357 if (mpz_cmp_ui (dim->value.integer, 1) < 0
358 || mpz_cmp_ui (dim->value.integer, rank) > 0)
360 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
361 "dimension index", gfc_current_intrinsic, &dim->where);
370 /* Compare the size of a along dimension ai with the size of b along
371 dimension bi, returning 0 if they are known not to be identical,
372 and 1 if they are identical, or if this cannot be determined. */
375 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
377 mpz_t a_size, b_size;
380 gcc_assert (a->rank > ai);
381 gcc_assert (b->rank > bi);
385 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
387 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
389 if (mpz_cmp (a_size, b_size) != 0)
400 /***** Check functions *****/
402 /* Check subroutine suitable for intrinsics taking a real argument and
403 a kind argument for the result. */
406 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
408 if (type_check (a, 0, BT_REAL) == FAILURE)
410 if (kind_check (kind, 1, type) == FAILURE)
417 /* Check subroutine suitable for ceiling, floor and nint. */
420 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
422 return check_a_kind (a, kind, BT_INTEGER);
426 /* Check subroutine suitable for aint, anint. */
429 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
431 return check_a_kind (a, kind, BT_REAL);
436 gfc_check_abs (gfc_expr *a)
438 if (numeric_check (a, 0) == FAILURE)
446 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
448 if (type_check (a, 0, BT_INTEGER) == FAILURE)
450 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
458 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
460 if (type_check (name, 0, BT_CHARACTER) == FAILURE
461 || scalar_check (name, 0) == FAILURE)
464 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
465 || scalar_check (mode, 1) == FAILURE)
473 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
475 if (logical_array_check (mask, 0) == FAILURE)
478 if (dim_check (dim, 1, 1) == FAILURE)
486 gfc_check_allocated (gfc_expr *array)
488 symbol_attribute attr;
490 if (variable_check (array, 0) == FAILURE)
493 attr = gfc_variable_attr (array, NULL);
494 if (!attr.allocatable)
496 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
497 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
502 if (array_check (array, 0) == FAILURE)
509 /* Common check function where the first argument must be real or
510 integer and the second argument must be the same as the first. */
513 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
515 if (int_or_real_check (a, 0) == FAILURE)
518 if (a->ts.type != p->ts.type)
520 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
521 "have the same type", gfc_current_intrinsic_arg[0],
522 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
527 if (a->ts.kind != p->ts.kind)
529 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
530 &p->where) == FAILURE)
539 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
541 symbol_attribute attr;
546 where = &pointer->where;
548 if (pointer->expr_type == EXPR_VARIABLE)
549 attr = gfc_variable_attr (pointer, NULL);
550 else if (pointer->expr_type == EXPR_FUNCTION)
551 attr = pointer->symtree->n.sym->attr;
552 else if (pointer->expr_type == EXPR_NULL)
555 gcc_assert (0); /* Pointer must be a variable or a function. */
559 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
560 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
565 /* Target argument is optional. */
569 where = &target->where;
570 if (target->expr_type == EXPR_NULL)
573 if (target->expr_type == EXPR_VARIABLE)
574 attr = gfc_variable_attr (target, NULL);
575 else if (target->expr_type == EXPR_FUNCTION)
576 attr = target->symtree->n.sym->attr;
579 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
580 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
581 gfc_current_intrinsic, &target->where);
585 if (!attr.pointer && !attr.target)
587 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
588 "or a TARGET", gfc_current_intrinsic_arg[1],
589 gfc_current_intrinsic, &target->where);
594 if (same_type_check (pointer, 0, target, 1) == FAILURE)
596 if (rank_check (target, 0, pointer->rank) == FAILURE)
598 if (target->rank > 0)
600 for (i = 0; i < target->rank; i++)
601 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
603 gfc_error ("Array section with a vector subscript at %L shall not "
604 "be the target of a pointer",
614 gfc_error ("NULL pointer at %L is not permitted as actual argument "
615 "of '%s' intrinsic function", where, gfc_current_intrinsic);
622 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
624 if (type_check (y, 0, BT_REAL) == FAILURE)
626 if (same_type_check (y, 0, x, 1) == FAILURE)
633 /* BESJN and BESYN functions. */
636 gfc_check_besn (gfc_expr *n, gfc_expr *x)
638 if (type_check (n, 0, BT_INTEGER) == FAILURE)
641 if (type_check (x, 1, BT_REAL) == FAILURE)
649 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
651 if (type_check (i, 0, BT_INTEGER) == FAILURE)
653 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
661 gfc_check_char (gfc_expr *i, gfc_expr *kind)
663 if (type_check (i, 0, BT_INTEGER) == FAILURE)
665 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
673 gfc_check_chdir (gfc_expr *dir)
675 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
683 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
685 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
691 if (type_check (status, 1, BT_INTEGER) == FAILURE)
694 if (scalar_check (status, 1) == FAILURE)
702 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
704 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
707 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
715 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
717 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
720 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
726 if (type_check (status, 2, BT_INTEGER) == FAILURE)
729 if (scalar_check (status, 2) == FAILURE)
737 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
739 if (numeric_check (x, 0) == FAILURE)
744 if (numeric_check (y, 1) == FAILURE)
747 if (x->ts.type == BT_COMPLEX)
749 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
750 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
751 gfc_current_intrinsic, &y->where);
756 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
764 gfc_check_complex (gfc_expr *x, gfc_expr *y)
766 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
768 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
769 "or REAL", gfc_current_intrinsic_arg[0],
770 gfc_current_intrinsic, &x->where);
773 if (scalar_check (x, 0) == FAILURE)
776 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
778 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
779 "or REAL", gfc_current_intrinsic_arg[1],
780 gfc_current_intrinsic, &y->where);
783 if (scalar_check (y, 1) == FAILURE)
791 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
793 if (logical_array_check (mask, 0) == FAILURE)
795 if (dim_check (dim, 1, 1) == FAILURE)
797 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
799 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
800 "with KIND argument at %L",
801 gfc_current_intrinsic, &kind->where) == FAILURE)
809 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
811 if (array_check (array, 0) == FAILURE)
814 if (array->rank == 1)
816 if (scalar_check (shift, 1) == FAILURE)
821 /* TODO: more requirements on shift parameter. */
824 if (dim_check (dim, 2, 1) == FAILURE)
832 gfc_check_ctime (gfc_expr *time)
834 if (scalar_check (time, 0) == FAILURE)
837 if (type_check (time, 0, BT_INTEGER) == FAILURE)
845 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
847 if (numeric_check (x, 0) == FAILURE)
852 if (numeric_check (y, 1) == FAILURE)
855 if (x->ts.type == BT_COMPLEX)
857 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
858 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
859 gfc_current_intrinsic, &y->where);
869 gfc_check_dble (gfc_expr *x)
871 if (numeric_check (x, 0) == FAILURE)
879 gfc_check_digits (gfc_expr *x)
881 if (int_or_real_check (x, 0) == FAILURE)
889 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
891 switch (vector_a->ts.type)
894 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
901 if (numeric_check (vector_b, 1) == FAILURE)
906 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
907 "or LOGICAL", gfc_current_intrinsic_arg[0],
908 gfc_current_intrinsic, &vector_a->where);
912 if (rank_check (vector_a, 0, 1) == FAILURE)
915 if (rank_check (vector_b, 1, 1) == FAILURE)
918 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
920 gfc_error ("different shape for arguments '%s' and '%s' at %L for "
921 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
922 gfc_current_intrinsic_arg[1], &vector_a->where);
931 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
934 if (array_check (array, 0) == FAILURE)
937 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
940 if (array->rank == 1)
942 if (scalar_check (shift, 2) == FAILURE)
947 /* TODO: more weird restrictions on shift. */
950 if (boundary != NULL)
952 if (same_type_check (array, 0, boundary, 2) == FAILURE)
955 /* TODO: more restrictions on boundary. */
958 if (dim_check (dim, 1, 1) == FAILURE)
965 /* A single complex argument. */
968 gfc_check_fn_c (gfc_expr *a)
970 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
977 /* A single real argument. */
980 gfc_check_fn_r (gfc_expr *a)
982 if (type_check (a, 0, BT_REAL) == FAILURE)
989 /* A single real or complex argument. */
992 gfc_check_fn_rc (gfc_expr *a)
994 if (real_or_complex_check (a, 0) == FAILURE)
1002 gfc_check_fnum (gfc_expr *unit)
1004 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1007 if (scalar_check (unit, 0) == FAILURE)
1015 gfc_check_huge (gfc_expr *x)
1017 if (int_or_real_check (x, 0) == FAILURE)
1024 /* Check that the single argument is an integer. */
1027 gfc_check_i (gfc_expr *i)
1029 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1037 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1039 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1042 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1045 if (i->ts.kind != j->ts.kind)
1047 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1048 &i->where) == FAILURE)
1057 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1059 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1062 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1070 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1072 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1075 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1078 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1086 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1088 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1091 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1099 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1103 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1106 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1109 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1110 "with KIND argument at %L",
1111 gfc_current_intrinsic, &kind->where) == FAILURE)
1114 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1120 /* Substring references don't have the charlength set. */
1122 while (ref && ref->type != REF_SUBSTRING)
1125 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1129 /* Check that the argument is length one. Non-constant lengths
1130 can't be checked here, so assume they are ok. */
1131 if (c->ts.cl && c->ts.cl->length)
1133 /* If we already have a length for this expression then use it. */
1134 if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1136 i = mpz_get_si (c->ts.cl->length->value.integer);
1143 start = ref->u.ss.start;
1144 end = ref->u.ss.end;
1147 if (end == NULL || end->expr_type != EXPR_CONSTANT
1148 || start->expr_type != EXPR_CONSTANT)
1151 i = mpz_get_si (end->value.integer) + 1
1152 - mpz_get_si (start->value.integer);
1160 gfc_error ("Argument of %s at %L must be of length one",
1161 gfc_current_intrinsic, &c->where);
1170 gfc_check_idnint (gfc_expr *a)
1172 if (double_check (a, 0) == FAILURE)
1180 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1182 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1185 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1188 if (i->ts.kind != j->ts.kind)
1190 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1191 &i->where) == FAILURE)
1200 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1203 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1204 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1207 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1210 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1212 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1213 "with KIND argument at %L",
1214 gfc_current_intrinsic, &kind->where) == FAILURE)
1217 if (string->ts.kind != substring->ts.kind)
1219 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1220 "kind as '%s'", gfc_current_intrinsic_arg[1],
1221 gfc_current_intrinsic, &substring->where,
1222 gfc_current_intrinsic_arg[0]);
1231 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1233 if (numeric_check (x, 0) == FAILURE)
1238 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1241 if (scalar_check (kind, 1) == FAILURE)
1250 gfc_check_intconv (gfc_expr *x)
1252 if (numeric_check (x, 0) == FAILURE)
1260 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1262 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1265 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1268 if (i->ts.kind != j->ts.kind)
1270 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1271 &i->where) == FAILURE)
1280 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1282 if (type_check (i, 0, BT_INTEGER) == FAILURE
1283 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1291 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1293 if (type_check (i, 0, BT_INTEGER) == FAILURE
1294 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1297 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1305 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1307 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1310 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1318 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1320 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1323 if (scalar_check (pid, 0) == FAILURE)
1326 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1329 if (scalar_check (sig, 1) == FAILURE)
1335 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1338 if (scalar_check (status, 2) == FAILURE)
1346 gfc_check_kind (gfc_expr *x)
1348 if (x->ts.type == BT_DERIVED)
1350 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1351 "non-derived type", gfc_current_intrinsic_arg[0],
1352 gfc_current_intrinsic, &x->where);
1361 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1363 if (array_check (array, 0) == FAILURE)
1368 if (dim_check (dim, 1, 1) == FAILURE)
1371 if (dim_rank_check (dim, array, 1) == FAILURE)
1375 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1377 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1378 "with KIND argument at %L",
1379 gfc_current_intrinsic, &kind->where) == FAILURE)
1387 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
1389 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
1392 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1394 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1395 "with KIND argument at %L",
1396 gfc_current_intrinsic, &kind->where) == FAILURE)
1404 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1406 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1409 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1417 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1419 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1422 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1428 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1431 if (scalar_check (status, 2) == FAILURE)
1439 gfc_check_loc (gfc_expr *expr)
1441 return variable_check (expr, 0);
1446 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1448 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1451 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1459 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1461 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1464 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1470 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1473 if (scalar_check (status, 2) == FAILURE)
1481 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1483 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1485 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1492 /* Min/max family. */
1495 min_max_args (gfc_actual_arglist *arg)
1497 if (arg == NULL || arg->next == NULL)
1499 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1500 gfc_current_intrinsic, gfc_current_intrinsic_where);
1509 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
1511 gfc_actual_arglist *arg, *tmp;
1516 if (min_max_args (arglist) == FAILURE)
1519 for (arg = arglist, n=1; arg; arg = arg->next, n++)
1522 if (x->ts.type != type || x->ts.kind != kind)
1524 if (x->ts.type == type)
1526 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1527 "kinds at %L", &x->where) == FAILURE)
1532 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1533 "%s(%d)", n, gfc_current_intrinsic, &x->where,
1534 gfc_basic_typename (type), kind);
1539 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
1542 snprintf (buffer, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
1543 m, n, gfc_current_intrinsic);
1544 if (gfc_check_conformance (buffer, tmp->expr, x) == FAILURE)
1554 gfc_check_min_max (gfc_actual_arglist *arg)
1558 if (min_max_args (arg) == FAILURE)
1563 if (x->ts.type == BT_CHARACTER)
1565 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1566 "with CHARACTER argument at %L",
1567 gfc_current_intrinsic, &x->where) == FAILURE)
1570 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1572 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1573 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
1577 return check_rest (x->ts.type, x->ts.kind, arg);
1582 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1584 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1589 gfc_check_min_max_real (gfc_actual_arglist *arg)
1591 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1596 gfc_check_min_max_double (gfc_actual_arglist *arg)
1598 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1602 /* End of min/max family. */
1605 gfc_check_malloc (gfc_expr *size)
1607 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1610 if (scalar_check (size, 0) == FAILURE)
1618 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1620 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1622 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1623 "or LOGICAL", gfc_current_intrinsic_arg[0],
1624 gfc_current_intrinsic, &matrix_a->where);
1628 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1630 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1631 "or LOGICAL", gfc_current_intrinsic_arg[1],
1632 gfc_current_intrinsic, &matrix_b->where);
1636 switch (matrix_a->rank)
1639 if (rank_check (matrix_b, 1, 2) == FAILURE)
1641 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1642 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1644 gfc_error ("different shape on dimension 1 for arguments '%s' "
1645 "and '%s' at %L for intrinsic matmul",
1646 gfc_current_intrinsic_arg[0],
1647 gfc_current_intrinsic_arg[1], &matrix_a->where);
1653 if (matrix_b->rank != 2)
1655 if (rank_check (matrix_b, 1, 1) == FAILURE)
1658 /* matrix_b has rank 1 or 2 here. Common check for the cases
1659 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1660 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1661 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1663 gfc_error ("different shape on dimension 2 for argument '%s' and "
1664 "dimension 1 for argument '%s' at %L for intrinsic "
1665 "matmul", gfc_current_intrinsic_arg[0],
1666 gfc_current_intrinsic_arg[1], &matrix_a->where);
1672 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1673 "1 or 2", gfc_current_intrinsic_arg[0],
1674 gfc_current_intrinsic, &matrix_a->where);
1682 /* Whoever came up with this interface was probably on something.
1683 The possibilities for the occupation of the second and third
1690 NULL MASK minloc(array, mask=m)
1693 I.e. in the case of minloc(array,mask), mask will be in the second
1694 position of the argument list and we'll have to fix that up. */
1697 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1699 gfc_expr *a, *m, *d;
1702 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1706 m = ap->next->next->expr;
1708 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1709 && ap->next->name == NULL)
1713 ap->next->expr = NULL;
1714 ap->next->next->expr = m;
1717 if (dim_check (d, 1, 1) == FAILURE)
1720 if (d && dim_rank_check (d, a, 0) == FAILURE)
1723 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1729 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1730 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1731 gfc_current_intrinsic);
1732 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1740 /* Similar to minloc/maxloc, the argument list might need to be
1741 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1742 difference is that MINLOC/MAXLOC take an additional KIND argument.
1743 The possibilities are:
1749 NULL MASK minval(array, mask=m)
1752 I.e. in the case of minval(array,mask), mask will be in the second
1753 position of the argument list and we'll have to fix that up. */
1756 check_reduction (gfc_actual_arglist *ap)
1758 gfc_expr *a, *m, *d;
1762 m = ap->next->next->expr;
1764 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1765 && ap->next->name == NULL)
1769 ap->next->expr = NULL;
1770 ap->next->next->expr = m;
1773 if (dim_check (d, 1, 1) == FAILURE)
1776 if (d && dim_rank_check (d, a, 0) == FAILURE)
1779 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1785 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1786 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1787 gfc_current_intrinsic);
1788 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1797 gfc_check_minval_maxval (gfc_actual_arglist *ap)
1799 if (int_or_real_check (ap->expr, 0) == FAILURE
1800 || array_check (ap->expr, 0) == FAILURE)
1803 return check_reduction (ap);
1808 gfc_check_product_sum (gfc_actual_arglist *ap)
1810 if (numeric_check (ap->expr, 0) == FAILURE
1811 || array_check (ap->expr, 0) == FAILURE)
1814 return check_reduction (ap);
1819 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
1821 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1824 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1831 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
1833 symbol_attribute attr;
1835 if (variable_check (from, 0) == FAILURE)
1838 if (array_check (from, 0) == FAILURE)
1841 attr = gfc_variable_attr (from, NULL);
1842 if (!attr.allocatable)
1844 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1845 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1850 if (variable_check (to, 0) == FAILURE)
1853 if (array_check (to, 0) == FAILURE)
1856 attr = gfc_variable_attr (to, NULL);
1857 if (!attr.allocatable)
1859 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1860 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1865 if (same_type_check (from, 0, to, 1) == FAILURE)
1868 if (to->rank != from->rank)
1870 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1871 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1872 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1873 &to->where, from->rank, to->rank);
1877 if (to->ts.kind != from->ts.kind)
1879 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1880 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1881 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1882 &to->where, from->ts.kind, to->ts.kind);
1891 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
1893 if (type_check (x, 0, BT_REAL) == FAILURE)
1896 if (type_check (s, 1, BT_REAL) == FAILURE)
1904 gfc_check_new_line (gfc_expr *a)
1906 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1914 gfc_check_null (gfc_expr *mold)
1916 symbol_attribute attr;
1921 if (variable_check (mold, 0) == FAILURE)
1924 attr = gfc_variable_attr (mold, NULL);
1928 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1929 gfc_current_intrinsic_arg[0],
1930 gfc_current_intrinsic, &mold->where);
1939 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
1943 if (array_check (array, 0) == FAILURE)
1946 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1949 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1950 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1951 gfc_current_intrinsic);
1952 if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1957 if (same_type_check (array, 0, vector, 2) == FAILURE)
1960 if (rank_check (vector, 2, 1) == FAILURE)
1963 /* TODO: More constraints here. */
1971 gfc_check_precision (gfc_expr *x)
1973 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1975 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1976 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1977 gfc_current_intrinsic, &x->where);
1986 gfc_check_present (gfc_expr *a)
1990 if (variable_check (a, 0) == FAILURE)
1993 sym = a->symtree->n.sym;
1994 if (!sym->attr.dummy)
1996 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1997 "dummy variable", gfc_current_intrinsic_arg[0],
1998 gfc_current_intrinsic, &a->where);
2002 if (!sym->attr.optional)
2004 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2005 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2006 gfc_current_intrinsic, &a->where);
2010 /* 13.14.82 PRESENT(A)
2012 Argument. A shall be the name of an optional dummy argument that is
2013 accessible in the subprogram in which the PRESENT function reference
2017 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2018 && a->ref->u.ar.type == AR_FULL))
2020 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2021 "subobject of '%s'", gfc_current_intrinsic_arg[0],
2022 gfc_current_intrinsic, &a->where, sym->name);
2031 gfc_check_radix (gfc_expr *x)
2033 if (int_or_real_check (x, 0) == FAILURE)
2041 gfc_check_range (gfc_expr *x)
2043 if (numeric_check (x, 0) == FAILURE)
2050 /* real, float, sngl. */
2052 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2054 if (numeric_check (a, 0) == FAILURE)
2057 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2065 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2067 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2070 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2078 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2080 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2083 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2089 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2092 if (scalar_check (status, 2) == FAILURE)
2100 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2102 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2105 if (scalar_check (x, 0) == FAILURE)
2108 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2111 if (scalar_check (y, 1) == FAILURE)
2119 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2120 gfc_expr *pad, gfc_expr *order)
2126 if (array_check (source, 0) == FAILURE)
2129 if (rank_check (shape, 1, 1) == FAILURE)
2132 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2135 if (gfc_array_size (shape, &size) != SUCCESS)
2137 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2138 "array of constant size", &shape->where);
2142 m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2147 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2148 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2154 if (same_type_check (source, 0, pad, 2) == FAILURE)
2156 if (array_check (pad, 2) == FAILURE)
2160 if (order != NULL && array_check (order, 3) == FAILURE)
2163 if (pad == NULL && shape->expr_type == EXPR_ARRAY
2164 && gfc_is_constant_expr (shape)
2165 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2166 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2168 /* Check the match in size between source and destination. */
2169 if (gfc_array_size (source, &nelems) == SUCCESS)
2174 c = shape->value.constructor;
2175 mpz_init_set_ui (size, 1);
2176 for (; c; c = c->next)
2177 mpz_mul (size, size, c->expr->value.integer);
2179 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2185 gfc_error ("Without padding, there are not enough elements "
2186 "in the intrinsic RESHAPE source at %L to match "
2187 "the shape", &source->where);
2198 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2200 if (type_check (x, 0, BT_REAL) == FAILURE)
2203 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2211 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2213 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2216 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2219 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2222 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2224 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2225 "with KIND argument at %L",
2226 gfc_current_intrinsic, &kind->where) == FAILURE)
2229 if (same_type_check (x, 0, y, 1) == FAILURE)
2237 gfc_check_secnds (gfc_expr *r)
2239 if (type_check (r, 0, BT_REAL) == FAILURE)
2242 if (kind_value_check (r, 0, 4) == FAILURE)
2245 if (scalar_check (r, 0) == FAILURE)
2253 gfc_check_selected_int_kind (gfc_expr *r)
2255 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2258 if (scalar_check (r, 0) == FAILURE)
2266 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2268 if (p == NULL && r == NULL)
2270 gfc_error ("Missing arguments to %s intrinsic at %L",
2271 gfc_current_intrinsic, gfc_current_intrinsic_where);
2276 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2279 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2287 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2289 if (type_check (x, 0, BT_REAL) == FAILURE)
2292 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2300 gfc_check_shape (gfc_expr *source)
2304 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2307 ar = gfc_find_array_ref (source);
2309 if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2311 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2312 "an assumed size array", &source->where);
2321 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2323 if (int_or_real_check (a, 0) == FAILURE)
2326 if (same_type_check (a, 0, b, 1) == FAILURE)
2334 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2336 if (array_check (array, 0) == FAILURE)
2341 if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2344 if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2347 if (dim_rank_check (dim, array, 0) == FAILURE)
2351 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2353 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2354 "with KIND argument at %L",
2355 gfc_current_intrinsic, &kind->where) == FAILURE)
2364 gfc_check_sizeof (gfc_expr *arg __attribute__((unused)))
2371 gfc_check_sleep_sub (gfc_expr *seconds)
2373 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2376 if (scalar_check (seconds, 0) == FAILURE)
2384 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2386 if (source->rank >= GFC_MAX_DIMENSIONS)
2388 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2389 "than rank %d", gfc_current_intrinsic_arg[0],
2390 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2395 if (dim_check (dim, 1, 0) == FAILURE)
2398 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2401 if (scalar_check (ncopies, 2) == FAILURE)
2408 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2412 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2414 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2417 if (scalar_check (unit, 0) == FAILURE)
2420 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2426 if (type_check (status, 2, BT_INTEGER) == FAILURE
2427 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2428 || scalar_check (status, 2) == FAILURE)
2436 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2438 return gfc_check_fgetputc_sub (unit, c, NULL);
2443 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2445 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2451 if (type_check (status, 1, BT_INTEGER) == FAILURE
2452 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2453 || scalar_check (status, 1) == FAILURE)
2461 gfc_check_fgetput (gfc_expr *c)
2463 return gfc_check_fgetput_sub (c, NULL);
2468 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2470 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2473 if (scalar_check (unit, 0) == FAILURE)
2476 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2479 if (scalar_check (offset, 1) == FAILURE)
2482 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2485 if (scalar_check (whence, 2) == FAILURE)
2491 if (type_check (status, 3, BT_INTEGER) == FAILURE)
2494 if (kind_value_check (status, 3, 4) == FAILURE)
2497 if (scalar_check (status, 3) == FAILURE)
2506 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2508 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2511 if (scalar_check (unit, 0) == FAILURE)
2514 if (type_check (array, 1, BT_INTEGER) == FAILURE
2515 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2518 if (array_check (array, 1) == FAILURE)
2526 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2528 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2531 if (scalar_check (unit, 0) == FAILURE)
2534 if (type_check (array, 1, BT_INTEGER) == FAILURE
2535 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2538 if (array_check (array, 1) == FAILURE)
2544 if (type_check (status, 2, BT_INTEGER) == FAILURE
2545 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2548 if (scalar_check (status, 2) == FAILURE)
2556 gfc_check_ftell (gfc_expr *unit)
2558 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2561 if (scalar_check (unit, 0) == FAILURE)
2569 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2571 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2574 if (scalar_check (unit, 0) == FAILURE)
2577 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2580 if (scalar_check (offset, 1) == FAILURE)
2588 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2590 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2593 if (type_check (array, 1, BT_INTEGER) == FAILURE
2594 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2597 if (array_check (array, 1) == FAILURE)
2605 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2607 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2610 if (type_check (array, 1, BT_INTEGER) == FAILURE
2611 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2614 if (array_check (array, 1) == FAILURE)
2620 if (type_check (status, 2, BT_INTEGER) == FAILURE
2621 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2624 if (scalar_check (status, 2) == FAILURE)
2632 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2633 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2635 if (mold->ts.type == BT_HOLLERITH)
2637 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
2638 &mold->where, gfc_basic_typename (BT_HOLLERITH));
2644 if (type_check (size, 2, BT_INTEGER) == FAILURE)
2647 if (scalar_check (size, 2) == FAILURE)
2650 if (nonoptional_check (size, 2) == FAILURE)
2659 gfc_check_transpose (gfc_expr *matrix)
2661 if (rank_check (matrix, 0, 2) == FAILURE)
2669 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2671 if (array_check (array, 0) == FAILURE)
2676 if (dim_check (dim, 1, 1) == FAILURE)
2679 if (dim_rank_check (dim, array, 0) == FAILURE)
2683 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2685 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2686 "with KIND argument at %L",
2687 gfc_current_intrinsic, &kind->where) == FAILURE)
2695 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2697 if (rank_check (vector, 0, 1) == FAILURE)
2700 if (array_check (mask, 1) == FAILURE)
2703 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2706 if (same_type_check (vector, 0, field, 2) == FAILURE)
2714 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2716 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2719 if (same_type_check (x, 0, y, 1) == FAILURE)
2722 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2725 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2727 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2728 "with KIND argument at %L",
2729 gfc_current_intrinsic, &kind->where) == FAILURE)
2737 gfc_check_trim (gfc_expr *x)
2739 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2742 if (scalar_check (x, 0) == FAILURE)
2750 gfc_check_ttynam (gfc_expr *unit)
2752 if (scalar_check (unit, 0) == FAILURE)
2755 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2762 /* Common check function for the half a dozen intrinsics that have a
2763 single real argument. */
2766 gfc_check_x (gfc_expr *x)
2768 if (type_check (x, 0, BT_REAL) == FAILURE)
2775 /************* Check functions for intrinsic subroutines *************/
2778 gfc_check_cpu_time (gfc_expr *time)
2780 if (scalar_check (time, 0) == FAILURE)
2783 if (type_check (time, 0, BT_REAL) == FAILURE)
2786 if (variable_check (time, 0) == FAILURE)
2794 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2795 gfc_expr *zone, gfc_expr *values)
2799 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2801 if (scalar_check (date, 0) == FAILURE)
2803 if (variable_check (date, 0) == FAILURE)
2809 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2811 if (scalar_check (time, 1) == FAILURE)
2813 if (variable_check (time, 1) == FAILURE)
2819 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2821 if (scalar_check (zone, 2) == FAILURE)
2823 if (variable_check (zone, 2) == FAILURE)
2829 if (type_check (values, 3, BT_INTEGER) == FAILURE)
2831 if (array_check (values, 3) == FAILURE)
2833 if (rank_check (values, 3, 1) == FAILURE)
2835 if (variable_check (values, 3) == FAILURE)
2844 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2845 gfc_expr *to, gfc_expr *topos)
2847 if (type_check (from, 0, BT_INTEGER) == FAILURE)
2850 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2853 if (type_check (len, 2, BT_INTEGER) == FAILURE)
2856 if (same_type_check (from, 0, to, 3) == FAILURE)
2859 if (variable_check (to, 3) == FAILURE)
2862 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2870 gfc_check_random_number (gfc_expr *harvest)
2872 if (type_check (harvest, 0, BT_REAL) == FAILURE)
2875 if (variable_check (harvest, 0) == FAILURE)
2883 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2885 unsigned int nargs = 0;
2886 locus *where = NULL;
2890 if (size->expr_type != EXPR_VARIABLE
2891 || !size->symtree->n.sym->attr.optional)
2894 if (scalar_check (size, 0) == FAILURE)
2897 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2900 if (variable_check (size, 0) == FAILURE)
2903 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2909 if (put->expr_type != EXPR_VARIABLE
2910 || !put->symtree->n.sym->attr.optional)
2913 where = &put->where;
2916 if (array_check (put, 1) == FAILURE)
2919 if (rank_check (put, 1, 1) == FAILURE)
2922 if (type_check (put, 1, BT_INTEGER) == FAILURE)
2925 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2931 if (get->expr_type != EXPR_VARIABLE
2932 || !get->symtree->n.sym->attr.optional)
2935 where = &get->where;
2938 if (array_check (get, 2) == FAILURE)
2941 if (rank_check (get, 2, 1) == FAILURE)
2944 if (type_check (get, 2, BT_INTEGER) == FAILURE)
2947 if (variable_check (get, 2) == FAILURE)
2950 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2954 /* RANDOM_SEED may not have more than one non-optional argument. */
2956 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
2963 gfc_check_second_sub (gfc_expr *time)
2965 if (scalar_check (time, 0) == FAILURE)
2968 if (type_check (time, 0, BT_REAL) == FAILURE)
2971 if (kind_value_check(time, 0, 4) == FAILURE)
2978 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2979 count, count_rate, and count_max are all optional arguments */
2982 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
2983 gfc_expr *count_max)
2987 if (scalar_check (count, 0) == FAILURE)
2990 if (type_check (count, 0, BT_INTEGER) == FAILURE)
2993 if (variable_check (count, 0) == FAILURE)
2997 if (count_rate != NULL)
2999 if (scalar_check (count_rate, 1) == FAILURE)
3002 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3005 if (variable_check (count_rate, 1) == FAILURE)
3009 && same_type_check (count, 0, count_rate, 1) == FAILURE)
3014 if (count_max != NULL)
3016 if (scalar_check (count_max, 2) == FAILURE)
3019 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3022 if (variable_check (count_max, 2) == FAILURE)
3026 && same_type_check (count, 0, count_max, 2) == FAILURE)
3029 if (count_rate != NULL
3030 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3039 gfc_check_irand (gfc_expr *x)
3044 if (scalar_check (x, 0) == FAILURE)
3047 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3050 if (kind_value_check(x, 0, 4) == FAILURE)
3058 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3060 if (scalar_check (seconds, 0) == FAILURE)
3063 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3066 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3068 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3069 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3070 gfc_current_intrinsic, &handler->where);
3074 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3080 if (scalar_check (status, 2) == FAILURE)
3083 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3086 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3094 gfc_check_rand (gfc_expr *x)
3099 if (scalar_check (x, 0) == FAILURE)
3102 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3105 if (kind_value_check(x, 0, 4) == FAILURE)
3113 gfc_check_srand (gfc_expr *x)
3115 if (scalar_check (x, 0) == FAILURE)
3118 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3121 if (kind_value_check(x, 0, 4) == FAILURE)
3129 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3131 if (scalar_check (time, 0) == FAILURE)
3134 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3137 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3145 gfc_check_etime (gfc_expr *x)
3147 if (array_check (x, 0) == FAILURE)
3150 if (rank_check (x, 0, 1) == FAILURE)
3153 if (variable_check (x, 0) == FAILURE)
3156 if (type_check (x, 0, BT_REAL) == FAILURE)
3159 if (kind_value_check(x, 0, 4) == FAILURE)
3167 gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
3169 if (array_check (values, 0) == FAILURE)
3172 if (rank_check (values, 0, 1) == FAILURE)
3175 if (variable_check (values, 0) == FAILURE)
3178 if (type_check (values, 0, BT_REAL) == FAILURE)
3181 if (kind_value_check(values, 0, 4) == FAILURE)
3184 if (scalar_check (time, 1) == FAILURE)
3187 if (type_check (time, 1, BT_REAL) == FAILURE)
3190 if (kind_value_check(time, 1, 4) == FAILURE)
3198 gfc_check_fdate_sub (gfc_expr *date)
3200 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3208 gfc_check_gerror (gfc_expr *msg)
3210 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3218 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3220 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3226 if (scalar_check (status, 1) == FAILURE)
3229 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3237 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
3239 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
3242 if (pos->ts.kind > gfc_default_integer_kind)
3244 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3245 "not wider than the default kind (%d)",
3246 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3247 &pos->where, gfc_default_integer_kind);
3251 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
3259 gfc_check_getlog (gfc_expr *msg)
3261 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3269 gfc_check_exit (gfc_expr *status)
3274 if (type_check (status, 0, BT_INTEGER) == FAILURE)
3277 if (scalar_check (status, 0) == FAILURE)
3285 gfc_check_flush (gfc_expr *unit)
3290 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3293 if (scalar_check (unit, 0) == FAILURE)
3301 gfc_check_free (gfc_expr *i)
3303 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3306 if (scalar_check (i, 0) == FAILURE)
3314 gfc_check_hostnm (gfc_expr *name)
3316 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3324 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3326 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3332 if (scalar_check (status, 1) == FAILURE)
3335 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3343 gfc_check_itime_idate (gfc_expr *values)
3345 if (array_check (values, 0) == FAILURE)
3348 if (rank_check (values, 0, 1) == FAILURE)
3351 if (variable_check (values, 0) == FAILURE)
3354 if (type_check (values, 0, BT_INTEGER) == FAILURE)
3357 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3365 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3367 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3370 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3373 if (scalar_check (time, 0) == FAILURE)
3376 if (array_check (values, 1) == FAILURE)
3379 if (rank_check (values, 1, 1) == FAILURE)
3382 if (variable_check (values, 1) == FAILURE)
3385 if (type_check (values, 1, BT_INTEGER) == FAILURE)
3388 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3396 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3398 if (scalar_check (unit, 0) == FAILURE)
3401 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3404 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3412 gfc_check_isatty (gfc_expr *unit)
3417 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3420 if (scalar_check (unit, 0) == FAILURE)
3428 gfc_check_isnan (gfc_expr *x)
3430 if (type_check (x, 0, BT_REAL) == FAILURE)
3438 gfc_check_perror (gfc_expr *string)
3440 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3448 gfc_check_umask (gfc_expr *mask)
3450 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3453 if (scalar_check (mask, 0) == FAILURE)
3461 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3463 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3466 if (scalar_check (mask, 0) == FAILURE)
3472 if (scalar_check (old, 1) == FAILURE)
3475 if (type_check (old, 1, BT_INTEGER) == FAILURE)
3483 gfc_check_unlink (gfc_expr *name)
3485 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3493 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3495 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3501 if (scalar_check (status, 1) == FAILURE)
3504 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3512 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3514 if (scalar_check (number, 0) == FAILURE)
3517 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3520 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3522 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3523 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3524 gfc_current_intrinsic, &handler->where);
3528 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3536 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3538 if (scalar_check (number, 0) == FAILURE)
3541 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3544 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3546 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3547 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3548 gfc_current_intrinsic, &handler->where);
3552 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3558 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3561 if (scalar_check (status, 2) == FAILURE)
3569 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3571 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3574 if (scalar_check (status, 1) == FAILURE)
3577 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3580 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3587 /* This is used for the GNU intrinsics AND, OR and XOR. */
3589 gfc_check_and (gfc_expr *i, gfc_expr *j)
3591 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3593 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3594 "or LOGICAL", gfc_current_intrinsic_arg[0],
3595 gfc_current_intrinsic, &i->where);
3599 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3601 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3602 "or LOGICAL", gfc_current_intrinsic_arg[1],
3603 gfc_current_intrinsic, &j->where);
3607 if (i->ts.type != j->ts.type)
3609 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3610 "have the same type", gfc_current_intrinsic_arg[0],
3611 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3616 if (scalar_check (i, 0) == FAILURE)
3619 if (scalar_check (j, 1) == FAILURE)