2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* These functions check to see if an argument list is compatible with
24 a particular intrinsic function or subroutine. Presence of
25 required arguments has already been established, the argument list
26 has been sorted into the right order and has NULL arguments in the
27 correct places for missing optional arguments. */
33 #include "intrinsic.h"
36 /* Make sure an expression is a scalar. */
39 scalar_check (gfc_expr *e, int n)
44 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
45 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
51 /* Check the type of an expression. */
54 type_check (gfc_expr *e, int n, bt type)
56 if (e->ts.type == type)
59 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
60 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
61 gfc_basic_typename (type));
67 /* Check that the expression is a numeric type. */
70 numeric_check (gfc_expr *e, int n)
72 if (gfc_numeric_ts (&e->ts))
75 /* If the expression has not got a type, check if its namespace can
76 offer a default type. */
77 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
78 && e->symtree->n.sym->ts.type == BT_UNKNOWN
79 && gfc_set_default_type (e->symtree->n.sym, 0,
80 e->symtree->n.sym->ns) == SUCCESS
81 && gfc_numeric_ts (&e->symtree->n.sym->ts))
83 e->ts = e->symtree->n.sym->ts;
87 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
88 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
94 /* Check that an expression is integer or real. */
97 int_or_real_check (gfc_expr *e, int n)
99 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
101 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
102 "or REAL", gfc_current_intrinsic_arg[n],
103 gfc_current_intrinsic, &e->where);
111 /* Check that an expression is real or complex. */
114 real_or_complex_check (gfc_expr *e, int n)
116 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
118 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
119 "or COMPLEX", gfc_current_intrinsic_arg[n],
120 gfc_current_intrinsic, &e->where);
128 /* Check that the expression is an optional constant integer
129 and that it specifies a valid kind for that type. */
132 kind_check (gfc_expr *k, int n, bt type)
139 if (type_check (k, n, BT_INTEGER) == FAILURE)
142 if (scalar_check (k, n) == FAILURE)
145 if (k->expr_type != EXPR_CONSTANT)
147 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
148 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
153 if (gfc_extract_int (k, &kind) != NULL
154 || gfc_validate_kind (type, kind, true) < 0)
156 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
165 /* Make sure the expression is a double precision real. */
168 double_check (gfc_expr *d, int n)
170 if (type_check (d, n, BT_REAL) == FAILURE)
173 if (d->ts.kind != gfc_default_double_kind)
175 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
176 "precision", gfc_current_intrinsic_arg[n],
177 gfc_current_intrinsic, &d->where);
185 /* Make sure the expression is a logical array. */
188 logical_array_check (gfc_expr *array, int n)
190 if (array->ts.type != BT_LOGICAL || array->rank == 0)
192 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
193 "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
202 /* Make sure an expression is an array. */
205 array_check (gfc_expr *e, int n)
210 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
211 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
217 /* Make sure two expressions have the same type. */
220 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
222 if (gfc_compare_types (&e->ts, &f->ts))
225 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
226 "and kind as '%s'", gfc_current_intrinsic_arg[m],
227 gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
233 /* Make sure that an expression has a certain (nonzero) rank. */
236 rank_check (gfc_expr *e, int n, int rank)
241 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
242 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
249 /* Make sure a variable expression is not an optional dummy argument. */
252 nonoptional_check (gfc_expr *e, int n)
254 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
256 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
257 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
261 /* TODO: Recursive check on nonoptional variables? */
267 /* Check that an expression has a particular kind. */
270 kind_value_check (gfc_expr *e, int n, int k)
275 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
276 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
283 /* Make sure an expression is a variable. */
286 variable_check (gfc_expr *e, int n)
288 if ((e->expr_type == EXPR_VARIABLE
289 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
290 || (e->expr_type == EXPR_FUNCTION
291 && e->symtree->n.sym->result == e->symtree->n.sym))
294 if (e->expr_type == EXPR_VARIABLE
295 && e->symtree->n.sym->attr.intent == INTENT_IN)
297 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
298 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
303 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
304 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
310 /* Check the common DIM parameter for correctness. */
313 dim_check (gfc_expr *dim, int n, bool optional)
318 if (type_check (dim, n, BT_INTEGER) == FAILURE)
321 if (scalar_check (dim, n) == FAILURE)
324 if (!optional && nonoptional_check (dim, n) == FAILURE)
331 /* If a DIM parameter is a constant, make sure that it is greater than
332 zero and less than or equal to the rank of the given array. If
333 allow_assumed is zero then dim must be less than the rank of the array
334 for assumed size arrays. */
337 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
345 if (dim->expr_type != EXPR_CONSTANT
346 || (array->expr_type != EXPR_VARIABLE
347 && array->expr_type != EXPR_ARRAY))
351 if (array->expr_type == EXPR_VARIABLE)
353 ar = gfc_find_array_ref (array);
354 if (ar->as->type == AS_ASSUMED_SIZE
356 && ar->type != AR_ELEMENT
357 && ar->type != AR_SECTION)
361 if (mpz_cmp_ui (dim->value.integer, 1) < 0
362 || mpz_cmp_ui (dim->value.integer, rank) > 0)
364 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
365 "dimension index", gfc_current_intrinsic, &dim->where);
374 /* Compare the size of a along dimension ai with the size of b along
375 dimension bi, returning 0 if they are known not to be identical,
376 and 1 if they are identical, or if this cannot be determined. */
379 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
381 mpz_t a_size, b_size;
384 gcc_assert (a->rank > ai);
385 gcc_assert (b->rank > bi);
389 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
391 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
393 if (mpz_cmp (a_size, b_size) != 0)
404 /* Check whether two character expressions have the same length;
405 returns SUCCESS if they have or if the length cannot be determined. */
408 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
413 if (a->ts.cl && a->ts.cl->length
414 && a->ts.cl->length->expr_type == EXPR_CONSTANT)
415 len_a = mpz_get_si (a->ts.cl->length->value.integer);
416 else if (a->expr_type == EXPR_CONSTANT
417 && (a->ts.cl == NULL || a->ts.cl->length == NULL))
418 len_a = a->value.character.length;
422 if (b->ts.cl && b->ts.cl->length
423 && b->ts.cl->length->expr_type == EXPR_CONSTANT)
424 len_b = mpz_get_si (b->ts.cl->length->value.integer);
425 else if (b->expr_type == EXPR_CONSTANT
426 && (b->ts.cl == NULL || b->ts.cl->length == NULL))
427 len_b = b->value.character.length;
434 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
435 len_a, len_b, name, &a->where);
440 /***** Check functions *****/
442 /* Check subroutine suitable for intrinsics taking a real argument and
443 a kind argument for the result. */
446 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
448 if (type_check (a, 0, BT_REAL) == FAILURE)
450 if (kind_check (kind, 1, type) == FAILURE)
457 /* Check subroutine suitable for ceiling, floor and nint. */
460 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
462 return check_a_kind (a, kind, BT_INTEGER);
466 /* Check subroutine suitable for aint, anint. */
469 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
471 return check_a_kind (a, kind, BT_REAL);
476 gfc_check_abs (gfc_expr *a)
478 if (numeric_check (a, 0) == FAILURE)
486 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
488 if (type_check (a, 0, BT_INTEGER) == FAILURE)
490 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
498 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
500 if (type_check (name, 0, BT_CHARACTER) == FAILURE
501 || scalar_check (name, 0) == FAILURE)
503 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
506 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
507 || scalar_check (mode, 1) == FAILURE)
509 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
517 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
519 if (logical_array_check (mask, 0) == FAILURE)
522 if (dim_check (dim, 1, false) == FAILURE)
525 if (dim_rank_check (dim, mask, 0) == FAILURE)
533 gfc_check_allocated (gfc_expr *array)
535 symbol_attribute attr;
537 if (variable_check (array, 0) == FAILURE)
540 attr = gfc_variable_attr (array, NULL);
541 if (!attr.allocatable)
543 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
544 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
549 if (array_check (array, 0) == FAILURE)
556 /* Common check function where the first argument must be real or
557 integer and the second argument must be the same as the first. */
560 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
562 if (int_or_real_check (a, 0) == FAILURE)
565 if (a->ts.type != p->ts.type)
567 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
568 "have the same type", gfc_current_intrinsic_arg[0],
569 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
574 if (a->ts.kind != p->ts.kind)
576 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
577 &p->where) == FAILURE)
586 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
588 if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
596 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
598 symbol_attribute attr1, attr2;
603 where = &pointer->where;
605 if (pointer->expr_type == EXPR_VARIABLE)
606 attr1 = gfc_variable_attr (pointer, NULL);
607 else if (pointer->expr_type == EXPR_FUNCTION)
608 attr1 = pointer->symtree->n.sym->attr;
609 else if (pointer->expr_type == EXPR_NULL)
612 gcc_assert (0); /* Pointer must be a variable or a function. */
614 if (!attr1.pointer && !attr1.proc_pointer)
616 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
617 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
622 /* Target argument is optional. */
626 where = &target->where;
627 if (target->expr_type == EXPR_NULL)
630 if (target->expr_type == EXPR_VARIABLE)
631 attr2 = gfc_variable_attr (target, NULL);
632 else if (target->expr_type == EXPR_FUNCTION)
633 attr2 = target->symtree->n.sym->attr;
636 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
637 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
638 gfc_current_intrinsic, &target->where);
642 if (attr1.pointer && !attr2.pointer && !attr2.target)
644 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
645 "or a TARGET", gfc_current_intrinsic_arg[1],
646 gfc_current_intrinsic, &target->where);
651 if (same_type_check (pointer, 0, target, 1) == FAILURE)
653 if (rank_check (target, 0, pointer->rank) == FAILURE)
655 if (target->rank > 0)
657 for (i = 0; i < target->rank; i++)
658 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
660 gfc_error ("Array section with a vector subscript at %L shall not "
661 "be the target of a pointer",
671 gfc_error ("NULL pointer at %L is not permitted as actual argument "
672 "of '%s' intrinsic function", where, gfc_current_intrinsic);
679 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
681 if (type_check (y, 0, BT_REAL) == FAILURE)
683 if (same_type_check (y, 0, x, 1) == FAILURE)
690 /* BESJN and BESYN functions. */
693 gfc_check_besn (gfc_expr *n, gfc_expr *x)
695 if (type_check (n, 0, BT_INTEGER) == FAILURE)
698 if (type_check (x, 1, BT_REAL) == FAILURE)
706 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
708 if (type_check (i, 0, BT_INTEGER) == FAILURE)
710 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
718 gfc_check_char (gfc_expr *i, gfc_expr *kind)
720 if (type_check (i, 0, BT_INTEGER) == FAILURE)
722 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
730 gfc_check_chdir (gfc_expr *dir)
732 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
734 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
742 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
744 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
746 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
752 if (type_check (status, 1, BT_INTEGER) == FAILURE)
754 if (scalar_check (status, 1) == FAILURE)
762 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
764 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
766 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
769 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
771 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
779 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
781 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
783 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
786 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
788 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
794 if (type_check (status, 2, BT_INTEGER) == FAILURE)
797 if (scalar_check (status, 2) == FAILURE)
805 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
807 if (numeric_check (x, 0) == FAILURE)
812 if (numeric_check (y, 1) == FAILURE)
815 if (x->ts.type == BT_COMPLEX)
817 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
818 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
819 gfc_current_intrinsic, &y->where);
824 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
832 gfc_check_complex (gfc_expr *x, gfc_expr *y)
834 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
836 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
837 "or REAL", gfc_current_intrinsic_arg[0],
838 gfc_current_intrinsic, &x->where);
841 if (scalar_check (x, 0) == FAILURE)
844 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
846 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
847 "or REAL", gfc_current_intrinsic_arg[1],
848 gfc_current_intrinsic, &y->where);
851 if (scalar_check (y, 1) == FAILURE)
859 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
861 if (logical_array_check (mask, 0) == FAILURE)
863 if (dim_check (dim, 1, false) == FAILURE)
865 if (dim_rank_check (dim, mask, 0) == FAILURE)
867 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
869 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
870 "with KIND argument at %L",
871 gfc_current_intrinsic, &kind->where) == FAILURE)
879 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
881 if (array_check (array, 0) == FAILURE)
884 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
887 if (dim_check (dim, 2, true) == FAILURE)
890 if (dim_rank_check (dim, array, false) == FAILURE)
893 if (array->rank == 1 || shift->rank == 0)
895 if (scalar_check (shift, 1) == FAILURE)
898 else if (shift->rank == array->rank - 1)
903 else if (dim->expr_type == EXPR_CONSTANT)
904 gfc_extract_int (dim, &d);
911 for (i = 0, j = 0; i < array->rank; i++)
914 if (!identical_dimen_shape (array, i, shift, j))
916 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
917 "invalid shape in dimension %d (%ld/%ld)",
918 gfc_current_intrinsic_arg[1],
919 gfc_current_intrinsic, &shift->where, i + 1,
920 mpz_get_si (array->shape[i]),
921 mpz_get_si (shift->shape[j]));
931 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
932 "%d or be a scalar", gfc_current_intrinsic_arg[1],
933 gfc_current_intrinsic, &shift->where, array->rank - 1);
942 gfc_check_ctime (gfc_expr *time)
944 if (scalar_check (time, 0) == FAILURE)
947 if (type_check (time, 0, BT_INTEGER) == FAILURE)
954 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
956 if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
963 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
965 if (numeric_check (x, 0) == FAILURE)
970 if (numeric_check (y, 1) == FAILURE)
973 if (x->ts.type == BT_COMPLEX)
975 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
976 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
977 gfc_current_intrinsic, &y->where);
987 gfc_check_dble (gfc_expr *x)
989 if (numeric_check (x, 0) == FAILURE)
997 gfc_check_digits (gfc_expr *x)
999 if (int_or_real_check (x, 0) == FAILURE)
1007 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1009 switch (vector_a->ts.type)
1012 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1019 if (numeric_check (vector_b, 1) == FAILURE)
1024 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1025 "or LOGICAL", gfc_current_intrinsic_arg[0],
1026 gfc_current_intrinsic, &vector_a->where);
1030 if (rank_check (vector_a, 0, 1) == FAILURE)
1033 if (rank_check (vector_b, 1, 1) == FAILURE)
1036 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1038 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1039 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
1040 gfc_current_intrinsic_arg[1], &vector_a->where);
1049 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1051 if (type_check (x, 0, BT_REAL) == FAILURE
1052 || type_check (y, 1, BT_REAL) == FAILURE)
1055 if (x->ts.kind != gfc_default_real_kind)
1057 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1058 "real", gfc_current_intrinsic_arg[0],
1059 gfc_current_intrinsic, &x->where);
1063 if (y->ts.kind != gfc_default_real_kind)
1065 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1066 "real", gfc_current_intrinsic_arg[1],
1067 gfc_current_intrinsic, &y->where);
1076 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1079 if (array_check (array, 0) == FAILURE)
1082 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1085 if (dim_check (dim, 3, true) == FAILURE)
1088 if (dim_rank_check (dim, array, false) == FAILURE)
1091 if (array->rank == 1 || shift->rank == 0)
1093 if (scalar_check (shift, 1) == FAILURE)
1096 else if (shift->rank == array->rank - 1)
1101 else if (dim->expr_type == EXPR_CONSTANT)
1102 gfc_extract_int (dim, &d);
1109 for (i = 0, j = 0; i < array->rank; i++)
1112 if (!identical_dimen_shape (array, i, shift, j))
1114 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1115 "invalid shape in dimension %d (%ld/%ld)",
1116 gfc_current_intrinsic_arg[1],
1117 gfc_current_intrinsic, &shift->where, i + 1,
1118 mpz_get_si (array->shape[i]),
1119 mpz_get_si (shift->shape[j]));
1129 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1130 "%d or be a scalar", gfc_current_intrinsic_arg[1],
1131 gfc_current_intrinsic, &shift->where, array->rank - 1);
1135 if (boundary != NULL)
1137 if (same_type_check (array, 0, boundary, 2) == FAILURE)
1140 if (array->rank == 1 || boundary->rank == 0)
1142 if (scalar_check (boundary, 2) == FAILURE)
1145 else if (boundary->rank == array->rank - 1)
1147 if (gfc_check_conformance (shift, boundary,
1148 "arguments '%s' and '%s' for "
1150 gfc_current_intrinsic_arg[1],
1151 gfc_current_intrinsic_arg[2],
1152 gfc_current_intrinsic ) == FAILURE)
1157 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1158 "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
1159 gfc_current_intrinsic, &shift->where, array->rank - 1);
1168 /* A single complex argument. */
1171 gfc_check_fn_c (gfc_expr *a)
1173 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1180 /* A single real argument. */
1183 gfc_check_fn_r (gfc_expr *a)
1185 if (type_check (a, 0, BT_REAL) == FAILURE)
1191 /* A single double argument. */
1194 gfc_check_fn_d (gfc_expr *a)
1196 if (double_check (a, 0) == FAILURE)
1202 /* A single real or complex argument. */
1205 gfc_check_fn_rc (gfc_expr *a)
1207 if (real_or_complex_check (a, 0) == FAILURE)
1215 gfc_check_fn_rc2008 (gfc_expr *a)
1217 if (real_or_complex_check (a, 0) == FAILURE)
1220 if (a->ts.type == BT_COMPLEX
1221 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
1222 "argument of '%s' intrinsic at %L",
1223 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1224 &a->where) == FAILURE)
1232 gfc_check_fnum (gfc_expr *unit)
1234 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1237 if (scalar_check (unit, 0) == FAILURE)
1245 gfc_check_huge (gfc_expr *x)
1247 if (int_or_real_check (x, 0) == FAILURE)
1255 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1257 if (type_check (x, 0, BT_REAL) == FAILURE)
1259 if (same_type_check (x, 0, y, 1) == FAILURE)
1266 /* Check that the single argument is an integer. */
1269 gfc_check_i (gfc_expr *i)
1271 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1279 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1281 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1284 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1287 if (i->ts.kind != j->ts.kind)
1289 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1290 &i->where) == FAILURE)
1299 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1301 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1304 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1312 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1314 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1317 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1320 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1328 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1330 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1333 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1341 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1345 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1348 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1351 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1352 "with KIND argument at %L",
1353 gfc_current_intrinsic, &kind->where) == FAILURE)
1356 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1362 /* Substring references don't have the charlength set. */
1364 while (ref && ref->type != REF_SUBSTRING)
1367 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1371 /* Check that the argument is length one. Non-constant lengths
1372 can't be checked here, so assume they are ok. */
1373 if (c->ts.cl && c->ts.cl->length)
1375 /* If we already have a length for this expression then use it. */
1376 if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1378 i = mpz_get_si (c->ts.cl->length->value.integer);
1385 start = ref->u.ss.start;
1386 end = ref->u.ss.end;
1389 if (end == NULL || end->expr_type != EXPR_CONSTANT
1390 || start->expr_type != EXPR_CONSTANT)
1393 i = mpz_get_si (end->value.integer) + 1
1394 - mpz_get_si (start->value.integer);
1402 gfc_error ("Argument of %s at %L must be of length one",
1403 gfc_current_intrinsic, &c->where);
1412 gfc_check_idnint (gfc_expr *a)
1414 if (double_check (a, 0) == FAILURE)
1422 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1424 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1427 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1430 if (i->ts.kind != j->ts.kind)
1432 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1433 &i->where) == FAILURE)
1442 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1445 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1446 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1449 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1452 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1454 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1455 "with KIND argument at %L",
1456 gfc_current_intrinsic, &kind->where) == FAILURE)
1459 if (string->ts.kind != substring->ts.kind)
1461 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1462 "kind as '%s'", gfc_current_intrinsic_arg[1],
1463 gfc_current_intrinsic, &substring->where,
1464 gfc_current_intrinsic_arg[0]);
1473 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1475 if (numeric_check (x, 0) == FAILURE)
1478 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1486 gfc_check_intconv (gfc_expr *x)
1488 if (numeric_check (x, 0) == FAILURE)
1496 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1498 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1501 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1504 if (i->ts.kind != j->ts.kind)
1506 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1507 &i->where) == FAILURE)
1516 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1518 if (type_check (i, 0, BT_INTEGER) == FAILURE
1519 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1527 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1529 if (type_check (i, 0, BT_INTEGER) == FAILURE
1530 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1533 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1541 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1543 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1546 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1554 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1556 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1559 if (scalar_check (pid, 0) == FAILURE)
1562 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1565 if (scalar_check (sig, 1) == FAILURE)
1571 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1574 if (scalar_check (status, 2) == FAILURE)
1582 gfc_check_kind (gfc_expr *x)
1584 if (x->ts.type == BT_DERIVED)
1586 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1587 "non-derived type", gfc_current_intrinsic_arg[0],
1588 gfc_current_intrinsic, &x->where);
1597 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1599 if (array_check (array, 0) == FAILURE)
1602 if (dim_check (dim, 1, false) == FAILURE)
1605 if (dim_rank_check (dim, array, 1) == FAILURE)
1608 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1610 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1611 "with KIND argument at %L",
1612 gfc_current_intrinsic, &kind->where) == FAILURE)
1620 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
1622 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
1625 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1627 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1628 "with KIND argument at %L",
1629 gfc_current_intrinsic, &kind->where) == FAILURE)
1637 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
1639 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1641 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
1644 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
1646 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
1654 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1656 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1658 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1661 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1663 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1671 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1673 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1675 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1678 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1680 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
1686 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1689 if (scalar_check (status, 2) == FAILURE)
1697 gfc_check_loc (gfc_expr *expr)
1699 return variable_check (expr, 0);
1704 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1706 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1708 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1711 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1713 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1721 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1723 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1725 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1728 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1730 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1736 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1739 if (scalar_check (status, 2) == FAILURE)
1747 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1749 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1751 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1758 /* Min/max family. */
1761 min_max_args (gfc_actual_arglist *arg)
1763 if (arg == NULL || arg->next == NULL)
1765 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1766 gfc_current_intrinsic, gfc_current_intrinsic_where);
1775 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
1777 gfc_actual_arglist *arg, *tmp;
1782 if (min_max_args (arglist) == FAILURE)
1785 for (arg = arglist, n=1; arg; arg = arg->next, n++)
1788 if (x->ts.type != type || x->ts.kind != kind)
1790 if (x->ts.type == type)
1792 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1793 "kinds at %L", &x->where) == FAILURE)
1798 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1799 "%s(%d)", n, gfc_current_intrinsic, &x->where,
1800 gfc_basic_typename (type), kind);
1805 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
1806 if (gfc_check_conformance (tmp->expr, x,
1807 "arguments 'a%d' and 'a%d' for "
1808 "intrinsic '%s'", m, n,
1809 gfc_current_intrinsic) == FAILURE)
1818 gfc_check_min_max (gfc_actual_arglist *arg)
1822 if (min_max_args (arg) == FAILURE)
1827 if (x->ts.type == BT_CHARACTER)
1829 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1830 "with CHARACTER argument at %L",
1831 gfc_current_intrinsic, &x->where) == FAILURE)
1834 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1836 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1837 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
1841 return check_rest (x->ts.type, x->ts.kind, arg);
1846 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1848 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1853 gfc_check_min_max_real (gfc_actual_arglist *arg)
1855 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1860 gfc_check_min_max_double (gfc_actual_arglist *arg)
1862 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1866 /* End of min/max family. */
1869 gfc_check_malloc (gfc_expr *size)
1871 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1874 if (scalar_check (size, 0) == FAILURE)
1882 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1884 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1886 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1887 "or LOGICAL", gfc_current_intrinsic_arg[0],
1888 gfc_current_intrinsic, &matrix_a->where);
1892 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1894 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1895 "or LOGICAL", gfc_current_intrinsic_arg[1],
1896 gfc_current_intrinsic, &matrix_b->where);
1900 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
1901 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
1903 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
1904 gfc_current_intrinsic, &matrix_a->where,
1905 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
1909 switch (matrix_a->rank)
1912 if (rank_check (matrix_b, 1, 2) == FAILURE)
1914 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1915 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1917 gfc_error ("Different shape on dimension 1 for arguments '%s' "
1918 "and '%s' at %L for intrinsic matmul",
1919 gfc_current_intrinsic_arg[0],
1920 gfc_current_intrinsic_arg[1], &matrix_a->where);
1926 if (matrix_b->rank != 2)
1928 if (rank_check (matrix_b, 1, 1) == FAILURE)
1931 /* matrix_b has rank 1 or 2 here. Common check for the cases
1932 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1933 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1934 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1936 gfc_error ("Different shape on dimension 2 for argument '%s' and "
1937 "dimension 1 for argument '%s' at %L for intrinsic "
1938 "matmul", gfc_current_intrinsic_arg[0],
1939 gfc_current_intrinsic_arg[1], &matrix_a->where);
1945 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1946 "1 or 2", gfc_current_intrinsic_arg[0],
1947 gfc_current_intrinsic, &matrix_a->where);
1955 /* Whoever came up with this interface was probably on something.
1956 The possibilities for the occupation of the second and third
1963 NULL MASK minloc(array, mask=m)
1966 I.e. in the case of minloc(array,mask), mask will be in the second
1967 position of the argument list and we'll have to fix that up. */
1970 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1972 gfc_expr *a, *m, *d;
1975 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1979 m = ap->next->next->expr;
1981 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1982 && ap->next->name == NULL)
1986 ap->next->expr = NULL;
1987 ap->next->next->expr = m;
1990 if (dim_check (d, 1, false) == FAILURE)
1993 if (dim_rank_check (d, a, 0) == FAILURE)
1996 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2000 && gfc_check_conformance (a, m,
2001 "arguments '%s' and '%s' for intrinsic %s",
2002 gfc_current_intrinsic_arg[0],
2003 gfc_current_intrinsic_arg[2],
2004 gfc_current_intrinsic ) == FAILURE)
2011 /* Similar to minloc/maxloc, the argument list might need to be
2012 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2013 difference is that MINLOC/MAXLOC take an additional KIND argument.
2014 The possibilities are:
2020 NULL MASK minval(array, mask=m)
2023 I.e. in the case of minval(array,mask), mask will be in the second
2024 position of the argument list and we'll have to fix that up. */
2027 check_reduction (gfc_actual_arglist *ap)
2029 gfc_expr *a, *m, *d;
2033 m = ap->next->next->expr;
2035 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2036 && ap->next->name == NULL)
2040 ap->next->expr = NULL;
2041 ap->next->next->expr = m;
2044 if (dim_check (d, 1, false) == FAILURE)
2047 if (dim_rank_check (d, a, 0) == FAILURE)
2050 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2054 && gfc_check_conformance (a, m,
2055 "arguments '%s' and '%s' for intrinsic %s",
2056 gfc_current_intrinsic_arg[0],
2057 gfc_current_intrinsic_arg[2],
2058 gfc_current_intrinsic) == FAILURE)
2066 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2068 if (int_or_real_check (ap->expr, 0) == FAILURE
2069 || array_check (ap->expr, 0) == FAILURE)
2072 return check_reduction (ap);
2077 gfc_check_product_sum (gfc_actual_arglist *ap)
2079 if (numeric_check (ap->expr, 0) == FAILURE
2080 || array_check (ap->expr, 0) == FAILURE)
2083 return check_reduction (ap);
2088 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2090 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2093 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2096 if (tsource->ts.type == BT_CHARACTER)
2097 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2104 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2106 symbol_attribute attr;
2108 if (variable_check (from, 0) == FAILURE)
2111 if (array_check (from, 0) == FAILURE)
2114 attr = gfc_variable_attr (from, NULL);
2115 if (!attr.allocatable)
2117 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2118 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2123 if (variable_check (to, 0) == FAILURE)
2126 if (array_check (to, 0) == FAILURE)
2129 attr = gfc_variable_attr (to, NULL);
2130 if (!attr.allocatable)
2132 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2133 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2138 if (same_type_check (from, 0, to, 1) == FAILURE)
2141 if (to->rank != from->rank)
2143 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2144 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
2145 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2146 &to->where, from->rank, to->rank);
2150 if (to->ts.kind != from->ts.kind)
2152 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2153 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
2154 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2155 &to->where, from->ts.kind, to->ts.kind);
2164 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2166 if (type_check (x, 0, BT_REAL) == FAILURE)
2169 if (type_check (s, 1, BT_REAL) == FAILURE)
2177 gfc_check_new_line (gfc_expr *a)
2179 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2187 gfc_check_null (gfc_expr *mold)
2189 symbol_attribute attr;
2194 if (variable_check (mold, 0) == FAILURE)
2197 attr = gfc_variable_attr (mold, NULL);
2199 if (!attr.pointer && !attr.proc_pointer)
2201 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2202 gfc_current_intrinsic_arg[0],
2203 gfc_current_intrinsic, &mold->where);
2212 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2214 if (array_check (array, 0) == FAILURE)
2217 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2220 if (gfc_check_conformance (array, mask,
2221 "arguments '%s' and '%s' for intrinsic '%s'",
2222 gfc_current_intrinsic_arg[0],
2223 gfc_current_intrinsic_arg[1],
2224 gfc_current_intrinsic) == FAILURE)
2229 mpz_t array_size, vector_size;
2230 bool have_array_size, have_vector_size;
2232 if (same_type_check (array, 0, vector, 2) == FAILURE)
2235 if (rank_check (vector, 2, 1) == FAILURE)
2238 /* VECTOR requires at least as many elements as MASK
2239 has .TRUE. values. */
2240 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2241 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2243 if (have_vector_size
2244 && (mask->expr_type == EXPR_ARRAY
2245 || (mask->expr_type == EXPR_CONSTANT
2246 && have_array_size)))
2248 int mask_true_values = 0;
2250 if (mask->expr_type == EXPR_ARRAY)
2252 gfc_constructor *mask_ctor = mask->value.constructor;
2255 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2257 mask_true_values = 0;
2261 if (mask_ctor->expr->value.logical)
2264 mask_ctor = mask_ctor->next;
2267 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2268 mask_true_values = mpz_get_si (array_size);
2270 if (mpz_get_si (vector_size) < mask_true_values)
2272 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2273 "provide at least as many elements as there "
2274 "are .TRUE. values in '%s' (%ld/%d)",
2275 gfc_current_intrinsic_arg[2],gfc_current_intrinsic,
2276 &vector->where, gfc_current_intrinsic_arg[1],
2277 mpz_get_si (vector_size), mask_true_values);
2282 if (have_array_size)
2283 mpz_clear (array_size);
2284 if (have_vector_size)
2285 mpz_clear (vector_size);
2293 gfc_check_precision (gfc_expr *x)
2295 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
2297 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2298 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
2299 gfc_current_intrinsic, &x->where);
2308 gfc_check_present (gfc_expr *a)
2312 if (variable_check (a, 0) == FAILURE)
2315 sym = a->symtree->n.sym;
2316 if (!sym->attr.dummy)
2318 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2319 "dummy variable", gfc_current_intrinsic_arg[0],
2320 gfc_current_intrinsic, &a->where);
2324 if (!sym->attr.optional)
2326 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2327 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2328 gfc_current_intrinsic, &a->where);
2332 /* 13.14.82 PRESENT(A)
2334 Argument. A shall be the name of an optional dummy argument that is
2335 accessible in the subprogram in which the PRESENT function reference
2339 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2340 && a->ref->u.ar.type == AR_FULL))
2342 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2343 "subobject of '%s'", gfc_current_intrinsic_arg[0],
2344 gfc_current_intrinsic, &a->where, sym->name);
2353 gfc_check_radix (gfc_expr *x)
2355 if (int_or_real_check (x, 0) == FAILURE)
2363 gfc_check_range (gfc_expr *x)
2365 if (numeric_check (x, 0) == FAILURE)
2372 /* real, float, sngl. */
2374 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2376 if (numeric_check (a, 0) == FAILURE)
2379 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2387 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2389 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2391 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2394 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2396 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2404 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2406 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2408 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2411 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2413 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2419 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2422 if (scalar_check (status, 2) == FAILURE)
2430 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2432 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2435 if (scalar_check (x, 0) == FAILURE)
2438 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2441 if (scalar_check (y, 1) == FAILURE)
2449 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2450 gfc_expr *pad, gfc_expr *order)
2456 if (array_check (source, 0) == FAILURE)
2459 if (rank_check (shape, 1, 1) == FAILURE)
2462 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2465 if (gfc_array_size (shape, &size) != SUCCESS)
2467 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2468 "array of constant size", &shape->where);
2472 shape_size = mpz_get_ui (size);
2475 if (shape_size <= 0)
2477 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
2478 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2482 else if (shape_size > GFC_MAX_DIMENSIONS)
2484 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2485 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2488 else if (shape->expr_type == EXPR_ARRAY)
2492 for (i = 0; i < shape_size; ++i)
2494 e = gfc_get_array_element (shape, i);
2495 if (e->expr_type != EXPR_CONSTANT)
2501 gfc_extract_int (e, &extent);
2504 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2505 "negative element (%d)", gfc_current_intrinsic_arg[1],
2506 gfc_current_intrinsic, &e->where, extent);
2516 if (same_type_check (source, 0, pad, 2) == FAILURE)
2519 if (array_check (pad, 2) == FAILURE)
2525 if (array_check (order, 3) == FAILURE)
2528 if (type_check (order, 3, BT_INTEGER) == FAILURE)
2531 if (order->expr_type == EXPR_ARRAY)
2533 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
2536 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
2539 gfc_array_size (order, &size);
2540 order_size = mpz_get_ui (size);
2543 if (order_size != shape_size)
2545 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2546 "has wrong number of elements (%d/%d)",
2547 gfc_current_intrinsic_arg[3],
2548 gfc_current_intrinsic, &order->where,
2549 order_size, shape_size);
2553 for (i = 1; i <= order_size; ++i)
2555 e = gfc_get_array_element (order, i-1);
2556 if (e->expr_type != EXPR_CONSTANT)
2562 gfc_extract_int (e, &dim);
2564 if (dim < 1 || dim > order_size)
2566 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2567 "has out-of-range dimension (%d)",
2568 gfc_current_intrinsic_arg[3],
2569 gfc_current_intrinsic, &e->where, dim);
2573 if (perm[dim-1] != 0)
2575 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2576 "invalid permutation of dimensions (dimension "
2577 "'%d' duplicated)", gfc_current_intrinsic_arg[3],
2578 gfc_current_intrinsic, &e->where, dim);
2588 if (pad == NULL && shape->expr_type == EXPR_ARRAY
2589 && gfc_is_constant_expr (shape)
2590 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2591 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2593 /* Check the match in size between source and destination. */
2594 if (gfc_array_size (source, &nelems) == SUCCESS)
2599 c = shape->value.constructor;
2600 mpz_init_set_ui (size, 1);
2601 for (; c; c = c->next)
2602 mpz_mul (size, size, c->expr->value.integer);
2604 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2610 gfc_error ("Without padding, there are not enough elements "
2611 "in the intrinsic RESHAPE source at %L to match "
2612 "the shape", &source->where);
2623 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2625 if (type_check (x, 0, BT_REAL) == FAILURE)
2628 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2636 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2638 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2641 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2644 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2647 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2649 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2650 "with KIND argument at %L",
2651 gfc_current_intrinsic, &kind->where) == FAILURE)
2654 if (same_type_check (x, 0, y, 1) == FAILURE)
2662 gfc_check_secnds (gfc_expr *r)
2664 if (type_check (r, 0, BT_REAL) == FAILURE)
2667 if (kind_value_check (r, 0, 4) == FAILURE)
2670 if (scalar_check (r, 0) == FAILURE)
2678 gfc_check_selected_char_kind (gfc_expr *name)
2680 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2683 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
2686 if (scalar_check (name, 0) == FAILURE)
2694 gfc_check_selected_int_kind (gfc_expr *r)
2696 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2699 if (scalar_check (r, 0) == FAILURE)
2707 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2709 if (p == NULL && r == NULL)
2711 gfc_error ("Missing arguments to %s intrinsic at %L",
2712 gfc_current_intrinsic, gfc_current_intrinsic_where);
2717 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2720 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2728 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2730 if (type_check (x, 0, BT_REAL) == FAILURE)
2733 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2741 gfc_check_shape (gfc_expr *source)
2745 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2748 ar = gfc_find_array_ref (source);
2750 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
2752 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2753 "an assumed size array", &source->where);
2762 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2764 if (int_or_real_check (a, 0) == FAILURE)
2767 if (same_type_check (a, 0, b, 1) == FAILURE)
2775 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2777 if (array_check (array, 0) == FAILURE)
2780 if (dim_check (dim, 1, true) == FAILURE)
2783 if (dim_rank_check (dim, array, 0) == FAILURE)
2786 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2788 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2789 "with KIND argument at %L",
2790 gfc_current_intrinsic, &kind->where) == FAILURE)
2799 gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
2806 gfc_check_sleep_sub (gfc_expr *seconds)
2808 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2811 if (scalar_check (seconds, 0) == FAILURE)
2819 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2821 if (source->rank >= GFC_MAX_DIMENSIONS)
2823 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2824 "than rank %d", gfc_current_intrinsic_arg[0],
2825 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2833 if (dim_check (dim, 1, false) == FAILURE)
2836 /* dim_rank_check() does not apply here. */
2838 && dim->expr_type == EXPR_CONSTANT
2839 && (mpz_cmp_ui (dim->value.integer, 1) < 0
2840 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
2842 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
2843 "dimension index", gfc_current_intrinsic_arg[1],
2844 gfc_current_intrinsic, &dim->where);
2848 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2851 if (scalar_check (ncopies, 2) == FAILURE)
2858 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2862 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2864 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2867 if (scalar_check (unit, 0) == FAILURE)
2870 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2872 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
2878 if (type_check (status, 2, BT_INTEGER) == FAILURE
2879 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2880 || scalar_check (status, 2) == FAILURE)
2888 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2890 return gfc_check_fgetputc_sub (unit, c, NULL);
2895 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2897 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2899 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
2905 if (type_check (status, 1, BT_INTEGER) == FAILURE
2906 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2907 || scalar_check (status, 1) == FAILURE)
2915 gfc_check_fgetput (gfc_expr *c)
2917 return gfc_check_fgetput_sub (c, NULL);
2922 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2924 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2927 if (scalar_check (unit, 0) == FAILURE)
2930 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2933 if (scalar_check (offset, 1) == FAILURE)
2936 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2939 if (scalar_check (whence, 2) == FAILURE)
2945 if (type_check (status, 3, BT_INTEGER) == FAILURE)
2948 if (kind_value_check (status, 3, 4) == FAILURE)
2951 if (scalar_check (status, 3) == FAILURE)
2960 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2962 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2965 if (scalar_check (unit, 0) == FAILURE)
2968 if (type_check (array, 1, BT_INTEGER) == FAILURE
2969 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2972 if (array_check (array, 1) == FAILURE)
2980 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2982 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2985 if (scalar_check (unit, 0) == FAILURE)
2988 if (type_check (array, 1, BT_INTEGER) == FAILURE
2989 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2992 if (array_check (array, 1) == FAILURE)
2998 if (type_check (status, 2, BT_INTEGER) == FAILURE
2999 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3002 if (scalar_check (status, 2) == FAILURE)
3010 gfc_check_ftell (gfc_expr *unit)
3012 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3015 if (scalar_check (unit, 0) == FAILURE)
3023 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3025 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3028 if (scalar_check (unit, 0) == FAILURE)
3031 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3034 if (scalar_check (offset, 1) == FAILURE)
3042 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3044 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3046 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3049 if (type_check (array, 1, BT_INTEGER) == FAILURE
3050 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3053 if (array_check (array, 1) == FAILURE)
3061 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3063 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3065 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3068 if (type_check (array, 1, BT_INTEGER) == FAILURE
3069 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3072 if (array_check (array, 1) == FAILURE)
3078 if (type_check (status, 2, BT_INTEGER) == FAILURE
3079 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3082 if (scalar_check (status, 2) == FAILURE)
3090 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
3091 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
3093 if (mold->ts.type == BT_HOLLERITH)
3095 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3096 &mold->where, gfc_basic_typename (BT_HOLLERITH));
3102 if (type_check (size, 2, BT_INTEGER) == FAILURE)
3105 if (scalar_check (size, 2) == FAILURE)
3108 if (nonoptional_check (size, 2) == FAILURE)
3117 gfc_check_transpose (gfc_expr *matrix)
3119 if (rank_check (matrix, 0, 2) == FAILURE)
3127 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3129 if (array_check (array, 0) == FAILURE)
3132 if (dim_check (dim, 1, false) == FAILURE)
3135 if (dim_rank_check (dim, array, 0) == FAILURE)
3138 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3140 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3141 "with KIND argument at %L",
3142 gfc_current_intrinsic, &kind->where) == FAILURE)
3150 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
3154 if (rank_check (vector, 0, 1) == FAILURE)
3157 if (array_check (mask, 1) == FAILURE)
3160 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
3163 if (same_type_check (vector, 0, field, 2) == FAILURE)
3166 if (mask->expr_type == EXPR_ARRAY
3167 && gfc_array_size (vector, &vector_size) == SUCCESS)
3169 int mask_true_count = 0;
3170 gfc_constructor *mask_ctor = mask->value.constructor;
3173 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
3175 mask_true_count = 0;
3179 if (mask_ctor->expr->value.logical)
3182 mask_ctor = mask_ctor->next;
3185 if (mpz_get_si (vector_size) < mask_true_count)
3187 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3188 "provide at least as many elements as there "
3189 "are .TRUE. values in '%s' (%ld/%d)",
3190 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3191 &vector->where, gfc_current_intrinsic_arg[1],
3192 mpz_get_si (vector_size), mask_true_count);
3196 mpz_clear (vector_size);
3199 if (mask->rank != field->rank && field->rank != 0)
3201 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
3202 "the same rank as '%s' or be a scalar",
3203 gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
3204 &field->where, gfc_current_intrinsic_arg[1]);
3208 if (mask->rank == field->rank)
3211 for (i = 0; i < field->rank; i++)
3212 if (! identical_dimen_shape (mask, i, field, i))
3214 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
3215 "must have identical shape.",
3216 gfc_current_intrinsic_arg[2],
3217 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3227 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3229 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3232 if (same_type_check (x, 0, y, 1) == FAILURE)
3235 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3238 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3240 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3241 "with KIND argument at %L",
3242 gfc_current_intrinsic, &kind->where) == FAILURE)
3250 gfc_check_trim (gfc_expr *x)
3252 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3255 if (scalar_check (x, 0) == FAILURE)
3263 gfc_check_ttynam (gfc_expr *unit)
3265 if (scalar_check (unit, 0) == FAILURE)
3268 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3275 /* Common check function for the half a dozen intrinsics that have a
3276 single real argument. */
3279 gfc_check_x (gfc_expr *x)
3281 if (type_check (x, 0, BT_REAL) == FAILURE)
3288 /************* Check functions for intrinsic subroutines *************/
3291 gfc_check_cpu_time (gfc_expr *time)
3293 if (scalar_check (time, 0) == FAILURE)
3296 if (type_check (time, 0, BT_REAL) == FAILURE)
3299 if (variable_check (time, 0) == FAILURE)
3307 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
3308 gfc_expr *zone, gfc_expr *values)
3312 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3314 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3316 if (scalar_check (date, 0) == FAILURE)
3318 if (variable_check (date, 0) == FAILURE)
3324 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
3326 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
3328 if (scalar_check (time, 1) == FAILURE)
3330 if (variable_check (time, 1) == FAILURE)
3336 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
3338 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
3340 if (scalar_check (zone, 2) == FAILURE)
3342 if (variable_check (zone, 2) == FAILURE)
3348 if (type_check (values, 3, BT_INTEGER) == FAILURE)
3350 if (array_check (values, 3) == FAILURE)
3352 if (rank_check (values, 3, 1) == FAILURE)
3354 if (variable_check (values, 3) == FAILURE)
3363 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
3364 gfc_expr *to, gfc_expr *topos)
3366 if (type_check (from, 0, BT_INTEGER) == FAILURE)
3369 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
3372 if (type_check (len, 2, BT_INTEGER) == FAILURE)
3375 if (same_type_check (from, 0, to, 3) == FAILURE)
3378 if (variable_check (to, 3) == FAILURE)
3381 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
3389 gfc_check_random_number (gfc_expr *harvest)
3391 if (type_check (harvest, 0, BT_REAL) == FAILURE)
3394 if (variable_check (harvest, 0) == FAILURE)
3402 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
3404 unsigned int nargs = 0, kiss_size;
3405 locus *where = NULL;
3406 mpz_t put_size, get_size;
3407 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
3409 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
3411 /* Keep the number of bytes in sync with kiss_size in
3412 libgfortran/intrinsics/random.c. */
3413 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
3417 if (size->expr_type != EXPR_VARIABLE
3418 || !size->symtree->n.sym->attr.optional)
3421 if (scalar_check (size, 0) == FAILURE)
3424 if (type_check (size, 0, BT_INTEGER) == FAILURE)
3427 if (variable_check (size, 0) == FAILURE)
3430 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3436 if (put->expr_type != EXPR_VARIABLE
3437 || !put->symtree->n.sym->attr.optional)
3440 where = &put->where;
3443 if (array_check (put, 1) == FAILURE)
3446 if (rank_check (put, 1, 1) == FAILURE)
3449 if (type_check (put, 1, BT_INTEGER) == FAILURE)
3452 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3455 if (gfc_array_size (put, &put_size) == SUCCESS
3456 && mpz_get_ui (put_size) < kiss_size)
3457 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3458 "too small (%i/%i)",
3459 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
3460 (int) mpz_get_ui (put_size), kiss_size);
3465 if (get->expr_type != EXPR_VARIABLE
3466 || !get->symtree->n.sym->attr.optional)
3469 where = &get->where;
3472 if (array_check (get, 2) == FAILURE)
3475 if (rank_check (get, 2, 1) == FAILURE)
3478 if (type_check (get, 2, BT_INTEGER) == FAILURE)
3481 if (variable_check (get, 2) == FAILURE)
3484 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3487 if (gfc_array_size (get, &get_size) == SUCCESS
3488 && mpz_get_ui (get_size) < kiss_size)
3489 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3490 "too small (%i/%i)",
3491 gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
3492 (int) mpz_get_ui (get_size), kiss_size);
3495 /* RANDOM_SEED may not have more than one non-optional argument. */
3497 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3504 gfc_check_second_sub (gfc_expr *time)
3506 if (scalar_check (time, 0) == FAILURE)
3509 if (type_check (time, 0, BT_REAL) == FAILURE)
3512 if (kind_value_check(time, 0, 4) == FAILURE)
3519 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3520 count, count_rate, and count_max are all optional arguments */
3523 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3524 gfc_expr *count_max)
3528 if (scalar_check (count, 0) == FAILURE)
3531 if (type_check (count, 0, BT_INTEGER) == FAILURE)
3534 if (variable_check (count, 0) == FAILURE)
3538 if (count_rate != NULL)
3540 if (scalar_check (count_rate, 1) == FAILURE)
3543 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3546 if (variable_check (count_rate, 1) == FAILURE)
3550 && same_type_check (count, 0, count_rate, 1) == FAILURE)
3555 if (count_max != NULL)
3557 if (scalar_check (count_max, 2) == FAILURE)
3560 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3563 if (variable_check (count_max, 2) == FAILURE)
3567 && same_type_check (count, 0, count_max, 2) == FAILURE)
3570 if (count_rate != NULL
3571 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3580 gfc_check_irand (gfc_expr *x)
3585 if (scalar_check (x, 0) == FAILURE)
3588 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3591 if (kind_value_check(x, 0, 4) == FAILURE)
3599 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3601 if (scalar_check (seconds, 0) == FAILURE)
3604 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3607 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3609 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3610 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3611 gfc_current_intrinsic, &handler->where);
3615 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3621 if (scalar_check (status, 2) == FAILURE)
3624 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3627 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3635 gfc_check_rand (gfc_expr *x)
3640 if (scalar_check (x, 0) == FAILURE)
3643 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3646 if (kind_value_check(x, 0, 4) == FAILURE)
3654 gfc_check_srand (gfc_expr *x)
3656 if (scalar_check (x, 0) == FAILURE)
3659 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3662 if (kind_value_check(x, 0, 4) == FAILURE)
3670 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3672 if (scalar_check (time, 0) == FAILURE)
3674 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3677 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3679 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
3687 gfc_check_dtime_etime (gfc_expr *x)
3689 if (array_check (x, 0) == FAILURE)
3692 if (rank_check (x, 0, 1) == FAILURE)
3695 if (variable_check (x, 0) == FAILURE)
3698 if (type_check (x, 0, BT_REAL) == FAILURE)
3701 if (kind_value_check(x, 0, 4) == FAILURE)
3709 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3711 if (array_check (values, 0) == FAILURE)
3714 if (rank_check (values, 0, 1) == FAILURE)
3717 if (variable_check (values, 0) == FAILURE)
3720 if (type_check (values, 0, BT_REAL) == FAILURE)
3723 if (kind_value_check(values, 0, 4) == FAILURE)
3726 if (scalar_check (time, 1) == FAILURE)
3729 if (type_check (time, 1, BT_REAL) == FAILURE)
3732 if (kind_value_check(time, 1, 4) == FAILURE)
3740 gfc_check_fdate_sub (gfc_expr *date)
3742 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3744 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3752 gfc_check_gerror (gfc_expr *msg)
3754 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3756 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3764 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3766 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3768 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
3774 if (scalar_check (status, 1) == FAILURE)
3777 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3785 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
3787 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
3790 if (pos->ts.kind > gfc_default_integer_kind)
3792 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3793 "not wider than the default kind (%d)",
3794 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3795 &pos->where, gfc_default_integer_kind);
3799 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
3801 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
3809 gfc_check_getlog (gfc_expr *msg)
3811 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3813 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3821 gfc_check_exit (gfc_expr *status)
3826 if (type_check (status, 0, BT_INTEGER) == FAILURE)
3829 if (scalar_check (status, 0) == FAILURE)
3837 gfc_check_flush (gfc_expr *unit)
3842 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3845 if (scalar_check (unit, 0) == FAILURE)
3853 gfc_check_free (gfc_expr *i)
3855 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3858 if (scalar_check (i, 0) == FAILURE)
3866 gfc_check_hostnm (gfc_expr *name)
3868 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3870 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3878 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3880 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3882 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3888 if (scalar_check (status, 1) == FAILURE)
3891 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3899 gfc_check_itime_idate (gfc_expr *values)
3901 if (array_check (values, 0) == FAILURE)
3904 if (rank_check (values, 0, 1) == FAILURE)
3907 if (variable_check (values, 0) == FAILURE)
3910 if (type_check (values, 0, BT_INTEGER) == FAILURE)
3913 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3921 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3923 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3926 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3929 if (scalar_check (time, 0) == FAILURE)
3932 if (array_check (values, 1) == FAILURE)
3935 if (rank_check (values, 1, 1) == FAILURE)
3938 if (variable_check (values, 1) == FAILURE)
3941 if (type_check (values, 1, BT_INTEGER) == FAILURE)
3944 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3952 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3954 if (scalar_check (unit, 0) == FAILURE)
3957 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3960 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3962 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
3970 gfc_check_isatty (gfc_expr *unit)
3975 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3978 if (scalar_check (unit, 0) == FAILURE)
3986 gfc_check_isnan (gfc_expr *x)
3988 if (type_check (x, 0, BT_REAL) == FAILURE)
3996 gfc_check_perror (gfc_expr *string)
3998 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
4000 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
4008 gfc_check_umask (gfc_expr *mask)
4010 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4013 if (scalar_check (mask, 0) == FAILURE)
4021 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
4023 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4026 if (scalar_check (mask, 0) == FAILURE)
4032 if (scalar_check (old, 1) == FAILURE)
4035 if (type_check (old, 1, BT_INTEGER) == FAILURE)
4043 gfc_check_unlink (gfc_expr *name)
4045 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4047 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4055 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
4057 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4059 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4065 if (scalar_check (status, 1) == FAILURE)
4068 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4076 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
4078 if (scalar_check (number, 0) == FAILURE)
4081 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4084 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4086 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4087 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4088 gfc_current_intrinsic, &handler->where);
4092 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4100 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
4102 if (scalar_check (number, 0) == FAILURE)
4105 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4108 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4110 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4111 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4112 gfc_current_intrinsic, &handler->where);
4116 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4122 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4125 if (scalar_check (status, 2) == FAILURE)
4133 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
4135 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
4137 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
4140 if (scalar_check (status, 1) == FAILURE)
4143 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4146 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
4153 /* This is used for the GNU intrinsics AND, OR and XOR. */
4155 gfc_check_and (gfc_expr *i, gfc_expr *j)
4157 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
4159 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4160 "or LOGICAL", gfc_current_intrinsic_arg[0],
4161 gfc_current_intrinsic, &i->where);
4165 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
4167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4168 "or LOGICAL", gfc_current_intrinsic_arg[1],
4169 gfc_current_intrinsic, &j->where);
4173 if (i->ts.type != j->ts.type)
4175 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
4176 "have the same type", gfc_current_intrinsic_arg[0],
4177 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
4182 if (scalar_check (i, 0) == FAILURE)
4185 if (scalar_check (j, 1) == FAILURE)