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 /* If the expression has not got a type, check if its namespace can
62 offer a default type. */
63 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
64 && e->symtree->n.sym->ts.type == BT_UNKNOWN
65 && gfc_set_default_type (e->symtree->n.sym, 0,
66 e->symtree->n.sym->ns) == SUCCESS
67 && gfc_numeric_ts (&e->symtree->n.sym->ts))
69 e->ts = e->symtree->n.sym->ts;
73 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
74 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
80 /* Check that an expression is integer or real. */
83 int_or_real_check (gfc_expr *e, int n)
85 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
87 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
88 "or REAL", gfc_current_intrinsic_arg[n],
89 gfc_current_intrinsic, &e->where);
97 /* Check that an expression is real or complex. */
100 real_or_complex_check (gfc_expr *e, int n)
102 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
105 "or COMPLEX", gfc_current_intrinsic_arg[n],
106 gfc_current_intrinsic, &e->where);
114 /* Check that the expression is an optional constant integer
115 and that it specifies a valid kind for that type. */
118 kind_check (gfc_expr *k, int n, bt type)
125 if (type_check (k, n, BT_INTEGER) == FAILURE)
128 if (k->expr_type != EXPR_CONSTANT)
130 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
131 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
136 if (gfc_extract_int (k, &kind) != NULL
137 || gfc_validate_kind (type, kind, true) < 0)
139 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
148 /* Make sure the expression is a double precision real. */
151 double_check (gfc_expr *d, int n)
153 if (type_check (d, n, BT_REAL) == FAILURE)
156 if (d->ts.kind != gfc_default_double_kind)
158 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
159 "precision", gfc_current_intrinsic_arg[n],
160 gfc_current_intrinsic, &d->where);
168 /* Make sure the expression is a logical array. */
171 logical_array_check (gfc_expr *array, int n)
173 if (array->ts.type != BT_LOGICAL || array->rank == 0)
175 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
176 "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
185 /* Make sure an expression is an array. */
188 array_check (gfc_expr *e, int n)
193 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
194 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
200 /* Make sure an expression is a scalar. */
203 scalar_check (gfc_expr *e, int n)
208 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
209 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
215 /* Make sure two expressions have the same type. */
218 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
220 if (gfc_compare_types (&e->ts, &f->ts))
223 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
224 "and kind as '%s'", gfc_current_intrinsic_arg[m],
225 gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
231 /* Make sure that an expression has a certain (nonzero) rank. */
234 rank_check (gfc_expr *e, int n, int rank)
239 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
240 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
247 /* Make sure a variable expression is not an optional dummy argument. */
250 nonoptional_check (gfc_expr *e, int n)
252 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
254 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
255 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
259 /* TODO: Recursive check on nonoptional variables? */
265 /* Check that an expression has a particular kind. */
268 kind_value_check (gfc_expr *e, int n, int k)
273 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
274 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
281 /* Make sure an expression is a variable. */
284 variable_check (gfc_expr *e, int n)
286 if ((e->expr_type == EXPR_VARIABLE
287 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
288 || (e->expr_type == EXPR_FUNCTION
289 && e->symtree->n.sym->result == e->symtree->n.sym))
292 if (e->expr_type == EXPR_VARIABLE
293 && e->symtree->n.sym->attr.intent == INTENT_IN)
295 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
296 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
301 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
302 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
308 /* Check the common DIM parameter for correctness. */
311 dim_check (gfc_expr *dim, int n, int optional)
313 if (optional && dim == NULL)
318 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
319 gfc_current_intrinsic, gfc_current_intrinsic_where);
323 if (type_check (dim, n, BT_INTEGER) == FAILURE)
326 if (scalar_check (dim, n) == FAILURE)
329 if (nonoptional_check (dim, n) == FAILURE)
336 /* If a DIM parameter is a constant, make sure that it is greater than
337 zero and less than or equal to the rank of the given array. If
338 allow_assumed is zero then dim must be less than the rank of the array
339 for assumed size arrays. */
342 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
347 if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
350 ar = gfc_find_array_ref (array);
352 if (ar->as->type == AS_ASSUMED_SIZE
354 && ar->type != AR_ELEMENT
355 && ar->type != AR_SECTION)
358 if (mpz_cmp_ui (dim->value.integer, 1) < 0
359 || mpz_cmp_ui (dim->value.integer, rank) > 0)
361 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
362 "dimension index", gfc_current_intrinsic, &dim->where);
371 /* Compare the size of a along dimension ai with the size of b along
372 dimension bi, returning 0 if they are known not to be identical,
373 and 1 if they are identical, or if this cannot be determined. */
376 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
378 mpz_t a_size, b_size;
381 gcc_assert (a->rank > ai);
382 gcc_assert (b->rank > bi);
386 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
388 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
390 if (mpz_cmp (a_size, b_size) != 0)
401 /* Error return for transformational intrinsics not allowed in
402 initialization expressions. */
405 non_init_transformational (void)
407 gfc_error ("transformational intrinsic '%s' at %L is not permitted "
408 "in an initialization expression", gfc_current_intrinsic,
409 gfc_current_intrinsic_where);
413 /***** Check functions *****/
415 /* Check subroutine suitable for intrinsics taking a real argument and
416 a kind argument for the result. */
419 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
421 if (type_check (a, 0, BT_REAL) == FAILURE)
423 if (kind_check (kind, 1, type) == FAILURE)
430 /* Check subroutine suitable for ceiling, floor and nint. */
433 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
435 return check_a_kind (a, kind, BT_INTEGER);
439 /* Check subroutine suitable for aint, anint. */
442 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
444 return check_a_kind (a, kind, BT_REAL);
449 gfc_check_abs (gfc_expr *a)
451 if (numeric_check (a, 0) == FAILURE)
459 gfc_check_achar (gfc_expr *a)
461 if (type_check (a, 0, BT_INTEGER) == FAILURE)
469 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
471 if (type_check (name, 0, BT_CHARACTER) == FAILURE
472 || scalar_check (name, 0) == FAILURE)
475 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
476 || scalar_check (mode, 1) == FAILURE)
484 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
486 if (logical_array_check (mask, 0) == FAILURE)
489 if (dim_check (dim, 1, 1) == FAILURE)
493 return non_init_transformational ();
500 gfc_check_allocated (gfc_expr *array)
502 symbol_attribute attr;
504 if (variable_check (array, 0) == FAILURE)
507 if (array_check (array, 0) == FAILURE)
510 attr = gfc_variable_attr (array, NULL);
511 if (!attr.allocatable)
513 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
514 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
523 /* Common check function where the first argument must be real or
524 integer and the second argument must be the same as the first. */
527 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
529 if (int_or_real_check (a, 0) == FAILURE)
532 if (a->ts.type != p->ts.type)
534 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
535 "have the same type", gfc_current_intrinsic_arg[0],
536 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
541 if (a->ts.kind != p->ts.kind)
543 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
544 &p->where) == FAILURE)
553 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
555 symbol_attribute attr;
560 where = &pointer->where;
562 if (pointer->expr_type == EXPR_VARIABLE)
563 attr = gfc_variable_attr (pointer, NULL);
564 else if (pointer->expr_type == EXPR_FUNCTION)
565 attr = pointer->symtree->n.sym->attr;
566 else if (pointer->expr_type == EXPR_NULL)
569 gcc_assert (0); /* Pointer must be a variable or a function. */
573 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
574 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
579 /* Target argument is optional. */
583 where = &target->where;
584 if (target->expr_type == EXPR_NULL)
587 if (target->expr_type == EXPR_VARIABLE)
588 attr = gfc_variable_attr (target, NULL);
589 else if (target->expr_type == EXPR_FUNCTION)
590 attr = target->symtree->n.sym->attr;
593 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
594 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
595 gfc_current_intrinsic, &target->where);
599 if (!attr.pointer && !attr.target)
601 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
602 "or a TARGET", gfc_current_intrinsic_arg[1],
603 gfc_current_intrinsic, &target->where);
608 if (same_type_check (pointer, 0, target, 1) == FAILURE)
610 if (rank_check (target, 0, pointer->rank) == FAILURE)
612 if (target->rank > 0)
614 for (i = 0; i < target->rank; i++)
615 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
617 gfc_error ("Array section with a vector subscript at %L shall not "
618 "be the target of a pointer",
628 gfc_error ("NULL pointer at %L is not permitted as actual argument "
629 "of '%s' intrinsic function", where, gfc_current_intrinsic);
636 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
638 if (type_check (y, 0, BT_REAL) == FAILURE)
640 if (same_type_check (y, 0, x, 1) == FAILURE)
647 /* BESJN and BESYN functions. */
650 gfc_check_besn (gfc_expr *n, gfc_expr *x)
652 if (type_check (n, 0, BT_INTEGER) == FAILURE)
655 if (type_check (x, 1, BT_REAL) == FAILURE)
663 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
665 if (type_check (i, 0, BT_INTEGER) == FAILURE)
667 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
675 gfc_check_char (gfc_expr *i, gfc_expr *kind)
677 if (type_check (i, 0, BT_INTEGER) == FAILURE)
679 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
687 gfc_check_chdir (gfc_expr *dir)
689 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
697 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
699 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
705 if (type_check (status, 1, BT_INTEGER) == FAILURE)
708 if (scalar_check (status, 1) == FAILURE)
716 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
718 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
721 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
729 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
731 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
734 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
740 if (type_check (status, 2, BT_INTEGER) == FAILURE)
743 if (scalar_check (status, 2) == FAILURE)
751 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
753 if (numeric_check (x, 0) == FAILURE)
758 if (numeric_check (y, 1) == FAILURE)
761 if (x->ts.type == BT_COMPLEX)
763 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
764 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
765 gfc_current_intrinsic, &y->where);
770 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
778 gfc_check_complex (gfc_expr *x, gfc_expr *y)
780 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
782 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
783 "or REAL", gfc_current_intrinsic_arg[0],
784 gfc_current_intrinsic, &x->where);
787 if (scalar_check (x, 0) == FAILURE)
790 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
792 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
793 "or REAL", gfc_current_intrinsic_arg[1],
794 gfc_current_intrinsic, &y->where);
797 if (scalar_check (y, 1) == FAILURE)
805 gfc_check_count (gfc_expr *mask, gfc_expr *dim)
807 if (logical_array_check (mask, 0) == FAILURE)
809 if (dim_check (dim, 1, 1) == FAILURE)
813 return non_init_transformational ();
820 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
822 if (array_check (array, 0) == FAILURE)
825 if (array->rank == 1)
827 if (scalar_check (shift, 1) == FAILURE)
832 /* TODO: more requirements on shift parameter. */
835 if (dim_check (dim, 2, 1) == FAILURE)
839 return non_init_transformational ();
846 gfc_check_ctime (gfc_expr *time)
848 if (scalar_check (time, 0) == FAILURE)
851 if (type_check (time, 0, BT_INTEGER) == FAILURE)
859 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
861 if (numeric_check (x, 0) == FAILURE)
866 if (numeric_check (y, 1) == FAILURE)
869 if (x->ts.type == BT_COMPLEX)
871 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
872 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
873 gfc_current_intrinsic, &y->where);
883 gfc_check_dble (gfc_expr *x)
885 if (numeric_check (x, 0) == FAILURE)
893 gfc_check_digits (gfc_expr *x)
895 if (int_or_real_check (x, 0) == FAILURE)
903 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
905 switch (vector_a->ts.type)
908 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
915 if (numeric_check (vector_b, 1) == FAILURE)
920 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
921 "or LOGICAL", gfc_current_intrinsic_arg[0],
922 gfc_current_intrinsic, &vector_a->where);
926 if (rank_check (vector_a, 0, 1) == FAILURE)
929 if (rank_check (vector_b, 1, 1) == FAILURE)
932 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
934 gfc_error ("different shape for arguments '%s' and '%s' at %L for "
935 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
936 gfc_current_intrinsic_arg[1], &vector_a->where);
941 return non_init_transformational ();
948 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
951 if (array_check (array, 0) == FAILURE)
954 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
957 if (array->rank == 1)
959 if (scalar_check (shift, 2) == FAILURE)
964 /* TODO: more weird restrictions on shift. */
967 if (boundary != NULL)
969 if (same_type_check (array, 0, boundary, 2) == FAILURE)
972 /* TODO: more restrictions on boundary. */
975 if (dim_check (dim, 1, 1) == FAILURE)
979 return non_init_transformational ();
985 /* A single complex argument. */
988 gfc_check_fn_c (gfc_expr *a)
990 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
997 /* A single real argument. */
1000 gfc_check_fn_r (gfc_expr *a)
1002 if (type_check (a, 0, BT_REAL) == FAILURE)
1009 /* A single real or complex argument. */
1012 gfc_check_fn_rc (gfc_expr *a)
1014 if (real_or_complex_check (a, 0) == FAILURE)
1022 gfc_check_fnum (gfc_expr *unit)
1024 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1027 if (scalar_check (unit, 0) == FAILURE)
1035 gfc_check_huge (gfc_expr *x)
1037 if (int_or_real_check (x, 0) == FAILURE)
1044 /* Check that the single argument is an integer. */
1047 gfc_check_i (gfc_expr *i)
1049 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1057 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1059 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1062 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1065 if (i->ts.kind != j->ts.kind)
1067 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1068 &i->where) == FAILURE)
1077 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1079 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1082 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1090 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1092 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1095 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1098 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1106 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1108 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1111 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1119 gfc_check_ichar_iachar (gfc_expr *c)
1123 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1126 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1132 /* Substring references don't have the charlength set. */
1134 while (ref && ref->type != REF_SUBSTRING)
1137 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1141 /* Check that the argument is length one. Non-constant lengths
1142 can't be checked here, so assume they are ok. */
1143 if (c->ts.cl && c->ts.cl->length)
1145 /* If we already have a length for this expression then use it. */
1146 if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1148 i = mpz_get_si (c->ts.cl->length->value.integer);
1155 start = ref->u.ss.start;
1156 end = ref->u.ss.end;
1159 if (end == NULL || end->expr_type != EXPR_CONSTANT
1160 || start->expr_type != EXPR_CONSTANT)
1163 i = mpz_get_si (end->value.integer) + 1
1164 - mpz_get_si (start->value.integer);
1172 gfc_error ("Argument of %s at %L must be of length one",
1173 gfc_current_intrinsic, &c->where);
1182 gfc_check_idnint (gfc_expr *a)
1184 if (double_check (a, 0) == FAILURE)
1192 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1194 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1197 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1200 if (i->ts.kind != j->ts.kind)
1202 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1203 &i->where) == FAILURE)
1212 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
1214 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1215 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1219 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1222 if (string->ts.kind != substring->ts.kind)
1224 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1225 "kind as '%s'", gfc_current_intrinsic_arg[1],
1226 gfc_current_intrinsic, &substring->where,
1227 gfc_current_intrinsic_arg[0]);
1236 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1238 if (numeric_check (x, 0) == FAILURE)
1243 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1246 if (scalar_check (kind, 1) == FAILURE)
1255 gfc_check_intconv (gfc_expr *x)
1257 if (numeric_check (x, 0) == FAILURE)
1265 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1267 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1270 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1273 if (i->ts.kind != j->ts.kind)
1275 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1276 &i->where) == FAILURE)
1285 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1287 if (type_check (i, 0, BT_INTEGER) == FAILURE
1288 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1296 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1298 if (type_check (i, 0, BT_INTEGER) == FAILURE
1299 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1302 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1310 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1312 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1315 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1323 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1325 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1328 if (scalar_check (pid, 0) == FAILURE)
1331 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1334 if (scalar_check (sig, 1) == FAILURE)
1340 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1343 if (scalar_check (status, 2) == FAILURE)
1351 gfc_check_kind (gfc_expr *x)
1353 if (x->ts.type == BT_DERIVED)
1355 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1356 "non-derived type", gfc_current_intrinsic_arg[0],
1357 gfc_current_intrinsic, &x->where);
1366 gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
1368 if (array_check (array, 0) == FAILURE)
1373 if (dim_check (dim, 1, 1) == FAILURE)
1376 if (dim_rank_check (dim, array, 1) == FAILURE)
1384 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1386 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1389 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1397 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1399 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1402 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1408 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1411 if (scalar_check (status, 2) == FAILURE)
1419 gfc_check_loc (gfc_expr *expr)
1421 return variable_check (expr, 0);
1426 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1428 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1431 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1439 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1441 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1444 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1450 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1453 if (scalar_check (status, 2) == FAILURE)
1461 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1463 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1465 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1472 /* Min/max family. */
1475 min_max_args (gfc_actual_arglist *arg)
1477 if (arg == NULL || arg->next == NULL)
1479 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1480 gfc_current_intrinsic, gfc_current_intrinsic_where);
1489 check_rest (bt type, int kind, gfc_actual_arglist *arg)
1491 gfc_expr *x, *first_arg;
1495 if (min_max_args (arg) == FAILURE)
1500 first_arg = arg->expr;
1501 for (; arg; arg = arg->next, n++)
1504 if (x->ts.type != type || x->ts.kind != kind)
1506 if (x->ts.type == type)
1508 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1509 "kinds at %L", &x->where) == FAILURE)
1514 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1515 "%s(%d)", n, gfc_current_intrinsic, &x->where,
1516 gfc_basic_typename (type), kind);
1521 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1522 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n-1],
1523 gfc_current_intrinsic);
1524 if (gfc_check_conformance (buffer, first_arg, x) == FAILURE)
1533 gfc_check_min_max (gfc_actual_arglist *arg)
1537 if (min_max_args (arg) == FAILURE)
1542 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1544 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
1545 "or REAL", gfc_current_intrinsic, &x->where);
1549 return check_rest (x->ts.type, x->ts.kind, arg);
1554 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1556 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1561 gfc_check_min_max_real (gfc_actual_arglist *arg)
1563 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1568 gfc_check_min_max_double (gfc_actual_arglist *arg)
1570 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1574 /* End of min/max family. */
1577 gfc_check_malloc (gfc_expr *size)
1579 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1582 if (scalar_check (size, 0) == FAILURE)
1590 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1592 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1594 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1595 "or LOGICAL", gfc_current_intrinsic_arg[0],
1596 gfc_current_intrinsic, &matrix_a->where);
1600 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1602 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1603 "or LOGICAL", gfc_current_intrinsic_arg[1],
1604 gfc_current_intrinsic, &matrix_b->where);
1608 switch (matrix_a->rank)
1611 if (rank_check (matrix_b, 1, 2) == FAILURE)
1613 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1614 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1616 gfc_error ("different shape on dimension 1 for arguments '%s' "
1617 "and '%s' at %L for intrinsic matmul",
1618 gfc_current_intrinsic_arg[0],
1619 gfc_current_intrinsic_arg[1], &matrix_a->where);
1625 if (matrix_b->rank != 2)
1627 if (rank_check (matrix_b, 1, 1) == FAILURE)
1630 /* matrix_b has rank 1 or 2 here. Common check for the cases
1631 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1632 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1633 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1635 gfc_error ("different shape on dimension 2 for argument '%s' and "
1636 "dimension 1 for argument '%s' at %L for intrinsic "
1637 "matmul", gfc_current_intrinsic_arg[0],
1638 gfc_current_intrinsic_arg[1], &matrix_a->where);
1644 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1645 "1 or 2", gfc_current_intrinsic_arg[0],
1646 gfc_current_intrinsic, &matrix_a->where);
1651 return non_init_transformational ();
1657 /* Whoever came up with this interface was probably on something.
1658 The possibilities for the occupation of the second and third
1665 NULL MASK minloc(array, mask=m)
1668 I.e. in the case of minloc(array,mask), mask will be in the second
1669 position of the argument list and we'll have to fix that up. */
1672 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1674 gfc_expr *a, *m, *d;
1677 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1681 m = ap->next->next->expr;
1683 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1684 && ap->next->name == NULL)
1688 ap->next->expr = NULL;
1689 ap->next->next->expr = m;
1692 if (dim_check (d, 1, 1) == FAILURE)
1695 if (d && dim_rank_check (d, a, 0) == FAILURE)
1698 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1704 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1705 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1706 gfc_current_intrinsic);
1707 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1712 return non_init_transformational ();
1718 /* Similar to minloc/maxloc, the argument list might need to be
1719 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1720 difference is that MINLOC/MAXLOC take an additional KIND argument.
1721 The possibilities are:
1727 NULL MASK minval(array, mask=m)
1730 I.e. in the case of minval(array,mask), mask will be in the second
1731 position of the argument list and we'll have to fix that up. */
1734 check_reduction (gfc_actual_arglist *ap)
1736 gfc_expr *a, *m, *d;
1740 m = ap->next->next->expr;
1742 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1743 && ap->next->name == NULL)
1747 ap->next->expr = NULL;
1748 ap->next->next->expr = m;
1751 if (dim_check (d, 1, 1) == FAILURE)
1754 if (d && dim_rank_check (d, a, 0) == FAILURE)
1757 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1763 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1764 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1765 gfc_current_intrinsic);
1766 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1775 gfc_check_minval_maxval (gfc_actual_arglist *ap)
1777 if (int_or_real_check (ap->expr, 0) == FAILURE
1778 || array_check (ap->expr, 0) == FAILURE)
1782 return non_init_transformational ();
1784 return check_reduction (ap);
1789 gfc_check_product_sum (gfc_actual_arglist *ap)
1791 if (numeric_check (ap->expr, 0) == FAILURE
1792 || array_check (ap->expr, 0) == FAILURE)
1796 return non_init_transformational ();
1798 return check_reduction (ap);
1803 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
1805 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1808 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1815 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
1817 symbol_attribute attr;
1819 if (variable_check (from, 0) == FAILURE)
1822 if (array_check (from, 0) == FAILURE)
1825 attr = gfc_variable_attr (from, NULL);
1826 if (!attr.allocatable)
1828 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1829 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1834 if (variable_check (to, 0) == FAILURE)
1837 if (array_check (to, 0) == FAILURE)
1840 attr = gfc_variable_attr (to, NULL);
1841 if (!attr.allocatable)
1843 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1844 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1849 if (same_type_check (from, 0, to, 1) == FAILURE)
1852 if (to->rank != from->rank)
1854 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1855 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1856 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1857 &to->where, from->rank, to->rank);
1861 if (to->ts.kind != from->ts.kind)
1863 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1864 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1865 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1866 &to->where, from->ts.kind, to->ts.kind);
1875 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
1877 if (type_check (x, 0, BT_REAL) == FAILURE)
1880 if (type_check (s, 1, BT_REAL) == FAILURE)
1888 gfc_check_new_line (gfc_expr *a)
1890 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1898 gfc_check_null (gfc_expr *mold)
1900 symbol_attribute attr;
1905 if (variable_check (mold, 0) == FAILURE)
1908 attr = gfc_variable_attr (mold, NULL);
1912 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1913 gfc_current_intrinsic_arg[0],
1914 gfc_current_intrinsic, &mold->where);
1923 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
1927 if (array_check (array, 0) == FAILURE)
1930 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1933 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1934 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1935 gfc_current_intrinsic);
1936 if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1941 if (same_type_check (array, 0, vector, 2) == FAILURE)
1944 if (rank_check (vector, 2, 1) == FAILURE)
1947 /* TODO: More constraints here. */
1951 return non_init_transformational ();
1958 gfc_check_precision (gfc_expr *x)
1960 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1962 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1963 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1964 gfc_current_intrinsic, &x->where);
1973 gfc_check_present (gfc_expr *a)
1977 if (variable_check (a, 0) == FAILURE)
1980 sym = a->symtree->n.sym;
1981 if (!sym->attr.dummy)
1983 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1984 "dummy variable", gfc_current_intrinsic_arg[0],
1985 gfc_current_intrinsic, &a->where);
1989 if (!sym->attr.optional)
1991 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1992 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1993 gfc_current_intrinsic, &a->where);
1997 /* 13.14.82 PRESENT(A)
1999 Argument. A shall be the name of an optional dummy argument that is
2000 accessible in the subprogram in which the PRESENT function reference
2004 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2005 && a->ref->u.ar.type == AR_FULL))
2007 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2008 "subobject of '%s'", gfc_current_intrinsic_arg[0],
2009 gfc_current_intrinsic, &a->where, sym->name);
2018 gfc_check_radix (gfc_expr *x)
2020 if (int_or_real_check (x, 0) == FAILURE)
2028 gfc_check_range (gfc_expr *x)
2030 if (numeric_check (x, 0) == FAILURE)
2037 /* real, float, sngl. */
2039 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2041 if (numeric_check (a, 0) == FAILURE)
2044 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2052 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2054 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2057 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2065 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2067 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2070 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2076 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2079 if (scalar_check (status, 2) == FAILURE)
2087 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2089 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2092 if (scalar_check (x, 0) == FAILURE)
2095 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2098 if (scalar_check (y, 1) == FAILURE)
2106 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2107 gfc_expr *pad, gfc_expr *order)
2113 if (array_check (source, 0) == FAILURE)
2116 if (rank_check (shape, 1, 1) == FAILURE)
2119 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2122 if (gfc_array_size (shape, &size) != SUCCESS)
2124 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2125 "array of constant size", &shape->where);
2129 m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2134 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2135 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2141 if (same_type_check (source, 0, pad, 2) == FAILURE)
2143 if (array_check (pad, 2) == FAILURE)
2147 if (order != NULL && array_check (order, 3) == FAILURE)
2150 if (pad == NULL && shape->expr_type == EXPR_ARRAY
2151 && gfc_is_constant_expr (shape)
2152 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2153 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2155 /* Check the match in size between source and destination. */
2156 if (gfc_array_size (source, &nelems) == SUCCESS)
2161 c = shape->value.constructor;
2162 mpz_init_set_ui (size, 1);
2163 for (; c; c = c->next)
2164 mpz_mul (size, size, c->expr->value.integer);
2166 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2172 gfc_error ("Without padding, there are not enough elements "
2173 "in the intrinsic RESHAPE source at %L to match "
2174 "the shape", &source->where);
2185 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2187 if (type_check (x, 0, BT_REAL) == FAILURE)
2190 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2198 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2200 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2203 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2206 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2209 if (same_type_check (x, 0, y, 1) == FAILURE)
2217 gfc_check_secnds (gfc_expr *r)
2219 if (type_check (r, 0, BT_REAL) == FAILURE)
2222 if (kind_value_check (r, 0, 4) == FAILURE)
2225 if (scalar_check (r, 0) == FAILURE)
2233 gfc_check_selected_int_kind (gfc_expr *r)
2235 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2238 if (scalar_check (r, 0) == FAILURE)
2246 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2248 if (p == NULL && r == NULL)
2250 gfc_error ("Missing arguments to %s intrinsic at %L",
2251 gfc_current_intrinsic, gfc_current_intrinsic_where);
2256 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2259 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2267 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2269 if (type_check (x, 0, BT_REAL) == FAILURE)
2272 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2280 gfc_check_shape (gfc_expr *source)
2284 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2287 ar = gfc_find_array_ref (source);
2289 if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2291 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2292 "an assumed size array", &source->where);
2301 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2303 if (int_or_real_check (a, 0) == FAILURE)
2306 if (same_type_check (a, 0, b, 1) == FAILURE)
2314 gfc_check_size (gfc_expr *array, gfc_expr *dim)
2316 if (array_check (array, 0) == FAILURE)
2321 if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2324 if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2327 if (dim_rank_check (dim, array, 0) == FAILURE)
2336 gfc_check_sleep_sub (gfc_expr *seconds)
2338 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2341 if (scalar_check (seconds, 0) == FAILURE)
2349 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2351 if (source->rank >= GFC_MAX_DIMENSIONS)
2353 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2354 "than rank %d", gfc_current_intrinsic_arg[0],
2355 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2360 if (dim_check (dim, 1, 0) == FAILURE)
2363 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2366 if (scalar_check (ncopies, 2) == FAILURE)
2370 return non_init_transformational ();
2376 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2380 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2382 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2385 if (scalar_check (unit, 0) == FAILURE)
2388 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2394 if (type_check (status, 2, BT_INTEGER) == FAILURE
2395 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2396 || scalar_check (status, 2) == FAILURE)
2404 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2406 return gfc_check_fgetputc_sub (unit, c, NULL);
2411 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2413 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2419 if (type_check (status, 1, BT_INTEGER) == FAILURE
2420 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2421 || scalar_check (status, 1) == FAILURE)
2429 gfc_check_fgetput (gfc_expr *c)
2431 return gfc_check_fgetput_sub (c, NULL);
2436 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2438 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2441 if (scalar_check (unit, 0) == FAILURE)
2444 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2447 if (scalar_check (offset, 1) == FAILURE)
2450 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2453 if (scalar_check (whence, 2) == FAILURE)
2459 if (type_check (status, 3, BT_INTEGER) == FAILURE)
2462 if (kind_value_check (status, 3, 4) == FAILURE)
2465 if (scalar_check (status, 3) == FAILURE)
2474 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2476 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2479 if (scalar_check (unit, 0) == FAILURE)
2482 if (type_check (array, 1, BT_INTEGER) == FAILURE
2483 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2486 if (array_check (array, 1) == FAILURE)
2494 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2496 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2499 if (scalar_check (unit, 0) == FAILURE)
2502 if (type_check (array, 1, BT_INTEGER) == FAILURE
2503 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2506 if (array_check (array, 1) == FAILURE)
2512 if (type_check (status, 2, BT_INTEGER) == FAILURE
2513 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2516 if (scalar_check (status, 2) == FAILURE)
2524 gfc_check_ftell (gfc_expr *unit)
2526 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2529 if (scalar_check (unit, 0) == FAILURE)
2537 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2539 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2542 if (scalar_check (unit, 0) == FAILURE)
2545 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2548 if (scalar_check (offset, 1) == FAILURE)
2556 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2558 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2561 if (type_check (array, 1, BT_INTEGER) == FAILURE
2562 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2565 if (array_check (array, 1) == FAILURE)
2573 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2575 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2578 if (type_check (array, 1, BT_INTEGER) == FAILURE
2579 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2582 if (array_check (array, 1) == FAILURE)
2588 if (type_check (status, 2, BT_INTEGER) == FAILURE
2589 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2592 if (scalar_check (status, 2) == FAILURE)
2600 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2601 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2605 if (type_check (size, 2, BT_INTEGER) == FAILURE)
2608 if (scalar_check (size, 2) == FAILURE)
2611 if (nonoptional_check (size, 2) == FAILURE)
2620 gfc_check_transpose (gfc_expr *matrix)
2622 if (rank_check (matrix, 0, 2) == FAILURE)
2626 return non_init_transformational ();
2633 gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
2635 if (array_check (array, 0) == FAILURE)
2640 if (dim_check (dim, 1, 1) == FAILURE)
2643 if (dim_rank_check (dim, array, 0) == FAILURE)
2652 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2654 if (rank_check (vector, 0, 1) == FAILURE)
2657 if (array_check (mask, 1) == FAILURE)
2660 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2663 if (same_type_check (vector, 0, field, 2) == FAILURE)
2667 return non_init_transformational ();
2674 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2676 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2679 if (same_type_check (x, 0, y, 1) == FAILURE)
2682 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2690 gfc_check_trim (gfc_expr *x)
2692 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2695 if (scalar_check (x, 0) == FAILURE)
2703 gfc_check_ttynam (gfc_expr *unit)
2705 if (scalar_check (unit, 0) == FAILURE)
2708 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2715 /* Common check function for the half a dozen intrinsics that have a
2716 single real argument. */
2719 gfc_check_x (gfc_expr *x)
2721 if (type_check (x, 0, BT_REAL) == FAILURE)
2728 /************* Check functions for intrinsic subroutines *************/
2731 gfc_check_cpu_time (gfc_expr *time)
2733 if (scalar_check (time, 0) == FAILURE)
2736 if (type_check (time, 0, BT_REAL) == FAILURE)
2739 if (variable_check (time, 0) == FAILURE)
2747 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2748 gfc_expr *zone, gfc_expr *values)
2752 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2754 if (scalar_check (date, 0) == FAILURE)
2756 if (variable_check (date, 0) == FAILURE)
2762 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2764 if (scalar_check (time, 1) == FAILURE)
2766 if (variable_check (time, 1) == FAILURE)
2772 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2774 if (scalar_check (zone, 2) == FAILURE)
2776 if (variable_check (zone, 2) == FAILURE)
2782 if (type_check (values, 3, BT_INTEGER) == FAILURE)
2784 if (array_check (values, 3) == FAILURE)
2786 if (rank_check (values, 3, 1) == FAILURE)
2788 if (variable_check (values, 3) == FAILURE)
2797 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2798 gfc_expr *to, gfc_expr *topos)
2800 if (type_check (from, 0, BT_INTEGER) == FAILURE)
2803 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2806 if (type_check (len, 2, BT_INTEGER) == FAILURE)
2809 if (same_type_check (from, 0, to, 3) == FAILURE)
2812 if (variable_check (to, 3) == FAILURE)
2815 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2823 gfc_check_random_number (gfc_expr *harvest)
2825 if (type_check (harvest, 0, BT_REAL) == FAILURE)
2828 if (variable_check (harvest, 0) == FAILURE)
2836 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2840 if (scalar_check (size, 0) == FAILURE)
2843 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2846 if (variable_check (size, 0) == FAILURE)
2849 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2857 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2860 if (array_check (put, 1) == FAILURE)
2863 if (rank_check (put, 1, 1) == FAILURE)
2866 if (type_check (put, 1, BT_INTEGER) == FAILURE)
2869 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2876 if (size != NULL || put != NULL)
2877 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2880 if (array_check (get, 2) == FAILURE)
2883 if (rank_check (get, 2, 1) == FAILURE)
2886 if (type_check (get, 2, BT_INTEGER) == FAILURE)
2889 if (variable_check (get, 2) == FAILURE)
2892 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2901 gfc_check_second_sub (gfc_expr *time)
2903 if (scalar_check (time, 0) == FAILURE)
2906 if (type_check (time, 0, BT_REAL) == FAILURE)
2909 if (kind_value_check(time, 0, 4) == FAILURE)
2916 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2917 count, count_rate, and count_max are all optional arguments */
2920 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
2921 gfc_expr *count_max)
2925 if (scalar_check (count, 0) == FAILURE)
2928 if (type_check (count, 0, BT_INTEGER) == FAILURE)
2931 if (variable_check (count, 0) == FAILURE)
2935 if (count_rate != NULL)
2937 if (scalar_check (count_rate, 1) == FAILURE)
2940 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2943 if (variable_check (count_rate, 1) == FAILURE)
2947 && same_type_check (count, 0, count_rate, 1) == FAILURE)
2952 if (count_max != NULL)
2954 if (scalar_check (count_max, 2) == FAILURE)
2957 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2960 if (variable_check (count_max, 2) == FAILURE)
2964 && same_type_check (count, 0, count_max, 2) == FAILURE)
2967 if (count_rate != NULL
2968 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2977 gfc_check_irand (gfc_expr *x)
2982 if (scalar_check (x, 0) == FAILURE)
2985 if (type_check (x, 0, BT_INTEGER) == FAILURE)
2988 if (kind_value_check(x, 0, 4) == FAILURE)
2996 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
2998 if (scalar_check (seconds, 0) == FAILURE)
3001 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3004 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3006 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3007 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3008 gfc_current_intrinsic, &handler->where);
3012 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3018 if (scalar_check (status, 2) == FAILURE)
3021 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3024 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3032 gfc_check_rand (gfc_expr *x)
3037 if (scalar_check (x, 0) == FAILURE)
3040 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3043 if (kind_value_check(x, 0, 4) == FAILURE)
3051 gfc_check_srand (gfc_expr *x)
3053 if (scalar_check (x, 0) == FAILURE)
3056 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3059 if (kind_value_check(x, 0, 4) == FAILURE)
3067 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3069 if (scalar_check (time, 0) == FAILURE)
3072 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3075 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3083 gfc_check_etime (gfc_expr *x)
3085 if (array_check (x, 0) == FAILURE)
3088 if (rank_check (x, 0, 1) == FAILURE)
3091 if (variable_check (x, 0) == FAILURE)
3094 if (type_check (x, 0, BT_REAL) == FAILURE)
3097 if (kind_value_check(x, 0, 4) == FAILURE)
3105 gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
3107 if (array_check (values, 0) == FAILURE)
3110 if (rank_check (values, 0, 1) == FAILURE)
3113 if (variable_check (values, 0) == FAILURE)
3116 if (type_check (values, 0, BT_REAL) == FAILURE)
3119 if (kind_value_check(values, 0, 4) == FAILURE)
3122 if (scalar_check (time, 1) == FAILURE)
3125 if (type_check (time, 1, BT_REAL) == FAILURE)
3128 if (kind_value_check(time, 1, 4) == FAILURE)
3136 gfc_check_fdate_sub (gfc_expr *date)
3138 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3146 gfc_check_gerror (gfc_expr *msg)
3148 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3156 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3158 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3164 if (scalar_check (status, 1) == FAILURE)
3167 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3175 gfc_check_getlog (gfc_expr *msg)
3177 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3185 gfc_check_exit (gfc_expr *status)
3190 if (type_check (status, 0, BT_INTEGER) == FAILURE)
3193 if (scalar_check (status, 0) == FAILURE)
3201 gfc_check_flush (gfc_expr *unit)
3206 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3209 if (scalar_check (unit, 0) == FAILURE)
3217 gfc_check_free (gfc_expr *i)
3219 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3222 if (scalar_check (i, 0) == FAILURE)
3230 gfc_check_hostnm (gfc_expr *name)
3232 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3240 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3242 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3248 if (scalar_check (status, 1) == FAILURE)
3251 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3259 gfc_check_itime_idate (gfc_expr *values)
3261 if (array_check (values, 0) == FAILURE)
3264 if (rank_check (values, 0, 1) == FAILURE)
3267 if (variable_check (values, 0) == FAILURE)
3270 if (type_check (values, 0, BT_INTEGER) == FAILURE)
3273 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3281 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3283 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3286 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3289 if (scalar_check (time, 0) == FAILURE)
3292 if (array_check (values, 1) == FAILURE)
3295 if (rank_check (values, 1, 1) == FAILURE)
3298 if (variable_check (values, 1) == FAILURE)
3301 if (type_check (values, 1, BT_INTEGER) == FAILURE)
3304 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3312 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3314 if (scalar_check (unit, 0) == FAILURE)
3317 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3320 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3328 gfc_check_isatty (gfc_expr *unit)
3333 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3336 if (scalar_check (unit, 0) == FAILURE)
3344 gfc_check_perror (gfc_expr *string)
3346 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3354 gfc_check_umask (gfc_expr *mask)
3356 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3359 if (scalar_check (mask, 0) == FAILURE)
3367 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3369 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3372 if (scalar_check (mask, 0) == FAILURE)
3378 if (scalar_check (old, 1) == FAILURE)
3381 if (type_check (old, 1, BT_INTEGER) == FAILURE)
3389 gfc_check_unlink (gfc_expr *name)
3391 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3399 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3401 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3407 if (scalar_check (status, 1) == FAILURE)
3410 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3418 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3420 if (scalar_check (number, 0) == FAILURE)
3423 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3426 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3428 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3429 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3430 gfc_current_intrinsic, &handler->where);
3434 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3442 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3444 if (scalar_check (number, 0) == FAILURE)
3447 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3450 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3452 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3453 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3454 gfc_current_intrinsic, &handler->where);
3458 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3464 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3467 if (scalar_check (status, 2) == FAILURE)
3475 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3477 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3480 if (scalar_check (status, 1) == FAILURE)
3483 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3486 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3493 /* This is used for the GNU intrinsics AND, OR and XOR. */
3495 gfc_check_and (gfc_expr *i, gfc_expr *j)
3497 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3499 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3500 "or LOGICAL", gfc_current_intrinsic_arg[0],
3501 gfc_current_intrinsic, &i->where);
3505 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3507 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3508 "or LOGICAL", gfc_current_intrinsic_arg[1],
3509 gfc_current_intrinsic, &j->where);
3513 if (i->ts.type != j->ts.type)
3515 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3516 "have the same type", gfc_current_intrinsic_arg[0],
3517 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3522 if (scalar_check (i, 0) == FAILURE)
3525 if (scalar_check (j, 1) == FAILURE)