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)
530 gfc_check_allocated (gfc_expr *array)
532 symbol_attribute attr;
534 if (variable_check (array, 0) == FAILURE)
537 attr = gfc_variable_attr (array, NULL);
538 if (!attr.allocatable)
540 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
541 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
546 if (array_check (array, 0) == FAILURE)
553 /* Common check function where the first argument must be real or
554 integer and the second argument must be the same as the first. */
557 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
559 if (int_or_real_check (a, 0) == FAILURE)
562 if (a->ts.type != p->ts.type)
564 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
565 "have the same type", gfc_current_intrinsic_arg[0],
566 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
571 if (a->ts.kind != p->ts.kind)
573 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
574 &p->where) == FAILURE)
583 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
585 if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
593 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
595 symbol_attribute attr1, attr2;
600 where = &pointer->where;
602 if (pointer->expr_type == EXPR_VARIABLE)
603 attr1 = gfc_variable_attr (pointer, NULL);
604 else if (pointer->expr_type == EXPR_FUNCTION)
605 attr1 = pointer->symtree->n.sym->attr;
606 else if (pointer->expr_type == EXPR_NULL)
609 gcc_assert (0); /* Pointer must be a variable or a function. */
611 if (!attr1.pointer && !attr1.proc_pointer)
613 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
614 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
619 /* Target argument is optional. */
623 where = &target->where;
624 if (target->expr_type == EXPR_NULL)
627 if (target->expr_type == EXPR_VARIABLE)
628 attr2 = gfc_variable_attr (target, NULL);
629 else if (target->expr_type == EXPR_FUNCTION)
630 attr2 = target->symtree->n.sym->attr;
633 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
634 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
635 gfc_current_intrinsic, &target->where);
639 if (attr1.pointer && !attr2.pointer && !attr2.target)
641 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
642 "or a TARGET", gfc_current_intrinsic_arg[1],
643 gfc_current_intrinsic, &target->where);
648 if (same_type_check (pointer, 0, target, 1) == FAILURE)
650 if (rank_check (target, 0, pointer->rank) == FAILURE)
652 if (target->rank > 0)
654 for (i = 0; i < target->rank; i++)
655 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
657 gfc_error ("Array section with a vector subscript at %L shall not "
658 "be the target of a pointer",
668 gfc_error ("NULL pointer at %L is not permitted as actual argument "
669 "of '%s' intrinsic function", where, gfc_current_intrinsic);
676 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
678 if (type_check (y, 0, BT_REAL) == FAILURE)
680 if (same_type_check (y, 0, x, 1) == FAILURE)
687 /* BESJN and BESYN functions. */
690 gfc_check_besn (gfc_expr *n, gfc_expr *x)
692 if (type_check (n, 0, BT_INTEGER) == FAILURE)
695 if (type_check (x, 1, BT_REAL) == FAILURE)
703 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
705 if (type_check (i, 0, BT_INTEGER) == FAILURE)
707 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
715 gfc_check_char (gfc_expr *i, gfc_expr *kind)
717 if (type_check (i, 0, BT_INTEGER) == FAILURE)
719 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
727 gfc_check_chdir (gfc_expr *dir)
729 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
731 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
739 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
741 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
743 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
749 if (type_check (status, 1, BT_INTEGER) == FAILURE)
751 if (scalar_check (status, 1) == FAILURE)
759 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
761 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
763 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
766 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
768 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
776 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
778 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
780 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
783 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
785 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
791 if (type_check (status, 2, BT_INTEGER) == FAILURE)
794 if (scalar_check (status, 2) == FAILURE)
802 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
804 if (numeric_check (x, 0) == FAILURE)
809 if (numeric_check (y, 1) == FAILURE)
812 if (x->ts.type == BT_COMPLEX)
814 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
815 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
816 gfc_current_intrinsic, &y->where);
821 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
829 gfc_check_complex (gfc_expr *x, gfc_expr *y)
831 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
833 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
834 "or REAL", gfc_current_intrinsic_arg[0],
835 gfc_current_intrinsic, &x->where);
838 if (scalar_check (x, 0) == FAILURE)
841 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
843 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
844 "or REAL", gfc_current_intrinsic_arg[1],
845 gfc_current_intrinsic, &y->where);
848 if (scalar_check (y, 1) == FAILURE)
856 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
858 if (logical_array_check (mask, 0) == FAILURE)
860 if (dim_check (dim, 1, false) == FAILURE)
862 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
864 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
865 "with KIND argument at %L",
866 gfc_current_intrinsic, &kind->where) == FAILURE)
874 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
876 if (array_check (array, 0) == FAILURE)
879 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
882 if (dim_check (dim, 2, true) == FAILURE)
885 if (dim_rank_check (dim, array, false) == FAILURE)
888 if (array->rank == 1 || shift->rank == 0)
890 if (scalar_check (shift, 1) == FAILURE)
893 else if (shift->rank == array->rank - 1)
898 else if (dim->expr_type == EXPR_CONSTANT)
899 gfc_extract_int (dim, &d);
906 for (i = 0, j = 0; i < array->rank; i++)
909 if (!identical_dimen_shape (array, i, shift, j))
911 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
912 "invalid shape in dimension %d (%ld/%ld)",
913 gfc_current_intrinsic_arg[1],
914 gfc_current_intrinsic, &shift->where, i + 1,
915 mpz_get_si (array->shape[i]),
916 mpz_get_si (shift->shape[j]));
926 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
927 "%d or be a scalar", gfc_current_intrinsic_arg[1],
928 gfc_current_intrinsic, &shift->where, array->rank - 1);
937 gfc_check_ctime (gfc_expr *time)
939 if (scalar_check (time, 0) == FAILURE)
942 if (type_check (time, 0, BT_INTEGER) == FAILURE)
949 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
951 if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
958 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
960 if (numeric_check (x, 0) == FAILURE)
965 if (numeric_check (y, 1) == FAILURE)
968 if (x->ts.type == BT_COMPLEX)
970 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
971 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
972 gfc_current_intrinsic, &y->where);
982 gfc_check_dble (gfc_expr *x)
984 if (numeric_check (x, 0) == FAILURE)
992 gfc_check_digits (gfc_expr *x)
994 if (int_or_real_check (x, 0) == FAILURE)
1002 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1004 switch (vector_a->ts.type)
1007 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1014 if (numeric_check (vector_b, 1) == FAILURE)
1019 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1020 "or LOGICAL", gfc_current_intrinsic_arg[0],
1021 gfc_current_intrinsic, &vector_a->where);
1025 if (rank_check (vector_a, 0, 1) == FAILURE)
1028 if (rank_check (vector_b, 1, 1) == FAILURE)
1031 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1033 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1034 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
1035 gfc_current_intrinsic_arg[1], &vector_a->where);
1044 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1046 if (type_check (x, 0, BT_REAL) == FAILURE
1047 || type_check (y, 1, BT_REAL) == FAILURE)
1050 if (x->ts.kind != gfc_default_real_kind)
1052 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1053 "real", gfc_current_intrinsic_arg[0],
1054 gfc_current_intrinsic, &x->where);
1058 if (y->ts.kind != gfc_default_real_kind)
1060 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1061 "real", gfc_current_intrinsic_arg[1],
1062 gfc_current_intrinsic, &y->where);
1071 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1074 if (array_check (array, 0) == FAILURE)
1077 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1080 if (dim_check (dim, 3, true) == FAILURE)
1083 if (dim_rank_check (dim, array, false) == FAILURE)
1086 if (array->rank == 1 || shift->rank == 0)
1088 if (scalar_check (shift, 1) == FAILURE)
1091 else if (shift->rank == array->rank - 1)
1096 else if (dim->expr_type == EXPR_CONSTANT)
1097 gfc_extract_int (dim, &d);
1104 for (i = 0, j = 0; i < array->rank; i++)
1107 if (!identical_dimen_shape (array, i, shift, j))
1109 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1110 "invalid shape in dimension %d (%ld/%ld)",
1111 gfc_current_intrinsic_arg[1],
1112 gfc_current_intrinsic, &shift->where, i + 1,
1113 mpz_get_si (array->shape[i]),
1114 mpz_get_si (shift->shape[j]));
1124 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1125 "%d or be a scalar", gfc_current_intrinsic_arg[1],
1126 gfc_current_intrinsic, &shift->where, array->rank - 1);
1130 if (boundary != NULL)
1132 if (same_type_check (array, 0, boundary, 2) == FAILURE)
1135 if (array->rank == 1 || boundary->rank == 0)
1137 if (scalar_check (boundary, 2) == FAILURE)
1140 else if (boundary->rank == array->rank - 1)
1142 if (gfc_check_conformance (shift, boundary,
1143 "arguments '%s' and '%s' for "
1145 gfc_current_intrinsic_arg[1],
1146 gfc_current_intrinsic_arg[2],
1147 gfc_current_intrinsic ) == FAILURE)
1152 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1153 "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
1154 gfc_current_intrinsic, &shift->where, array->rank - 1);
1163 /* A single complex argument. */
1166 gfc_check_fn_c (gfc_expr *a)
1168 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1175 /* A single real argument. */
1178 gfc_check_fn_r (gfc_expr *a)
1180 if (type_check (a, 0, BT_REAL) == FAILURE)
1186 /* A single double argument. */
1189 gfc_check_fn_d (gfc_expr *a)
1191 if (double_check (a, 0) == FAILURE)
1197 /* A single real or complex argument. */
1200 gfc_check_fn_rc (gfc_expr *a)
1202 if (real_or_complex_check (a, 0) == FAILURE)
1210 gfc_check_fnum (gfc_expr *unit)
1212 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1215 if (scalar_check (unit, 0) == FAILURE)
1223 gfc_check_huge (gfc_expr *x)
1225 if (int_or_real_check (x, 0) == FAILURE)
1233 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1235 if (type_check (x, 0, BT_REAL) == FAILURE)
1237 if (same_type_check (x, 0, y, 1) == FAILURE)
1244 /* Check that the single argument is an integer. */
1247 gfc_check_i (gfc_expr *i)
1249 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1257 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1259 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1262 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1265 if (i->ts.kind != j->ts.kind)
1267 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1268 &i->where) == FAILURE)
1277 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1279 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1282 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1290 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1292 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1295 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1298 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1306 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1308 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1311 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1319 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1323 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1326 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1329 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1330 "with KIND argument at %L",
1331 gfc_current_intrinsic, &kind->where) == FAILURE)
1334 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1340 /* Substring references don't have the charlength set. */
1342 while (ref && ref->type != REF_SUBSTRING)
1345 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1349 /* Check that the argument is length one. Non-constant lengths
1350 can't be checked here, so assume they are ok. */
1351 if (c->ts.cl && c->ts.cl->length)
1353 /* If we already have a length for this expression then use it. */
1354 if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1356 i = mpz_get_si (c->ts.cl->length->value.integer);
1363 start = ref->u.ss.start;
1364 end = ref->u.ss.end;
1367 if (end == NULL || end->expr_type != EXPR_CONSTANT
1368 || start->expr_type != EXPR_CONSTANT)
1371 i = mpz_get_si (end->value.integer) + 1
1372 - mpz_get_si (start->value.integer);
1380 gfc_error ("Argument of %s at %L must be of length one",
1381 gfc_current_intrinsic, &c->where);
1390 gfc_check_idnint (gfc_expr *a)
1392 if (double_check (a, 0) == FAILURE)
1400 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1402 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1405 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1408 if (i->ts.kind != j->ts.kind)
1410 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1411 &i->where) == FAILURE)
1420 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1423 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1424 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1427 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1430 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1432 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1433 "with KIND argument at %L",
1434 gfc_current_intrinsic, &kind->where) == FAILURE)
1437 if (string->ts.kind != substring->ts.kind)
1439 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1440 "kind as '%s'", gfc_current_intrinsic_arg[1],
1441 gfc_current_intrinsic, &substring->where,
1442 gfc_current_intrinsic_arg[0]);
1451 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1453 if (numeric_check (x, 0) == FAILURE)
1456 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1464 gfc_check_intconv (gfc_expr *x)
1466 if (numeric_check (x, 0) == FAILURE)
1474 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1476 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1479 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1482 if (i->ts.kind != j->ts.kind)
1484 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1485 &i->where) == FAILURE)
1494 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1496 if (type_check (i, 0, BT_INTEGER) == FAILURE
1497 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1505 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1507 if (type_check (i, 0, BT_INTEGER) == FAILURE
1508 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1511 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1519 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1521 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1524 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1532 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1534 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1537 if (scalar_check (pid, 0) == FAILURE)
1540 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1543 if (scalar_check (sig, 1) == FAILURE)
1549 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1552 if (scalar_check (status, 2) == FAILURE)
1560 gfc_check_kind (gfc_expr *x)
1562 if (x->ts.type == BT_DERIVED)
1564 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1565 "non-derived type", gfc_current_intrinsic_arg[0],
1566 gfc_current_intrinsic, &x->where);
1575 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1577 if (array_check (array, 0) == FAILURE)
1580 if (dim_check (dim, 1, false) == FAILURE)
1583 if (dim_rank_check (dim, array, 1) == FAILURE)
1586 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1588 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1589 "with KIND argument at %L",
1590 gfc_current_intrinsic, &kind->where) == FAILURE)
1598 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
1600 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
1603 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1605 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1606 "with KIND argument at %L",
1607 gfc_current_intrinsic, &kind->where) == FAILURE)
1615 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
1617 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1619 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
1622 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
1624 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
1632 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1634 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1636 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1639 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1641 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1649 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1651 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1653 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1656 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1658 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
1664 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1667 if (scalar_check (status, 2) == FAILURE)
1675 gfc_check_loc (gfc_expr *expr)
1677 return variable_check (expr, 0);
1682 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1684 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1686 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1689 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1691 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1699 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1701 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1703 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
1706 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1708 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
1714 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1717 if (scalar_check (status, 2) == FAILURE)
1725 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1727 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1729 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1736 /* Min/max family. */
1739 min_max_args (gfc_actual_arglist *arg)
1741 if (arg == NULL || arg->next == NULL)
1743 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1744 gfc_current_intrinsic, gfc_current_intrinsic_where);
1753 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
1755 gfc_actual_arglist *arg, *tmp;
1760 if (min_max_args (arglist) == FAILURE)
1763 for (arg = arglist, n=1; arg; arg = arg->next, n++)
1766 if (x->ts.type != type || x->ts.kind != kind)
1768 if (x->ts.type == type)
1770 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1771 "kinds at %L", &x->where) == FAILURE)
1776 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1777 "%s(%d)", n, gfc_current_intrinsic, &x->where,
1778 gfc_basic_typename (type), kind);
1783 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
1784 if (gfc_check_conformance (tmp->expr, x,
1785 "arguments 'a%d' and 'a%d' for "
1786 "intrinsic '%s'", m, n,
1787 gfc_current_intrinsic) == FAILURE)
1796 gfc_check_min_max (gfc_actual_arglist *arg)
1800 if (min_max_args (arg) == FAILURE)
1805 if (x->ts.type == BT_CHARACTER)
1807 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1808 "with CHARACTER argument at %L",
1809 gfc_current_intrinsic, &x->where) == FAILURE)
1812 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1814 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1815 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
1819 return check_rest (x->ts.type, x->ts.kind, arg);
1824 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1826 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1831 gfc_check_min_max_real (gfc_actual_arglist *arg)
1833 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1838 gfc_check_min_max_double (gfc_actual_arglist *arg)
1840 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1844 /* End of min/max family. */
1847 gfc_check_malloc (gfc_expr *size)
1849 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1852 if (scalar_check (size, 0) == FAILURE)
1860 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1862 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1864 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1865 "or LOGICAL", gfc_current_intrinsic_arg[0],
1866 gfc_current_intrinsic, &matrix_a->where);
1870 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1872 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1873 "or LOGICAL", gfc_current_intrinsic_arg[1],
1874 gfc_current_intrinsic, &matrix_b->where);
1878 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
1879 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
1881 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
1882 gfc_current_intrinsic, &matrix_a->where,
1883 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
1887 switch (matrix_a->rank)
1890 if (rank_check (matrix_b, 1, 2) == FAILURE)
1892 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1893 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1895 gfc_error ("Different shape on dimension 1 for arguments '%s' "
1896 "and '%s' at %L for intrinsic matmul",
1897 gfc_current_intrinsic_arg[0],
1898 gfc_current_intrinsic_arg[1], &matrix_a->where);
1904 if (matrix_b->rank != 2)
1906 if (rank_check (matrix_b, 1, 1) == FAILURE)
1909 /* matrix_b has rank 1 or 2 here. Common check for the cases
1910 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1911 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1912 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1914 gfc_error ("Different shape on dimension 2 for argument '%s' and "
1915 "dimension 1 for argument '%s' at %L for intrinsic "
1916 "matmul", gfc_current_intrinsic_arg[0],
1917 gfc_current_intrinsic_arg[1], &matrix_a->where);
1923 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1924 "1 or 2", gfc_current_intrinsic_arg[0],
1925 gfc_current_intrinsic, &matrix_a->where);
1933 /* Whoever came up with this interface was probably on something.
1934 The possibilities for the occupation of the second and third
1941 NULL MASK minloc(array, mask=m)
1944 I.e. in the case of minloc(array,mask), mask will be in the second
1945 position of the argument list and we'll have to fix that up. */
1948 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1950 gfc_expr *a, *m, *d;
1953 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1957 m = ap->next->next->expr;
1959 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1960 && ap->next->name == NULL)
1964 ap->next->expr = NULL;
1965 ap->next->next->expr = m;
1968 if (dim_check (d, 1, false) == FAILURE)
1971 if (dim_rank_check (d, a, 0) == FAILURE)
1974 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1978 && gfc_check_conformance (a, m,
1979 "arguments '%s' and '%s' for intrinsic %s",
1980 gfc_current_intrinsic_arg[0],
1981 gfc_current_intrinsic_arg[2],
1982 gfc_current_intrinsic ) == FAILURE)
1989 /* Similar to minloc/maxloc, the argument list might need to be
1990 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1991 difference is that MINLOC/MAXLOC take an additional KIND argument.
1992 The possibilities are:
1998 NULL MASK minval(array, mask=m)
2001 I.e. in the case of minval(array,mask), mask will be in the second
2002 position of the argument list and we'll have to fix that up. */
2005 check_reduction (gfc_actual_arglist *ap)
2007 gfc_expr *a, *m, *d;
2011 m = ap->next->next->expr;
2013 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2014 && ap->next->name == NULL)
2018 ap->next->expr = NULL;
2019 ap->next->next->expr = m;
2022 if (dim_check (d, 1, false) == FAILURE)
2025 if (dim_rank_check (d, a, 0) == FAILURE)
2028 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2032 && gfc_check_conformance (a, m,
2033 "arguments '%s' and '%s' for intrinsic %s",
2034 gfc_current_intrinsic_arg[0],
2035 gfc_current_intrinsic_arg[2],
2036 gfc_current_intrinsic) == FAILURE)
2044 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2046 if (int_or_real_check (ap->expr, 0) == FAILURE
2047 || array_check (ap->expr, 0) == FAILURE)
2050 return check_reduction (ap);
2055 gfc_check_product_sum (gfc_actual_arglist *ap)
2057 if (numeric_check (ap->expr, 0) == FAILURE
2058 || array_check (ap->expr, 0) == FAILURE)
2061 return check_reduction (ap);
2066 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2068 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2071 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2074 if (tsource->ts.type == BT_CHARACTER)
2075 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2082 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2084 symbol_attribute attr;
2086 if (variable_check (from, 0) == FAILURE)
2089 if (array_check (from, 0) == FAILURE)
2092 attr = gfc_variable_attr (from, NULL);
2093 if (!attr.allocatable)
2095 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2096 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2101 if (variable_check (to, 0) == FAILURE)
2104 if (array_check (to, 0) == FAILURE)
2107 attr = gfc_variable_attr (to, NULL);
2108 if (!attr.allocatable)
2110 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
2111 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
2116 if (same_type_check (from, 0, to, 1) == FAILURE)
2119 if (to->rank != from->rank)
2121 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2122 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
2123 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2124 &to->where, from->rank, to->rank);
2128 if (to->ts.kind != from->ts.kind)
2130 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2131 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
2132 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2133 &to->where, from->ts.kind, to->ts.kind);
2142 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2144 if (type_check (x, 0, BT_REAL) == FAILURE)
2147 if (type_check (s, 1, BT_REAL) == FAILURE)
2155 gfc_check_new_line (gfc_expr *a)
2157 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2165 gfc_check_null (gfc_expr *mold)
2167 symbol_attribute attr;
2172 if (variable_check (mold, 0) == FAILURE)
2175 attr = gfc_variable_attr (mold, NULL);
2177 if (!attr.pointer && !attr.proc_pointer)
2179 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2180 gfc_current_intrinsic_arg[0],
2181 gfc_current_intrinsic, &mold->where);
2190 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2192 if (array_check (array, 0) == FAILURE)
2195 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2198 if (gfc_check_conformance (array, mask,
2199 "arguments '%s' and '%s' for intrinsic '%s'",
2200 gfc_current_intrinsic_arg[0],
2201 gfc_current_intrinsic_arg[1],
2202 gfc_current_intrinsic) == FAILURE)
2207 mpz_t array_size, vector_size;
2208 bool have_array_size, have_vector_size;
2210 if (same_type_check (array, 0, vector, 2) == FAILURE)
2213 if (rank_check (vector, 2, 1) == FAILURE)
2216 /* VECTOR requires at least as many elements as MASK
2217 has .TRUE. values. */
2218 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2219 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2221 if (have_vector_size
2222 && (mask->expr_type == EXPR_ARRAY
2223 || (mask->expr_type == EXPR_CONSTANT
2224 && have_array_size)))
2226 int mask_true_values = 0;
2228 if (mask->expr_type == EXPR_ARRAY)
2230 gfc_constructor *mask_ctor = mask->value.constructor;
2233 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2235 mask_true_values = 0;
2239 if (mask_ctor->expr->value.logical)
2242 mask_ctor = mask_ctor->next;
2245 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2246 mask_true_values = mpz_get_si (array_size);
2248 if (mpz_get_si (vector_size) < mask_true_values)
2250 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2251 "provide at least as many elements as there "
2252 "are .TRUE. values in '%s' (%ld/%d)",
2253 gfc_current_intrinsic_arg[2],gfc_current_intrinsic,
2254 &vector->where, gfc_current_intrinsic_arg[1],
2255 mpz_get_si (vector_size), mask_true_values);
2260 if (have_array_size)
2261 mpz_clear (array_size);
2262 if (have_vector_size)
2263 mpz_clear (vector_size);
2271 gfc_check_precision (gfc_expr *x)
2273 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
2275 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2276 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
2277 gfc_current_intrinsic, &x->where);
2286 gfc_check_present (gfc_expr *a)
2290 if (variable_check (a, 0) == FAILURE)
2293 sym = a->symtree->n.sym;
2294 if (!sym->attr.dummy)
2296 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2297 "dummy variable", gfc_current_intrinsic_arg[0],
2298 gfc_current_intrinsic, &a->where);
2302 if (!sym->attr.optional)
2304 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2305 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2306 gfc_current_intrinsic, &a->where);
2310 /* 13.14.82 PRESENT(A)
2312 Argument. A shall be the name of an optional dummy argument that is
2313 accessible in the subprogram in which the PRESENT function reference
2317 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2318 && a->ref->u.ar.type == AR_FULL))
2320 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2321 "subobject of '%s'", gfc_current_intrinsic_arg[0],
2322 gfc_current_intrinsic, &a->where, sym->name);
2331 gfc_check_radix (gfc_expr *x)
2333 if (int_or_real_check (x, 0) == FAILURE)
2341 gfc_check_range (gfc_expr *x)
2343 if (numeric_check (x, 0) == FAILURE)
2350 /* real, float, sngl. */
2352 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2354 if (numeric_check (a, 0) == FAILURE)
2357 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2365 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2367 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2369 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2372 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2374 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2382 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2384 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2386 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2389 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2391 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2397 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2400 if (scalar_check (status, 2) == FAILURE)
2408 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2410 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2413 if (scalar_check (x, 0) == FAILURE)
2416 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2419 if (scalar_check (y, 1) == FAILURE)
2427 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2428 gfc_expr *pad, gfc_expr *order)
2434 if (array_check (source, 0) == FAILURE)
2437 if (rank_check (shape, 1, 1) == FAILURE)
2440 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2443 if (gfc_array_size (shape, &size) != SUCCESS)
2445 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2446 "array of constant size", &shape->where);
2450 shape_size = mpz_get_ui (size);
2453 if (shape_size <= 0)
2455 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
2456 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
2460 else if (shape_size > GFC_MAX_DIMENSIONS)
2462 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2463 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2466 else if (shape->expr_type == EXPR_ARRAY)
2470 for (i = 0; i < shape_size; ++i)
2472 e = gfc_get_array_element (shape, i);
2473 if (e->expr_type != EXPR_CONSTANT)
2479 gfc_extract_int (e, &extent);
2482 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2483 "negative element (%d)", gfc_current_intrinsic_arg[1],
2484 gfc_current_intrinsic, &e->where, extent);
2494 if (same_type_check (source, 0, pad, 2) == FAILURE)
2497 if (array_check (pad, 2) == FAILURE)
2503 if (array_check (order, 3) == FAILURE)
2506 if (type_check (order, 3, BT_INTEGER) == FAILURE)
2509 if (order->expr_type == EXPR_ARRAY)
2511 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
2514 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
2517 gfc_array_size (order, &size);
2518 order_size = mpz_get_ui (size);
2521 if (order_size != shape_size)
2523 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2524 "has wrong number of elements (%d/%d)",
2525 gfc_current_intrinsic_arg[3],
2526 gfc_current_intrinsic, &order->where,
2527 order_size, shape_size);
2531 for (i = 1; i <= order_size; ++i)
2533 e = gfc_get_array_element (order, i-1);
2534 if (e->expr_type != EXPR_CONSTANT)
2540 gfc_extract_int (e, &dim);
2542 if (dim < 1 || dim > order_size)
2544 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2545 "has out-of-range dimension (%d)",
2546 gfc_current_intrinsic_arg[3],
2547 gfc_current_intrinsic, &e->where, dim);
2551 if (perm[dim-1] != 0)
2553 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2554 "invalid permutation of dimensions (dimension "
2555 "'%d' duplicated)", gfc_current_intrinsic_arg[3],
2556 gfc_current_intrinsic, &e->where, dim);
2566 if (pad == NULL && shape->expr_type == EXPR_ARRAY
2567 && gfc_is_constant_expr (shape)
2568 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2569 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2571 /* Check the match in size between source and destination. */
2572 if (gfc_array_size (source, &nelems) == SUCCESS)
2577 c = shape->value.constructor;
2578 mpz_init_set_ui (size, 1);
2579 for (; c; c = c->next)
2580 mpz_mul (size, size, c->expr->value.integer);
2582 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2588 gfc_error ("Without padding, there are not enough elements "
2589 "in the intrinsic RESHAPE source at %L to match "
2590 "the shape", &source->where);
2601 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2603 if (type_check (x, 0, BT_REAL) == FAILURE)
2606 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2614 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2616 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2619 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2622 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2625 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2627 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2628 "with KIND argument at %L",
2629 gfc_current_intrinsic, &kind->where) == FAILURE)
2632 if (same_type_check (x, 0, y, 1) == FAILURE)
2640 gfc_check_secnds (gfc_expr *r)
2642 if (type_check (r, 0, BT_REAL) == FAILURE)
2645 if (kind_value_check (r, 0, 4) == FAILURE)
2648 if (scalar_check (r, 0) == FAILURE)
2656 gfc_check_selected_char_kind (gfc_expr *name)
2658 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2661 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
2664 if (scalar_check (name, 0) == FAILURE)
2672 gfc_check_selected_int_kind (gfc_expr *r)
2674 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2677 if (scalar_check (r, 0) == FAILURE)
2685 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2687 if (p == NULL && r == NULL)
2689 gfc_error ("Missing arguments to %s intrinsic at %L",
2690 gfc_current_intrinsic, gfc_current_intrinsic_where);
2695 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2698 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2706 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2708 if (type_check (x, 0, BT_REAL) == FAILURE)
2711 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2719 gfc_check_shape (gfc_expr *source)
2723 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2726 ar = gfc_find_array_ref (source);
2728 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
2730 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2731 "an assumed size array", &source->where);
2740 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2742 if (int_or_real_check (a, 0) == FAILURE)
2745 if (same_type_check (a, 0, b, 1) == FAILURE)
2753 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2755 if (array_check (array, 0) == FAILURE)
2758 if (dim_check (dim, 1, true) == FAILURE)
2761 if (dim_rank_check (dim, array, 0) == FAILURE)
2764 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2766 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2767 "with KIND argument at %L",
2768 gfc_current_intrinsic, &kind->where) == FAILURE)
2777 gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
2784 gfc_check_sleep_sub (gfc_expr *seconds)
2786 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2789 if (scalar_check (seconds, 0) == FAILURE)
2797 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2799 if (source->rank >= GFC_MAX_DIMENSIONS)
2801 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2802 "than rank %d", gfc_current_intrinsic_arg[0],
2803 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2811 if (dim_check (dim, 1, false) == FAILURE)
2814 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2817 if (scalar_check (ncopies, 2) == FAILURE)
2824 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2828 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2830 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2833 if (scalar_check (unit, 0) == FAILURE)
2836 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2838 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
2844 if (type_check (status, 2, BT_INTEGER) == FAILURE
2845 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2846 || scalar_check (status, 2) == FAILURE)
2854 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2856 return gfc_check_fgetputc_sub (unit, c, NULL);
2861 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2863 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2865 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
2871 if (type_check (status, 1, BT_INTEGER) == FAILURE
2872 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2873 || scalar_check (status, 1) == FAILURE)
2881 gfc_check_fgetput (gfc_expr *c)
2883 return gfc_check_fgetput_sub (c, NULL);
2888 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2890 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2893 if (scalar_check (unit, 0) == FAILURE)
2896 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2899 if (scalar_check (offset, 1) == FAILURE)
2902 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2905 if (scalar_check (whence, 2) == FAILURE)
2911 if (type_check (status, 3, BT_INTEGER) == FAILURE)
2914 if (kind_value_check (status, 3, 4) == FAILURE)
2917 if (scalar_check (status, 3) == FAILURE)
2926 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2928 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2931 if (scalar_check (unit, 0) == FAILURE)
2934 if (type_check (array, 1, BT_INTEGER) == FAILURE
2935 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2938 if (array_check (array, 1) == FAILURE)
2946 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2948 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2951 if (scalar_check (unit, 0) == FAILURE)
2954 if (type_check (array, 1, BT_INTEGER) == FAILURE
2955 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2958 if (array_check (array, 1) == FAILURE)
2964 if (type_check (status, 2, BT_INTEGER) == FAILURE
2965 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2968 if (scalar_check (status, 2) == FAILURE)
2976 gfc_check_ftell (gfc_expr *unit)
2978 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2981 if (scalar_check (unit, 0) == FAILURE)
2989 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2991 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2994 if (scalar_check (unit, 0) == FAILURE)
2997 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3000 if (scalar_check (offset, 1) == FAILURE)
3008 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3010 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3012 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3015 if (type_check (array, 1, BT_INTEGER) == FAILURE
3016 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3019 if (array_check (array, 1) == FAILURE)
3027 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3029 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3031 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3034 if (type_check (array, 1, BT_INTEGER) == FAILURE
3035 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3038 if (array_check (array, 1) == FAILURE)
3044 if (type_check (status, 2, BT_INTEGER) == FAILURE
3045 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3048 if (scalar_check (status, 2) == FAILURE)
3056 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
3057 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
3059 if (mold->ts.type == BT_HOLLERITH)
3061 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3062 &mold->where, gfc_basic_typename (BT_HOLLERITH));
3068 if (type_check (size, 2, BT_INTEGER) == FAILURE)
3071 if (scalar_check (size, 2) == FAILURE)
3074 if (nonoptional_check (size, 2) == FAILURE)
3083 gfc_check_transpose (gfc_expr *matrix)
3085 if (rank_check (matrix, 0, 2) == FAILURE)
3093 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3095 if (array_check (array, 0) == FAILURE)
3098 if (dim_check (dim, 1, false) == FAILURE)
3101 if (dim_rank_check (dim, array, 0) == FAILURE)
3104 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3106 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3107 "with KIND argument at %L",
3108 gfc_current_intrinsic, &kind->where) == FAILURE)
3116 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
3118 if (rank_check (vector, 0, 1) == FAILURE)
3121 if (array_check (mask, 1) == FAILURE)
3124 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
3127 if (same_type_check (vector, 0, field, 2) == FAILURE)
3130 if (mask->rank != field->rank && field->rank != 0)
3132 gfc_error ("FIELD argument at %L of UNPACK must have the same rank as "
3133 "MASK or be a scalar", &field->where);
3137 if (mask->rank == field->rank)
3140 for (i = 0; i < field->rank; i++)
3141 if (! identical_dimen_shape (mask, i, field, i))
3143 gfc_error ("Different shape in dimension %d for MASK and FIELD "
3144 "arguments of UNPACK at %L", mask->rank, &field->where);
3154 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3156 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3159 if (same_type_check (x, 0, y, 1) == FAILURE)
3162 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3165 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3167 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3168 "with KIND argument at %L",
3169 gfc_current_intrinsic, &kind->where) == FAILURE)
3177 gfc_check_trim (gfc_expr *x)
3179 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3182 if (scalar_check (x, 0) == FAILURE)
3190 gfc_check_ttynam (gfc_expr *unit)
3192 if (scalar_check (unit, 0) == FAILURE)
3195 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3202 /* Common check function for the half a dozen intrinsics that have a
3203 single real argument. */
3206 gfc_check_x (gfc_expr *x)
3208 if (type_check (x, 0, BT_REAL) == FAILURE)
3215 /************* Check functions for intrinsic subroutines *************/
3218 gfc_check_cpu_time (gfc_expr *time)
3220 if (scalar_check (time, 0) == FAILURE)
3223 if (type_check (time, 0, BT_REAL) == FAILURE)
3226 if (variable_check (time, 0) == FAILURE)
3234 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
3235 gfc_expr *zone, gfc_expr *values)
3239 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3241 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3243 if (scalar_check (date, 0) == FAILURE)
3245 if (variable_check (date, 0) == FAILURE)
3251 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
3253 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
3255 if (scalar_check (time, 1) == FAILURE)
3257 if (variable_check (time, 1) == FAILURE)
3263 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
3265 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
3267 if (scalar_check (zone, 2) == FAILURE)
3269 if (variable_check (zone, 2) == FAILURE)
3275 if (type_check (values, 3, BT_INTEGER) == FAILURE)
3277 if (array_check (values, 3) == FAILURE)
3279 if (rank_check (values, 3, 1) == FAILURE)
3281 if (variable_check (values, 3) == FAILURE)
3290 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
3291 gfc_expr *to, gfc_expr *topos)
3293 if (type_check (from, 0, BT_INTEGER) == FAILURE)
3296 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
3299 if (type_check (len, 2, BT_INTEGER) == FAILURE)
3302 if (same_type_check (from, 0, to, 3) == FAILURE)
3305 if (variable_check (to, 3) == FAILURE)
3308 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
3316 gfc_check_random_number (gfc_expr *harvest)
3318 if (type_check (harvest, 0, BT_REAL) == FAILURE)
3321 if (variable_check (harvest, 0) == FAILURE)
3329 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
3331 unsigned int nargs = 0, kiss_size;
3332 locus *where = NULL;
3333 mpz_t put_size, get_size;
3334 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
3336 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
3338 /* Keep the number of bytes in sync with kiss_size in
3339 libgfortran/intrinsics/random.c. */
3340 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
3344 if (size->expr_type != EXPR_VARIABLE
3345 || !size->symtree->n.sym->attr.optional)
3348 if (scalar_check (size, 0) == FAILURE)
3351 if (type_check (size, 0, BT_INTEGER) == FAILURE)
3354 if (variable_check (size, 0) == FAILURE)
3357 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3363 if (put->expr_type != EXPR_VARIABLE
3364 || !put->symtree->n.sym->attr.optional)
3367 where = &put->where;
3370 if (array_check (put, 1) == FAILURE)
3373 if (rank_check (put, 1, 1) == FAILURE)
3376 if (type_check (put, 1, BT_INTEGER) == FAILURE)
3379 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3382 if (gfc_array_size (put, &put_size) == SUCCESS
3383 && mpz_get_ui (put_size) < kiss_size)
3384 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3385 "too small (%i/%i)",
3386 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
3387 (int) mpz_get_ui (put_size), kiss_size);
3392 if (get->expr_type != EXPR_VARIABLE
3393 || !get->symtree->n.sym->attr.optional)
3396 where = &get->where;
3399 if (array_check (get, 2) == FAILURE)
3402 if (rank_check (get, 2, 1) == FAILURE)
3405 if (type_check (get, 2, BT_INTEGER) == FAILURE)
3408 if (variable_check (get, 2) == FAILURE)
3411 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3414 if (gfc_array_size (get, &get_size) == SUCCESS
3415 && mpz_get_ui (get_size) < kiss_size)
3416 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3417 "too small (%i/%i)",
3418 gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
3419 (int) mpz_get_ui (get_size), kiss_size);
3422 /* RANDOM_SEED may not have more than one non-optional argument. */
3424 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3431 gfc_check_second_sub (gfc_expr *time)
3433 if (scalar_check (time, 0) == FAILURE)
3436 if (type_check (time, 0, BT_REAL) == FAILURE)
3439 if (kind_value_check(time, 0, 4) == FAILURE)
3446 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3447 count, count_rate, and count_max are all optional arguments */
3450 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3451 gfc_expr *count_max)
3455 if (scalar_check (count, 0) == FAILURE)
3458 if (type_check (count, 0, BT_INTEGER) == FAILURE)
3461 if (variable_check (count, 0) == FAILURE)
3465 if (count_rate != NULL)
3467 if (scalar_check (count_rate, 1) == FAILURE)
3470 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3473 if (variable_check (count_rate, 1) == FAILURE)
3477 && same_type_check (count, 0, count_rate, 1) == FAILURE)
3482 if (count_max != NULL)
3484 if (scalar_check (count_max, 2) == FAILURE)
3487 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3490 if (variable_check (count_max, 2) == FAILURE)
3494 && same_type_check (count, 0, count_max, 2) == FAILURE)
3497 if (count_rate != NULL
3498 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3507 gfc_check_irand (gfc_expr *x)
3512 if (scalar_check (x, 0) == FAILURE)
3515 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3518 if (kind_value_check(x, 0, 4) == FAILURE)
3526 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3528 if (scalar_check (seconds, 0) == FAILURE)
3531 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3534 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3536 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3537 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3538 gfc_current_intrinsic, &handler->where);
3542 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3548 if (scalar_check (status, 2) == FAILURE)
3551 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3554 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3562 gfc_check_rand (gfc_expr *x)
3567 if (scalar_check (x, 0) == FAILURE)
3570 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3573 if (kind_value_check(x, 0, 4) == FAILURE)
3581 gfc_check_srand (gfc_expr *x)
3583 if (scalar_check (x, 0) == FAILURE)
3586 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3589 if (kind_value_check(x, 0, 4) == FAILURE)
3597 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3599 if (scalar_check (time, 0) == FAILURE)
3601 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3604 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3606 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
3614 gfc_check_dtime_etime (gfc_expr *x)
3616 if (array_check (x, 0) == FAILURE)
3619 if (rank_check (x, 0, 1) == FAILURE)
3622 if (variable_check (x, 0) == FAILURE)
3625 if (type_check (x, 0, BT_REAL) == FAILURE)
3628 if (kind_value_check(x, 0, 4) == FAILURE)
3636 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3638 if (array_check (values, 0) == FAILURE)
3641 if (rank_check (values, 0, 1) == FAILURE)
3644 if (variable_check (values, 0) == FAILURE)
3647 if (type_check (values, 0, BT_REAL) == FAILURE)
3650 if (kind_value_check(values, 0, 4) == FAILURE)
3653 if (scalar_check (time, 1) == FAILURE)
3656 if (type_check (time, 1, BT_REAL) == FAILURE)
3659 if (kind_value_check(time, 1, 4) == FAILURE)
3667 gfc_check_fdate_sub (gfc_expr *date)
3669 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3671 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3679 gfc_check_gerror (gfc_expr *msg)
3681 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3683 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3691 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3693 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3695 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
3701 if (scalar_check (status, 1) == FAILURE)
3704 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3712 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
3714 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
3717 if (pos->ts.kind > gfc_default_integer_kind)
3719 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3720 "not wider than the default kind (%d)",
3721 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3722 &pos->where, gfc_default_integer_kind);
3726 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
3728 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
3736 gfc_check_getlog (gfc_expr *msg)
3738 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3740 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3748 gfc_check_exit (gfc_expr *status)
3753 if (type_check (status, 0, BT_INTEGER) == FAILURE)
3756 if (scalar_check (status, 0) == FAILURE)
3764 gfc_check_flush (gfc_expr *unit)
3769 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3772 if (scalar_check (unit, 0) == FAILURE)
3780 gfc_check_free (gfc_expr *i)
3782 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3785 if (scalar_check (i, 0) == FAILURE)
3793 gfc_check_hostnm (gfc_expr *name)
3795 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3797 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3805 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3807 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3809 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3815 if (scalar_check (status, 1) == FAILURE)
3818 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3826 gfc_check_itime_idate (gfc_expr *values)
3828 if (array_check (values, 0) == FAILURE)
3831 if (rank_check (values, 0, 1) == FAILURE)
3834 if (variable_check (values, 0) == FAILURE)
3837 if (type_check (values, 0, BT_INTEGER) == FAILURE)
3840 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3848 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3850 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3853 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3856 if (scalar_check (time, 0) == FAILURE)
3859 if (array_check (values, 1) == FAILURE)
3862 if (rank_check (values, 1, 1) == FAILURE)
3865 if (variable_check (values, 1) == FAILURE)
3868 if (type_check (values, 1, BT_INTEGER) == FAILURE)
3871 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3879 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3881 if (scalar_check (unit, 0) == FAILURE)
3884 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3887 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3889 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
3897 gfc_check_isatty (gfc_expr *unit)
3902 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3905 if (scalar_check (unit, 0) == FAILURE)
3913 gfc_check_isnan (gfc_expr *x)
3915 if (type_check (x, 0, BT_REAL) == FAILURE)
3923 gfc_check_perror (gfc_expr *string)
3925 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3927 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
3935 gfc_check_umask (gfc_expr *mask)
3937 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3940 if (scalar_check (mask, 0) == FAILURE)
3948 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3950 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3953 if (scalar_check (mask, 0) == FAILURE)
3959 if (scalar_check (old, 1) == FAILURE)
3962 if (type_check (old, 1, BT_INTEGER) == FAILURE)
3970 gfc_check_unlink (gfc_expr *name)
3972 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3974 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3982 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3984 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3986 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3992 if (scalar_check (status, 1) == FAILURE)
3995 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4003 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
4005 if (scalar_check (number, 0) == FAILURE)
4008 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4011 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4013 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4014 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4015 gfc_current_intrinsic, &handler->where);
4019 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4027 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
4029 if (scalar_check (number, 0) == FAILURE)
4032 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4035 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
4037 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4038 "or PROCEDURE", gfc_current_intrinsic_arg[1],
4039 gfc_current_intrinsic, &handler->where);
4043 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4049 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4052 if (scalar_check (status, 2) == FAILURE)
4060 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
4062 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
4064 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
4067 if (scalar_check (status, 1) == FAILURE)
4070 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4073 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
4080 /* This is used for the GNU intrinsics AND, OR and XOR. */
4082 gfc_check_and (gfc_expr *i, gfc_expr *j)
4084 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
4086 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4087 "or LOGICAL", gfc_current_intrinsic_arg[0],
4088 gfc_current_intrinsic, &i->where);
4092 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
4094 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4095 "or LOGICAL", gfc_current_intrinsic_arg[1],
4096 gfc_current_intrinsic, &j->where);
4100 if (i->ts.type != j->ts.type)
4102 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
4103 "have the same type", gfc_current_intrinsic_arg[0],
4104 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
4109 if (scalar_check (i, 0) == FAILURE)
4112 if (scalar_check (j, 1) == FAILURE)