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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* These functions check to see if an argument list is compatible with
25 a particular intrinsic function or subroutine. Presence of
26 required arguments has already been established, the argument list
27 has been sorted into the right order and has NULL arguments in the
28 correct places for missing optional arguments. */
34 #include "intrinsic.h"
37 /* Check the type of an expression. */
40 type_check (gfc_expr *e, int n, bt type)
42 if (e->ts.type == type)
45 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
46 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
47 gfc_basic_typename (type));
53 /* Check that the expression is a numeric type. */
56 numeric_check (gfc_expr *e, int n)
58 if (gfc_numeric_ts (&e->ts))
61 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
62 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
68 /* Check that an expression is integer or real. */
71 int_or_real_check (gfc_expr *e, int n)
73 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
75 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
76 "or REAL", gfc_current_intrinsic_arg[n],
77 gfc_current_intrinsic, &e->where);
85 /* Check that an expression is real or complex. */
88 real_or_complex_check (gfc_expr *e, int n)
90 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
92 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
93 "or COMPLEX", gfc_current_intrinsic_arg[n],
94 gfc_current_intrinsic, &e->where);
102 /* Check that the expression is an optional constant integer
103 and that it specifies a valid kind for that type. */
106 kind_check (gfc_expr *k, int n, bt type)
113 if (type_check (k, n, BT_INTEGER) == FAILURE)
116 if (k->expr_type != EXPR_CONSTANT)
118 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
119 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
124 if (gfc_extract_int (k, &kind) != NULL
125 || gfc_validate_kind (type, kind, true) < 0)
127 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
136 /* Make sure the expression is a double precision real. */
139 double_check (gfc_expr *d, int n)
141 if (type_check (d, n, BT_REAL) == FAILURE)
144 if (d->ts.kind != gfc_default_double_kind)
146 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
147 "precision", gfc_current_intrinsic_arg[n],
148 gfc_current_intrinsic, &d->where);
156 /* Make sure the expression is a logical array. */
159 logical_array_check (gfc_expr *array, int n)
161 if (array->ts.type != BT_LOGICAL || array->rank == 0)
163 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
164 "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
173 /* Make sure an expression is an array. */
176 array_check (gfc_expr *e, int n)
181 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
182 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
188 /* Make sure an expression is a scalar. */
191 scalar_check (gfc_expr *e, int n)
196 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
197 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
203 /* Make sure two expressions have the same type. */
206 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
208 if (gfc_compare_types (&e->ts, &f->ts))
211 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
212 "and kind as '%s'", gfc_current_intrinsic_arg[m],
213 gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
219 /* Make sure that an expression has a certain (nonzero) rank. */
222 rank_check (gfc_expr *e, int n, int rank)
227 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
228 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
235 /* Make sure a variable expression is not an optional dummy argument. */
238 nonoptional_check (gfc_expr *e, int n)
240 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
242 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
243 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
247 /* TODO: Recursive check on nonoptional variables? */
253 /* Check that an expression has a particular kind. */
256 kind_value_check (gfc_expr *e, int n, int k)
261 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
262 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
269 /* Make sure an expression is a variable. */
272 variable_check (gfc_expr *e, int n)
274 if ((e->expr_type == EXPR_VARIABLE
275 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
276 || (e->expr_type == EXPR_FUNCTION
277 && e->symtree->n.sym->result == e->symtree->n.sym))
280 if (e->expr_type == EXPR_VARIABLE
281 && e->symtree->n.sym->attr.intent == INTENT_IN)
283 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
284 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
289 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
290 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
296 /* Check the common DIM parameter for correctness. */
299 dim_check (gfc_expr *dim, int n, int optional)
301 if (optional && dim == NULL)
306 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
307 gfc_current_intrinsic, gfc_current_intrinsic_where);
311 if (type_check (dim, n, BT_INTEGER) == FAILURE)
314 if (scalar_check (dim, n) == FAILURE)
317 if (nonoptional_check (dim, n) == FAILURE)
324 /* If a DIM parameter is a constant, make sure that it is greater than
325 zero and less than or equal to the rank of the given array. If
326 allow_assumed is zero then dim must be less than the rank of the array
327 for assumed size arrays. */
330 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
335 if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
338 ar = gfc_find_array_ref (array);
340 if (ar->as->type == AS_ASSUMED_SIZE
342 && ar->type != AR_ELEMENT
343 && ar->type != AR_SECTION)
346 if (mpz_cmp_ui (dim->value.integer, 1) < 0
347 || mpz_cmp_ui (dim->value.integer, rank) > 0)
349 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
350 "dimension index", gfc_current_intrinsic, &dim->where);
359 /* Compare the size of a along dimension ai with the size of b along
360 dimension bi, returning 0 if they are known not to be identical,
361 and 1 if they are identical, or if this cannot be determined. */
364 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
366 mpz_t a_size, b_size;
369 gcc_assert (a->rank > ai);
370 gcc_assert (b->rank > bi);
374 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
376 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
378 if (mpz_cmp (a_size, b_size) != 0)
389 /* Error return for transformational intrinsics not allowed in
390 initialization expressions. */
393 non_init_transformational (void)
395 gfc_error ("transformational intrinsic '%s' at %L is not permitted "
396 "in an initialization expression", gfc_current_intrinsic,
397 gfc_current_intrinsic_where);
401 /***** Check functions *****/
403 /* Check subroutine suitable for intrinsics taking a real argument and
404 a kind argument for the result. */
407 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
409 if (type_check (a, 0, BT_REAL) == FAILURE)
411 if (kind_check (kind, 1, type) == FAILURE)
418 /* Check subroutine suitable for ceiling, floor and nint. */
421 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
423 return check_a_kind (a, kind, BT_INTEGER);
427 /* Check subroutine suitable for aint, anint. */
430 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
432 return check_a_kind (a, kind, BT_REAL);
437 gfc_check_abs (gfc_expr *a)
439 if (numeric_check (a, 0) == FAILURE)
447 gfc_check_achar (gfc_expr *a)
449 if (type_check (a, 0, BT_INTEGER) == FAILURE)
457 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
459 if (type_check (name, 0, BT_CHARACTER) == FAILURE
460 || scalar_check (name, 0) == FAILURE)
463 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
464 || scalar_check (mode, 1) == FAILURE)
472 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
474 if (logical_array_check (mask, 0) == FAILURE)
477 if (dim_check (dim, 1, 1) == FAILURE)
481 return non_init_transformational ();
488 gfc_check_allocated (gfc_expr *array)
490 symbol_attribute attr;
492 if (variable_check (array, 0) == FAILURE)
495 if (array_check (array, 0) == FAILURE)
498 attr = gfc_variable_attr (array, NULL);
499 if (!attr.allocatable)
501 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
502 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
511 /* Common check function where the first argument must be real or
512 integer and the second argument must be the same as the first. */
515 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
517 if (int_or_real_check (a, 0) == FAILURE)
520 if (a->ts.type != p->ts.type)
522 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
523 "have the same type", gfc_current_intrinsic_arg[0],
524 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
529 if (a->ts.kind != p->ts.kind)
531 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
532 &p->where) == FAILURE)
541 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
543 symbol_attribute attr;
548 where = &pointer->where;
550 if (pointer->expr_type == EXPR_VARIABLE)
551 attr = gfc_variable_attr (pointer, NULL);
552 else if (pointer->expr_type == EXPR_FUNCTION)
553 attr = pointer->symtree->n.sym->attr;
554 else if (pointer->expr_type == EXPR_NULL)
557 gcc_assert (0); /* Pointer must be a variable or a function. */
561 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
562 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
567 /* Target argument is optional. */
571 where = &target->where;
572 if (target->expr_type == EXPR_NULL)
575 if (target->expr_type == EXPR_VARIABLE)
576 attr = gfc_variable_attr (target, NULL);
577 else if (target->expr_type == EXPR_FUNCTION)
578 attr = target->symtree->n.sym->attr;
581 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
582 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
583 gfc_current_intrinsic, &target->where);
587 if (!attr.pointer && !attr.target)
589 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
590 "or a TARGET", gfc_current_intrinsic_arg[1],
591 gfc_current_intrinsic, &target->where);
596 if (same_type_check (pointer, 0, target, 1) == FAILURE)
598 if (rank_check (target, 0, pointer->rank) == FAILURE)
600 if (target->rank > 0)
602 for (i = 0; i < target->rank; i++)
603 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
605 gfc_error ("Array section with a vector subscript at %L shall not "
606 "be the target of a pointer",
616 gfc_error ("NULL pointer at %L is not permitted as actual argument "
617 "of '%s' intrinsic function", where, gfc_current_intrinsic);
624 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
626 if (type_check (y, 0, BT_REAL) == FAILURE)
628 if (same_type_check (y, 0, x, 1) == FAILURE)
635 /* BESJN and BESYN functions. */
638 gfc_check_besn (gfc_expr *n, gfc_expr *x)
640 if (scalar_check (n, 0) == FAILURE)
643 if (type_check (n, 0, BT_INTEGER) == FAILURE)
646 if (scalar_check (x, 1) == FAILURE)
649 if (type_check (x, 1, BT_REAL) == FAILURE)
657 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
659 if (type_check (i, 0, BT_INTEGER) == FAILURE)
661 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
669 gfc_check_char (gfc_expr *i, gfc_expr *kind)
671 if (type_check (i, 0, BT_INTEGER) == FAILURE)
673 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
681 gfc_check_chdir (gfc_expr *dir)
683 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
691 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
693 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
699 if (type_check (status, 1, BT_INTEGER) == FAILURE)
702 if (scalar_check (status, 1) == FAILURE)
710 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
712 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
715 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
723 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
725 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
728 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
734 if (type_check (status, 2, BT_INTEGER) == FAILURE)
737 if (scalar_check (status, 2) == FAILURE)
745 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
747 if (numeric_check (x, 0) == FAILURE)
752 if (numeric_check (y, 1) == FAILURE)
755 if (x->ts.type == BT_COMPLEX)
757 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
758 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
759 gfc_current_intrinsic, &y->where);
764 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
772 gfc_check_complex (gfc_expr *x, gfc_expr *y)
774 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
776 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
777 "or REAL", gfc_current_intrinsic_arg[0],
778 gfc_current_intrinsic, &x->where);
781 if (scalar_check (x, 0) == FAILURE)
784 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
786 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
787 "or REAL", gfc_current_intrinsic_arg[1],
788 gfc_current_intrinsic, &y->where);
791 if (scalar_check (y, 1) == FAILURE)
799 gfc_check_count (gfc_expr *mask, gfc_expr *dim)
801 if (logical_array_check (mask, 0) == FAILURE)
803 if (dim_check (dim, 1, 1) == FAILURE)
807 return non_init_transformational ();
814 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
816 if (array_check (array, 0) == FAILURE)
819 if (array->rank == 1)
821 if (scalar_check (shift, 1) == FAILURE)
826 /* TODO: more requirements on shift parameter. */
829 if (dim_check (dim, 2, 1) == FAILURE)
833 return non_init_transformational ();
840 gfc_check_ctime (gfc_expr *time)
842 if (scalar_check (time, 0) == FAILURE)
845 if (type_check (time, 0, BT_INTEGER) == FAILURE)
853 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
855 if (numeric_check (x, 0) == FAILURE)
860 if (numeric_check (y, 1) == FAILURE)
863 if (x->ts.type == BT_COMPLEX)
865 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
866 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
867 gfc_current_intrinsic, &y->where);
877 gfc_check_dble (gfc_expr *x)
879 if (numeric_check (x, 0) == FAILURE)
887 gfc_check_digits (gfc_expr *x)
889 if (int_or_real_check (x, 0) == FAILURE)
897 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
899 switch (vector_a->ts.type)
902 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
909 if (numeric_check (vector_b, 1) == FAILURE)
914 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
915 "or LOGICAL", gfc_current_intrinsic_arg[0],
916 gfc_current_intrinsic, &vector_a->where);
920 if (rank_check (vector_a, 0, 1) == FAILURE)
923 if (rank_check (vector_b, 1, 1) == FAILURE)
926 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
928 gfc_error ("different shape for arguments '%s' and '%s' at %L for "
929 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
930 gfc_current_intrinsic_arg[1], &vector_a->where);
935 return non_init_transformational ();
942 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
945 if (array_check (array, 0) == FAILURE)
948 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
951 if (array->rank == 1)
953 if (scalar_check (shift, 2) == FAILURE)
958 /* TODO: more weird restrictions on shift. */
961 if (boundary != NULL)
963 if (same_type_check (array, 0, boundary, 2) == FAILURE)
966 /* TODO: more restrictions on boundary. */
969 if (dim_check (dim, 1, 1) == FAILURE)
973 return non_init_transformational ();
979 /* A single complex argument. */
982 gfc_check_fn_c (gfc_expr *a)
984 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
991 /* A single real argument. */
994 gfc_check_fn_r (gfc_expr *a)
996 if (type_check (a, 0, BT_REAL) == FAILURE)
1003 /* A single real or complex argument. */
1006 gfc_check_fn_rc (gfc_expr *a)
1008 if (real_or_complex_check (a, 0) == FAILURE)
1016 gfc_check_fnum (gfc_expr *unit)
1018 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1021 if (scalar_check (unit, 0) == FAILURE)
1028 /* This is used for the g77 one-argument Bessel functions, and the
1032 gfc_check_g77_math1 (gfc_expr *x)
1034 if (scalar_check (x, 0) == FAILURE)
1037 if (type_check (x, 0, BT_REAL) == FAILURE)
1045 gfc_check_huge (gfc_expr *x)
1047 if (int_or_real_check (x, 0) == FAILURE)
1054 /* Check that the single argument is an integer. */
1057 gfc_check_i (gfc_expr *i)
1059 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1067 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1069 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1072 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1075 if (i->ts.kind != j->ts.kind)
1077 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1078 &i->where) == FAILURE)
1087 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1089 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1092 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1100 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1102 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1105 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1108 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1116 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1118 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1121 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1129 gfc_check_ichar_iachar (gfc_expr *c)
1133 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1136 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1142 /* Substring references don't have the charlength set. */
1144 while (ref && ref->type != REF_SUBSTRING)
1147 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1151 /* Check that the argument is length one. Non-constant lengths
1152 can't be checked here, so assume they are ok. */
1153 if (c->ts.cl && c->ts.cl->length)
1155 /* If we already have a length for this expression then use it. */
1156 if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1158 i = mpz_get_si (c->ts.cl->length->value.integer);
1165 start = ref->u.ss.start;
1166 end = ref->u.ss.end;
1169 if (end == NULL || end->expr_type != EXPR_CONSTANT
1170 || start->expr_type != EXPR_CONSTANT)
1173 i = mpz_get_si (end->value.integer) + 1
1174 - mpz_get_si (start->value.integer);
1182 gfc_error ("Argument of %s at %L must be of length one",
1183 gfc_current_intrinsic, &c->where);
1192 gfc_check_idnint (gfc_expr *a)
1194 if (double_check (a, 0) == FAILURE)
1202 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1204 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1207 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1210 if (i->ts.kind != j->ts.kind)
1212 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1213 &i->where) == FAILURE)
1222 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
1224 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1225 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1229 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1232 if (string->ts.kind != substring->ts.kind)
1234 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1235 "kind as '%s'", gfc_current_intrinsic_arg[1],
1236 gfc_current_intrinsic, &substring->where,
1237 gfc_current_intrinsic_arg[0]);
1246 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1248 if (numeric_check (x, 0) == FAILURE)
1253 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1256 if (scalar_check (kind, 1) == FAILURE)
1265 gfc_check_intconv (gfc_expr *x)
1267 if (numeric_check (x, 0) == FAILURE)
1275 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1277 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1280 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1283 if (i->ts.kind != j->ts.kind)
1285 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1286 &i->where) == FAILURE)
1295 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1297 if (type_check (i, 0, BT_INTEGER) == FAILURE
1298 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1306 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1308 if (type_check (i, 0, BT_INTEGER) == FAILURE
1309 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1312 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1320 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1322 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1325 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1333 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1335 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1338 if (scalar_check (pid, 0) == FAILURE)
1341 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1344 if (scalar_check (sig, 1) == FAILURE)
1350 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1353 if (scalar_check (status, 2) == FAILURE)
1361 gfc_check_kind (gfc_expr *x)
1363 if (x->ts.type == BT_DERIVED)
1365 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1366 "non-derived type", gfc_current_intrinsic_arg[0],
1367 gfc_current_intrinsic, &x->where);
1376 gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
1378 if (array_check (array, 0) == FAILURE)
1383 if (dim_check (dim, 1, 1) == FAILURE)
1386 if (dim_rank_check (dim, array, 1) == FAILURE)
1394 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1396 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1399 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1407 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1409 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1412 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1418 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1421 if (scalar_check (status, 2) == FAILURE)
1429 gfc_check_loc (gfc_expr *expr)
1431 return variable_check (expr, 0);
1436 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1438 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1441 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1449 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1451 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1454 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1460 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1463 if (scalar_check (status, 2) == FAILURE)
1471 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1473 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1475 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1482 /* Min/max family. */
1485 min_max_args (gfc_actual_arglist *arg)
1487 if (arg == NULL || arg->next == NULL)
1489 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1490 gfc_current_intrinsic, gfc_current_intrinsic_where);
1499 check_rest (bt type, int kind, gfc_actual_arglist *arg)
1504 if (min_max_args (arg) == FAILURE)
1509 for (; arg; arg = arg->next, n++)
1512 if (x->ts.type != type || x->ts.kind != kind)
1514 if (x->ts.type == type)
1516 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1517 "kinds at %L", &x->where) == FAILURE)
1522 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1523 "%s(%d)", n, gfc_current_intrinsic, &x->where,
1524 gfc_basic_typename (type), kind);
1535 gfc_check_min_max (gfc_actual_arglist *arg)
1539 if (min_max_args (arg) == FAILURE)
1544 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1546 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
1547 "or REAL", gfc_current_intrinsic, &x->where);
1551 return check_rest (x->ts.type, x->ts.kind, arg);
1556 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1558 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1563 gfc_check_min_max_real (gfc_actual_arglist *arg)
1565 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1570 gfc_check_min_max_double (gfc_actual_arglist *arg)
1572 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1576 /* End of min/max family. */
1579 gfc_check_malloc (gfc_expr *size)
1581 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1584 if (scalar_check (size, 0) == FAILURE)
1592 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1594 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1596 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1597 "or LOGICAL", gfc_current_intrinsic_arg[0],
1598 gfc_current_intrinsic, &matrix_a->where);
1602 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1604 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1605 "or LOGICAL", gfc_current_intrinsic_arg[1],
1606 gfc_current_intrinsic, &matrix_b->where);
1610 switch (matrix_a->rank)
1613 if (rank_check (matrix_b, 1, 2) == FAILURE)
1615 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1616 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1618 gfc_error ("different shape on dimension 1 for arguments '%s' "
1619 "and '%s' at %L for intrinsic matmul",
1620 gfc_current_intrinsic_arg[0],
1621 gfc_current_intrinsic_arg[1], &matrix_a->where);
1627 if (matrix_b->rank != 2)
1629 if (rank_check (matrix_b, 1, 1) == FAILURE)
1632 /* matrix_b has rank 1 or 2 here. Common check for the cases
1633 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1634 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1635 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1637 gfc_error ("different shape on dimension 2 for argument '%s' and "
1638 "dimension 1 for argument '%s' at %L for intrinsic "
1639 "matmul", gfc_current_intrinsic_arg[0],
1640 gfc_current_intrinsic_arg[1], &matrix_a->where);
1646 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1647 "1 or 2", gfc_current_intrinsic_arg[0],
1648 gfc_current_intrinsic, &matrix_a->where);
1653 return non_init_transformational ();
1659 /* Whoever came up with this interface was probably on something.
1660 The possibilities for the occupation of the second and third
1667 NULL MASK minloc(array, mask=m)
1670 I.e. in the case of minloc(array,mask), mask will be in the second
1671 position of the argument list and we'll have to fix that up. */
1674 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1676 gfc_expr *a, *m, *d;
1679 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1683 m = ap->next->next->expr;
1685 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1686 && ap->next->name == NULL)
1690 ap->next->expr = NULL;
1691 ap->next->next->expr = m;
1694 if (dim_check (d, 1, 1) == FAILURE)
1697 if (d && dim_rank_check (d, a, 0) == FAILURE)
1700 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1706 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1707 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1708 gfc_current_intrinsic);
1709 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1714 return non_init_transformational ();
1720 /* Similar to minloc/maxloc, the argument list might need to be
1721 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1722 difference is that MINLOC/MAXLOC take an additional KIND argument.
1723 The possibilities are:
1729 NULL MASK minval(array, mask=m)
1732 I.e. in the case of minval(array,mask), mask will be in the second
1733 position of the argument list and we'll have to fix that up. */
1736 check_reduction (gfc_actual_arglist *ap)
1738 gfc_expr *a, *m, *d;
1742 m = ap->next->next->expr;
1744 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1745 && ap->next->name == NULL)
1749 ap->next->expr = NULL;
1750 ap->next->next->expr = m;
1753 if (dim_check (d, 1, 1) == FAILURE)
1756 if (d && dim_rank_check (d, a, 0) == FAILURE)
1759 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1765 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1766 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1767 gfc_current_intrinsic);
1768 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1777 gfc_check_minval_maxval (gfc_actual_arglist *ap)
1779 if (int_or_real_check (ap->expr, 0) == FAILURE
1780 || array_check (ap->expr, 0) == FAILURE)
1784 return non_init_transformational ();
1786 return check_reduction (ap);
1791 gfc_check_product_sum (gfc_actual_arglist *ap)
1793 if (numeric_check (ap->expr, 0) == FAILURE
1794 || array_check (ap->expr, 0) == FAILURE)
1798 return non_init_transformational ();
1800 return check_reduction (ap);
1805 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
1809 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1812 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1815 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1816 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1817 gfc_current_intrinsic);
1818 if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
1821 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1822 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1823 gfc_current_intrinsic);
1824 if (gfc_check_conformance (buffer, tsource, mask) == 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. */
1967 return non_init_transformational ();
1974 gfc_check_precision (gfc_expr *x)
1976 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1978 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1979 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1980 gfc_current_intrinsic, &x->where);
1989 gfc_check_present (gfc_expr *a)
1993 if (variable_check (a, 0) == FAILURE)
1996 sym = a->symtree->n.sym;
1997 if (!sym->attr.dummy)
1999 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2000 "dummy variable", gfc_current_intrinsic_arg[0],
2001 gfc_current_intrinsic, &a->where);
2005 if (!sym->attr.optional)
2007 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2008 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2009 gfc_current_intrinsic, &a->where);
2013 /* 13.14.82 PRESENT(A)
2015 Argument. A shall be the name of an optional dummy argument that is
2016 accessible in the subprogram in which the PRESENT function reference
2020 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2021 && a->ref->u.ar.type == AR_FULL))
2023 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2024 "subobject of '%s'", gfc_current_intrinsic_arg[0],
2025 gfc_current_intrinsic, &a->where, sym->name);
2034 gfc_check_radix (gfc_expr *x)
2036 if (int_or_real_check (x, 0) == FAILURE)
2044 gfc_check_range (gfc_expr *x)
2046 if (numeric_check (x, 0) == FAILURE)
2053 /* real, float, sngl. */
2055 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2057 if (numeric_check (a, 0) == FAILURE)
2060 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2068 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2070 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2073 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2081 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2083 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2086 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2092 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2095 if (scalar_check (status, 2) == FAILURE)
2103 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2105 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2108 if (scalar_check (x, 0) == FAILURE)
2111 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2114 if (scalar_check (y, 1) == FAILURE)
2122 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2123 gfc_expr *pad, gfc_expr *order)
2129 if (array_check (source, 0) == FAILURE)
2132 if (rank_check (shape, 1, 1) == FAILURE)
2135 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2138 if (gfc_array_size (shape, &size) != SUCCESS)
2140 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2141 "array of constant size", &shape->where);
2145 m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2150 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2151 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2157 if (same_type_check (source, 0, pad, 2) == FAILURE)
2159 if (array_check (pad, 2) == FAILURE)
2163 if (order != NULL && array_check (order, 3) == FAILURE)
2166 if (pad == NULL && shape->expr_type == EXPR_ARRAY
2167 && gfc_is_constant_expr (shape)
2168 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2169 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2171 /* Check the match in size between source and destination. */
2172 if (gfc_array_size (source, &nelems) == SUCCESS)
2177 c = shape->value.constructor;
2178 mpz_init_set_ui (size, 1);
2179 for (; c; c = c->next)
2180 mpz_mul (size, size, c->expr->value.integer);
2182 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2188 gfc_error ("Without padding, there are not enough elements "
2189 "in the intrinsic RESHAPE source at %L to match "
2190 "the shape", &source->where);
2201 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2203 if (type_check (x, 0, BT_REAL) == FAILURE)
2206 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2214 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2216 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2219 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2222 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2225 if (same_type_check (x, 0, y, 1) == FAILURE)
2233 gfc_check_secnds (gfc_expr *r)
2235 if (type_check (r, 0, BT_REAL) == FAILURE)
2238 if (kind_value_check (r, 0, 4) == FAILURE)
2241 if (scalar_check (r, 0) == FAILURE)
2249 gfc_check_selected_int_kind (gfc_expr *r)
2251 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2254 if (scalar_check (r, 0) == FAILURE)
2262 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2264 if (p == NULL && r == NULL)
2266 gfc_error ("Missing arguments to %s intrinsic at %L",
2267 gfc_current_intrinsic, gfc_current_intrinsic_where);
2272 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2275 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2283 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2285 if (type_check (x, 0, BT_REAL) == FAILURE)
2288 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2296 gfc_check_shape (gfc_expr *source)
2300 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2303 ar = gfc_find_array_ref (source);
2305 if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2307 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2308 "an assumed size array", &source->where);
2317 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2319 if (int_or_real_check (a, 0) == FAILURE)
2322 if (same_type_check (a, 0, b, 1) == FAILURE)
2330 gfc_check_size (gfc_expr *array, gfc_expr *dim)
2332 if (array_check (array, 0) == FAILURE)
2337 if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2340 if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2343 if (dim_rank_check (dim, array, 0) == FAILURE)
2352 gfc_check_sleep_sub (gfc_expr *seconds)
2354 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2357 if (scalar_check (seconds, 0) == FAILURE)
2365 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2367 if (source->rank >= GFC_MAX_DIMENSIONS)
2369 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2370 "than rank %d", gfc_current_intrinsic_arg[0],
2371 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2376 if (dim_check (dim, 1, 0) == FAILURE)
2379 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2382 if (scalar_check (ncopies, 2) == FAILURE)
2386 return non_init_transformational ();
2392 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2396 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2398 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2401 if (scalar_check (unit, 0) == FAILURE)
2404 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2410 if (type_check (status, 2, BT_INTEGER) == FAILURE
2411 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2412 || scalar_check (status, 2) == FAILURE)
2420 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2422 return gfc_check_fgetputc_sub (unit, c, NULL);
2427 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2429 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2435 if (type_check (status, 1, BT_INTEGER) == FAILURE
2436 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2437 || scalar_check (status, 1) == FAILURE)
2445 gfc_check_fgetput (gfc_expr *c)
2447 return gfc_check_fgetput_sub (c, NULL);
2452 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2454 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2457 if (scalar_check (unit, 0) == FAILURE)
2460 if (type_check (array, 1, BT_INTEGER) == FAILURE
2461 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2464 if (array_check (array, 1) == FAILURE)
2472 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2474 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2477 if (scalar_check (unit, 0) == FAILURE)
2480 if (type_check (array, 1, BT_INTEGER) == FAILURE
2481 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2484 if (array_check (array, 1) == FAILURE)
2490 if (type_check (status, 2, BT_INTEGER) == FAILURE
2491 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2494 if (scalar_check (status, 2) == FAILURE)
2502 gfc_check_ftell (gfc_expr *unit)
2504 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2507 if (scalar_check (unit, 0) == FAILURE)
2515 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2517 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2520 if (scalar_check (unit, 0) == FAILURE)
2523 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2526 if (scalar_check (offset, 1) == FAILURE)
2534 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2536 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2539 if (type_check (array, 1, BT_INTEGER) == FAILURE
2540 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2543 if (array_check (array, 1) == FAILURE)
2551 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2553 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2556 if (type_check (array, 1, BT_INTEGER) == FAILURE
2557 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2560 if (array_check (array, 1) == FAILURE)
2566 if (type_check (status, 2, BT_INTEGER) == FAILURE
2567 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2570 if (scalar_check (status, 2) == FAILURE)
2578 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2579 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2583 if (type_check (size, 2, BT_INTEGER) == FAILURE)
2586 if (scalar_check (size, 2) == FAILURE)
2589 if (nonoptional_check (size, 2) == FAILURE)
2598 gfc_check_transpose (gfc_expr *matrix)
2600 if (rank_check (matrix, 0, 2) == FAILURE)
2604 return non_init_transformational ();
2611 gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
2613 if (array_check (array, 0) == FAILURE)
2618 if (dim_check (dim, 1, 1) == FAILURE)
2621 if (dim_rank_check (dim, array, 0) == FAILURE)
2630 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2632 if (rank_check (vector, 0, 1) == FAILURE)
2635 if (array_check (mask, 1) == FAILURE)
2638 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2641 if (same_type_check (vector, 0, field, 2) == FAILURE)
2645 return non_init_transformational ();
2652 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2654 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2657 if (same_type_check (x, 0, y, 1) == FAILURE)
2660 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2668 gfc_check_trim (gfc_expr *x)
2670 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2673 if (scalar_check (x, 0) == FAILURE)
2681 gfc_check_ttynam (gfc_expr *unit)
2683 if (scalar_check (unit, 0) == FAILURE)
2686 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2693 /* Common check function for the half a dozen intrinsics that have a
2694 single real argument. */
2697 gfc_check_x (gfc_expr *x)
2699 if (type_check (x, 0, BT_REAL) == FAILURE)
2706 /************* Check functions for intrinsic subroutines *************/
2709 gfc_check_cpu_time (gfc_expr *time)
2711 if (scalar_check (time, 0) == FAILURE)
2714 if (type_check (time, 0, BT_REAL) == FAILURE)
2717 if (variable_check (time, 0) == FAILURE)
2725 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2726 gfc_expr *zone, gfc_expr *values)
2730 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2732 if (scalar_check (date, 0) == FAILURE)
2734 if (variable_check (date, 0) == FAILURE)
2740 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2742 if (scalar_check (time, 1) == FAILURE)
2744 if (variable_check (time, 1) == FAILURE)
2750 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2752 if (scalar_check (zone, 2) == FAILURE)
2754 if (variable_check (zone, 2) == FAILURE)
2760 if (type_check (values, 3, BT_INTEGER) == FAILURE)
2762 if (array_check (values, 3) == FAILURE)
2764 if (rank_check (values, 3, 1) == FAILURE)
2766 if (variable_check (values, 3) == FAILURE)
2775 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2776 gfc_expr *to, gfc_expr *topos)
2778 if (type_check (from, 0, BT_INTEGER) == FAILURE)
2781 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2784 if (type_check (len, 2, BT_INTEGER) == FAILURE)
2787 if (same_type_check (from, 0, to, 3) == FAILURE)
2790 if (variable_check (to, 3) == FAILURE)
2793 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2801 gfc_check_random_number (gfc_expr *harvest)
2803 if (type_check (harvest, 0, BT_REAL) == FAILURE)
2806 if (variable_check (harvest, 0) == FAILURE)
2814 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2818 if (scalar_check (size, 0) == FAILURE)
2821 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2824 if (variable_check (size, 0) == FAILURE)
2827 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2835 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2838 if (array_check (put, 1) == FAILURE)
2841 if (rank_check (put, 1, 1) == FAILURE)
2844 if (type_check (put, 1, BT_INTEGER) == FAILURE)
2847 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2854 if (size != NULL || put != NULL)
2855 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2858 if (array_check (get, 2) == FAILURE)
2861 if (rank_check (get, 2, 1) == FAILURE)
2864 if (type_check (get, 2, BT_INTEGER) == FAILURE)
2867 if (variable_check (get, 2) == FAILURE)
2870 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2879 gfc_check_second_sub (gfc_expr *time)
2881 if (scalar_check (time, 0) == FAILURE)
2884 if (type_check (time, 0, BT_REAL) == FAILURE)
2887 if (kind_value_check(time, 0, 4) == FAILURE)
2894 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2895 count, count_rate, and count_max are all optional arguments */
2898 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
2899 gfc_expr *count_max)
2903 if (scalar_check (count, 0) == FAILURE)
2906 if (type_check (count, 0, BT_INTEGER) == FAILURE)
2909 if (variable_check (count, 0) == FAILURE)
2913 if (count_rate != NULL)
2915 if (scalar_check (count_rate, 1) == FAILURE)
2918 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2921 if (variable_check (count_rate, 1) == FAILURE)
2925 && same_type_check (count, 0, count_rate, 1) == FAILURE)
2930 if (count_max != NULL)
2932 if (scalar_check (count_max, 2) == FAILURE)
2935 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2938 if (variable_check (count_max, 2) == FAILURE)
2942 && same_type_check (count, 0, count_max, 2) == FAILURE)
2945 if (count_rate != NULL
2946 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2955 gfc_check_irand (gfc_expr *x)
2960 if (scalar_check (x, 0) == FAILURE)
2963 if (type_check (x, 0, BT_INTEGER) == FAILURE)
2966 if (kind_value_check(x, 0, 4) == FAILURE)
2974 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
2976 if (scalar_check (seconds, 0) == FAILURE)
2979 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2982 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2984 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
2985 "or PROCEDURE", gfc_current_intrinsic_arg[1],
2986 gfc_current_intrinsic, &handler->where);
2990 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2996 if (scalar_check (status, 2) == FAILURE)
2999 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3002 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3010 gfc_check_rand (gfc_expr *x)
3015 if (scalar_check (x, 0) == FAILURE)
3018 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3021 if (kind_value_check(x, 0, 4) == FAILURE)
3029 gfc_check_srand (gfc_expr *x)
3031 if (scalar_check (x, 0) == FAILURE)
3034 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3037 if (kind_value_check(x, 0, 4) == FAILURE)
3045 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3047 if (scalar_check (time, 0) == FAILURE)
3050 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3053 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3061 gfc_check_etime (gfc_expr *x)
3063 if (array_check (x, 0) == FAILURE)
3066 if (rank_check (x, 0, 1) == FAILURE)
3069 if (variable_check (x, 0) == FAILURE)
3072 if (type_check (x, 0, BT_REAL) == FAILURE)
3075 if (kind_value_check(x, 0, 4) == FAILURE)
3083 gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
3085 if (array_check (values, 0) == FAILURE)
3088 if (rank_check (values, 0, 1) == FAILURE)
3091 if (variable_check (values, 0) == FAILURE)
3094 if (type_check (values, 0, BT_REAL) == FAILURE)
3097 if (kind_value_check(values, 0, 4) == FAILURE)
3100 if (scalar_check (time, 1) == FAILURE)
3103 if (type_check (time, 1, BT_REAL) == FAILURE)
3106 if (kind_value_check(time, 1, 4) == FAILURE)
3114 gfc_check_fdate_sub (gfc_expr *date)
3116 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3124 gfc_check_gerror (gfc_expr *msg)
3126 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3134 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3136 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3142 if (scalar_check (status, 1) == FAILURE)
3145 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3153 gfc_check_getlog (gfc_expr *msg)
3155 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3163 gfc_check_exit (gfc_expr *status)
3168 if (type_check (status, 0, BT_INTEGER) == FAILURE)
3171 if (scalar_check (status, 0) == FAILURE)
3179 gfc_check_flush (gfc_expr *unit)
3184 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3187 if (scalar_check (unit, 0) == FAILURE)
3195 gfc_check_free (gfc_expr *i)
3197 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3200 if (scalar_check (i, 0) == FAILURE)
3208 gfc_check_hostnm (gfc_expr *name)
3210 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3218 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3220 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3226 if (scalar_check (status, 1) == FAILURE)
3229 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3237 gfc_check_itime_idate (gfc_expr *values)
3239 if (array_check (values, 0) == FAILURE)
3242 if (rank_check (values, 0, 1) == FAILURE)
3245 if (variable_check (values, 0) == FAILURE)
3248 if (type_check (values, 0, BT_INTEGER) == FAILURE)
3251 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3259 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3261 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3264 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3267 if (scalar_check (time, 0) == FAILURE)
3270 if (array_check (values, 1) == FAILURE)
3273 if (rank_check (values, 1, 1) == FAILURE)
3276 if (variable_check (values, 1) == FAILURE)
3279 if (type_check (values, 1, BT_INTEGER) == FAILURE)
3282 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3290 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3292 if (scalar_check (unit, 0) == FAILURE)
3295 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3298 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3306 gfc_check_isatty (gfc_expr *unit)
3311 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3314 if (scalar_check (unit, 0) == FAILURE)
3322 gfc_check_perror (gfc_expr *string)
3324 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3332 gfc_check_umask (gfc_expr *mask)
3334 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3337 if (scalar_check (mask, 0) == FAILURE)
3345 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3347 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3350 if (scalar_check (mask, 0) == FAILURE)
3356 if (scalar_check (old, 1) == FAILURE)
3359 if (type_check (old, 1, BT_INTEGER) == FAILURE)
3367 gfc_check_unlink (gfc_expr *name)
3369 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3377 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3379 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3385 if (scalar_check (status, 1) == FAILURE)
3388 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3396 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3398 if (scalar_check (number, 0) == FAILURE)
3401 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3404 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3406 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3407 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3408 gfc_current_intrinsic, &handler->where);
3412 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3420 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3422 if (scalar_check (number, 0) == FAILURE)
3425 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3428 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3430 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3431 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3432 gfc_current_intrinsic, &handler->where);
3436 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3442 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3445 if (scalar_check (status, 2) == FAILURE)
3453 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3455 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3458 if (scalar_check (status, 1) == FAILURE)
3461 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3464 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3471 /* This is used for the GNU intrinsics AND, OR and XOR. */
3473 gfc_check_and (gfc_expr *i, gfc_expr *j)
3475 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3477 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3478 "or LOGICAL", gfc_current_intrinsic_arg[0],
3479 gfc_current_intrinsic, &i->where);
3483 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3485 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3486 "or LOGICAL", gfc_current_intrinsic_arg[1],
3487 gfc_current_intrinsic, &j->where);
3491 if (i->ts.type != j->ts.type)
3493 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3494 "have the same type", gfc_current_intrinsic_arg[0],
3495 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3500 if (scalar_check (i, 0) == FAILURE)
3503 if (scalar_check (j, 1) == FAILURE)