2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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"
34 #include "constructor.h"
37 /* Make sure an expression is a scalar. */
40 scalar_check (gfc_expr *e, int n)
45 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
46 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
53 /* Check the type of an expression. */
56 type_check (gfc_expr *e, int n, bt type)
58 if (e->ts.type == type)
61 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
62 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
63 &e->where, gfc_basic_typename (type));
69 /* Check that the expression is a numeric type. */
72 numeric_check (gfc_expr *e, int n)
74 if (gfc_numeric_ts (&e->ts))
77 /* If the expression has not got a type, check if its namespace can
78 offer a default type. */
79 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
80 && e->symtree->n.sym->ts.type == BT_UNKNOWN
81 && gfc_set_default_type (e->symtree->n.sym, 0,
82 e->symtree->n.sym->ns) == SUCCESS
83 && gfc_numeric_ts (&e->symtree->n.sym->ts))
85 e->ts = e->symtree->n.sym->ts;
89 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
90 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
97 /* Check that an expression is integer or real. */
100 int_or_real_check (gfc_expr *e, int n)
102 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
104 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
105 "or REAL", gfc_current_intrinsic_arg[n]->name,
106 gfc_current_intrinsic, &e->where);
114 /* Check that an expression is real or complex. */
117 real_or_complex_check (gfc_expr *e, int n)
119 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
121 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
122 "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
123 gfc_current_intrinsic, &e->where);
131 /* Check that an expression is INTEGER or PROCEDURE. */
134 int_or_proc_check (gfc_expr *e, int n)
136 if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
138 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
139 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
140 gfc_current_intrinsic, &e->where);
148 /* Check that the expression is an optional constant integer
149 and that it specifies a valid kind for that type. */
152 kind_check (gfc_expr *k, int n, bt type)
159 if (type_check (k, n, BT_INTEGER) == FAILURE)
162 if (scalar_check (k, n) == FAILURE)
165 if (k->expr_type != EXPR_CONSTANT)
167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
168 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
173 if (gfc_extract_int (k, &kind) != NULL
174 || gfc_validate_kind (type, kind, true) < 0)
176 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
185 /* Make sure the expression is a double precision real. */
188 double_check (gfc_expr *d, int n)
190 if (type_check (d, n, BT_REAL) == FAILURE)
193 if (d->ts.kind != gfc_default_double_kind)
195 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
196 "precision", gfc_current_intrinsic_arg[n]->name,
197 gfc_current_intrinsic, &d->where);
205 /* Check whether an expression is a coarray (without array designator). */
208 is_coarray (gfc_expr *e)
210 bool coarray = false;
213 if (e->expr_type != EXPR_VARIABLE)
216 coarray = e->symtree->n.sym->attr.codimension;
218 for (ref = e->ref; ref; ref = ref->next)
220 if (ref->type == REF_COMPONENT)
221 coarray = ref->u.c.component->attr.codimension;
222 else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
223 || ref->u.ar.codimen != 0)
232 coarray_check (gfc_expr *e, int n)
236 gfc_error ("Expected coarray variable as '%s' argument to the %s "
237 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
238 gfc_current_intrinsic, &e->where);
246 /* Make sure the expression is a logical array. */
249 logical_array_check (gfc_expr *array, int n)
251 if (array->ts.type != BT_LOGICAL || array->rank == 0)
253 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
254 "array", gfc_current_intrinsic_arg[n]->name,
255 gfc_current_intrinsic, &array->where);
263 /* Make sure an expression is an array. */
266 array_check (gfc_expr *e, int n)
271 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
272 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
279 /* If expr is a constant, then check to ensure that it is greater than
283 nonnegative_check (const char *arg, gfc_expr *expr)
287 if (expr->expr_type == EXPR_CONSTANT)
289 gfc_extract_int (expr, &i);
292 gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
301 /* If expr2 is constant, then check that the value is less than
302 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
305 less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
306 gfc_expr *expr2, bool or_equal)
310 if (expr2->expr_type == EXPR_CONSTANT)
312 gfc_extract_int (expr2, &i2);
313 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
316 if (i2 > gfc_integer_kinds[i3].bit_size)
318 gfc_error ("'%s' at %L must be less than "
319 "or equal to BIT_SIZE('%s')",
320 arg2, &expr2->where, arg1);
326 if (i2 >= gfc_integer_kinds[i3].bit_size)
328 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
329 arg2, &expr2->where, arg1);
339 /* If expr is constant, then check that the value is less than or equal
340 to the bit_size of the kind k. */
343 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
347 if (expr->expr_type != EXPR_CONSTANT)
350 i = gfc_validate_kind (BT_INTEGER, k, false);
351 gfc_extract_int (expr, &val);
353 if (val > gfc_integer_kinds[i].bit_size)
355 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
356 "INTEGER(KIND=%d)", arg, &expr->where, k);
364 /* If expr2 and expr3 are constants, then check that the value is less than
365 or equal to bit_size(expr1). */
368 less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
369 gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
373 if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
375 gfc_extract_int (expr2, &i2);
376 gfc_extract_int (expr3, &i3);
378 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
379 if (i2 > gfc_integer_kinds[i3].bit_size)
381 gfc_error ("'%s + %s' at %L must be less than or equal "
383 arg2, arg3, &expr2->where, arg1);
391 /* Make sure two expressions have the same type. */
394 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
396 if (gfc_compare_types (&e->ts, &f->ts))
399 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
400 "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
401 gfc_current_intrinsic, &f->where,
402 gfc_current_intrinsic_arg[n]->name);
408 /* Make sure that an expression has a certain (nonzero) rank. */
411 rank_check (gfc_expr *e, int n, int rank)
416 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
417 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
424 /* Make sure a variable expression is not an optional dummy argument. */
427 nonoptional_check (gfc_expr *e, int n)
429 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
431 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
432 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
436 /* TODO: Recursive check on nonoptional variables? */
442 /* Check for ALLOCATABLE attribute. */
445 allocatable_check (gfc_expr *e, int n)
447 symbol_attribute attr;
449 attr = gfc_variable_attr (e, NULL);
450 if (!attr.allocatable)
452 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
453 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
462 /* Check that an expression has a particular kind. */
465 kind_value_check (gfc_expr *e, int n, int k)
470 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
471 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
478 /* Make sure an expression is a variable. */
481 variable_check (gfc_expr *e, int n, bool allow_proc)
483 if (e->expr_type == EXPR_VARIABLE
484 && e->symtree->n.sym->attr.intent == INTENT_IN
485 && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
486 || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
488 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
489 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
494 if (e->expr_type == EXPR_VARIABLE
495 && e->symtree->n.sym->attr.flavor != FL_PARAMETER
497 || !e->symtree->n.sym->attr.function
498 || (e->symtree->n.sym == e->symtree->n.sym->result
499 && (e->symtree->n.sym == gfc_current_ns->proc_name
500 || (gfc_current_ns->parent
502 == gfc_current_ns->parent->proc_name)))))
505 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
506 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
512 /* Check the common DIM parameter for correctness. */
515 dim_check (gfc_expr *dim, int n, bool optional)
520 if (type_check (dim, n, BT_INTEGER) == FAILURE)
523 if (scalar_check (dim, n) == FAILURE)
526 if (!optional && nonoptional_check (dim, n) == FAILURE)
533 /* If a coarray DIM parameter is a constant, make sure that it is greater than
534 zero and less than or equal to the corank of the given array. */
537 dim_corank_check (gfc_expr *dim, gfc_expr *array)
542 gcc_assert (array->expr_type == EXPR_VARIABLE);
544 if (dim->expr_type != EXPR_CONSTANT)
547 ar = gfc_find_array_ref (array);
548 corank = ar->as->corank;
550 if (mpz_cmp_ui (dim->value.integer, 1) < 0
551 || mpz_cmp_ui (dim->value.integer, corank) > 0)
553 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
554 "codimension index", gfc_current_intrinsic, &dim->where);
563 /* If a DIM parameter is a constant, make sure that it is greater than
564 zero and less than or equal to the rank of the given array. If
565 allow_assumed is zero then dim must be less than the rank of the array
566 for assumed size arrays. */
569 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
577 if (dim->expr_type != EXPR_CONSTANT)
580 if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
581 && array->value.function.isym->id == GFC_ISYM_SPREAD)
582 rank = array->rank + 1;
586 if (array->expr_type == EXPR_VARIABLE)
588 ar = gfc_find_array_ref (array);
589 if (ar->as->type == AS_ASSUMED_SIZE
591 && ar->type != AR_ELEMENT
592 && ar->type != AR_SECTION)
596 if (mpz_cmp_ui (dim->value.integer, 1) < 0
597 || mpz_cmp_ui (dim->value.integer, rank) > 0)
599 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
600 "dimension index", gfc_current_intrinsic, &dim->where);
609 /* Compare the size of a along dimension ai with the size of b along
610 dimension bi, returning 0 if they are known not to be identical,
611 and 1 if they are identical, or if this cannot be determined. */
614 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
616 mpz_t a_size, b_size;
619 gcc_assert (a->rank > ai);
620 gcc_assert (b->rank > bi);
624 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
626 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
628 if (mpz_cmp (a_size, b_size) != 0)
639 /* Check whether two character expressions have the same length;
640 returns SUCCESS if they have or if the length cannot be determined. */
643 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
648 if (a->ts.u.cl && a->ts.u.cl->length
649 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
650 len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
651 else if (a->expr_type == EXPR_CONSTANT
652 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
653 len_a = a->value.character.length;
657 if (b->ts.u.cl && b->ts.u.cl->length
658 && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
659 len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
660 else if (b->expr_type == EXPR_CONSTANT
661 && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
662 len_b = b->value.character.length;
669 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
670 len_a, len_b, name, &a->where);
675 /***** Check functions *****/
677 /* Check subroutine suitable for intrinsics taking a real argument and
678 a kind argument for the result. */
681 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
683 if (type_check (a, 0, BT_REAL) == FAILURE)
685 if (kind_check (kind, 1, type) == FAILURE)
692 /* Check subroutine suitable for ceiling, floor and nint. */
695 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
697 return check_a_kind (a, kind, BT_INTEGER);
701 /* Check subroutine suitable for aint, anint. */
704 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
706 return check_a_kind (a, kind, BT_REAL);
711 gfc_check_abs (gfc_expr *a)
713 if (numeric_check (a, 0) == FAILURE)
721 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
723 if (type_check (a, 0, BT_INTEGER) == FAILURE)
725 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
733 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
735 if (type_check (name, 0, BT_CHARACTER) == FAILURE
736 || scalar_check (name, 0) == FAILURE)
738 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
741 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
742 || scalar_check (mode, 1) == FAILURE)
744 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
752 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
754 if (logical_array_check (mask, 0) == FAILURE)
757 if (dim_check (dim, 1, false) == FAILURE)
760 if (dim_rank_check (dim, mask, 0) == FAILURE)
768 gfc_check_allocated (gfc_expr *array)
770 if (variable_check (array, 0, false) == FAILURE)
772 if (allocatable_check (array, 0) == FAILURE)
779 /* Common check function where the first argument must be real or
780 integer and the second argument must be the same as the first. */
783 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
785 if (int_or_real_check (a, 0) == FAILURE)
788 if (a->ts.type != p->ts.type)
790 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
791 "have the same type", gfc_current_intrinsic_arg[0]->name,
792 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
797 if (a->ts.kind != p->ts.kind)
799 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
800 &p->where) == FAILURE)
809 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
811 if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
819 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
821 symbol_attribute attr1, attr2;
826 where = &pointer->where;
828 if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
829 attr1 = gfc_expr_attr (pointer);
830 else if (pointer->expr_type == EXPR_NULL)
833 gcc_assert (0); /* Pointer must be a variable or a function. */
835 if (!attr1.pointer && !attr1.proc_pointer)
837 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
838 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
843 /* Target argument is optional. */
847 where = &target->where;
848 if (target->expr_type == EXPR_NULL)
851 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
852 attr2 = gfc_expr_attr (target);
855 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
856 "or target VARIABLE or FUNCTION",
857 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
862 if (attr1.pointer && !attr2.pointer && !attr2.target)
864 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
865 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
866 gfc_current_intrinsic, &target->where);
871 if (same_type_check (pointer, 0, target, 1) == FAILURE)
873 if (rank_check (target, 0, pointer->rank) == FAILURE)
875 if (target->rank > 0)
877 for (i = 0; i < target->rank; i++)
878 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
880 gfc_error ("Array section with a vector subscript at %L shall not "
881 "be the target of a pointer",
891 gfc_error ("NULL pointer at %L is not permitted as actual argument "
892 "of '%s' intrinsic function", where, gfc_current_intrinsic);
899 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
901 /* gfc_notify_std would be a wast of time as the return value
902 is seemingly used only for the generic resolution. The error
903 will be: Too many arguments. */
904 if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
907 return gfc_check_atan2 (y, x);
912 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
914 if (type_check (y, 0, BT_REAL) == FAILURE)
916 if (same_type_check (y, 0, x, 1) == FAILURE)
923 /* BESJN and BESYN functions. */
926 gfc_check_besn (gfc_expr *n, gfc_expr *x)
928 if (type_check (n, 0, BT_INTEGER) == FAILURE)
930 if (n->expr_type == EXPR_CONSTANT)
933 gfc_extract_int (n, &i);
934 if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument "
935 "N at %L", &n->where) == FAILURE)
939 if (type_check (x, 1, BT_REAL) == FAILURE)
946 /* Transformational version of the Bessel JN and YN functions. */
949 gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
951 if (type_check (n1, 0, BT_INTEGER) == FAILURE)
953 if (scalar_check (n1, 0) == FAILURE)
955 if (nonnegative_check("N1", n1) == FAILURE)
958 if (type_check (n2, 1, BT_INTEGER) == FAILURE)
960 if (scalar_check (n2, 1) == FAILURE)
962 if (nonnegative_check("N2", n2) == FAILURE)
965 if (type_check (x, 2, BT_REAL) == FAILURE)
967 if (scalar_check (x, 2) == FAILURE)
975 gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
977 if (type_check (i, 0, BT_INTEGER) == FAILURE)
980 if (type_check (j, 1, BT_INTEGER) == FAILURE)
988 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
990 if (type_check (i, 0, BT_INTEGER) == FAILURE)
993 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
996 if (nonnegative_check ("pos", pos) == FAILURE)
999 if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
1007 gfc_check_char (gfc_expr *i, gfc_expr *kind)
1009 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1011 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
1019 gfc_check_chdir (gfc_expr *dir)
1021 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1023 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1031 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
1033 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1035 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1041 if (type_check (status, 1, BT_INTEGER) == FAILURE)
1043 if (scalar_check (status, 1) == FAILURE)
1051 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
1053 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1055 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1058 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1060 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1068 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
1070 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1072 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1075 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1077 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1083 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1086 if (scalar_check (status, 2) == FAILURE)
1094 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
1096 if (numeric_check (x, 0) == FAILURE)
1101 if (numeric_check (y, 1) == FAILURE)
1104 if (x->ts.type == BT_COMPLEX)
1106 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1107 "present if 'x' is COMPLEX",
1108 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1113 if (y->ts.type == BT_COMPLEX)
1115 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1116 "of either REAL or INTEGER",
1117 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1124 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
1132 gfc_check_complex (gfc_expr *x, gfc_expr *y)
1134 if (int_or_real_check (x, 0) == FAILURE)
1136 if (scalar_check (x, 0) == FAILURE)
1139 if (int_or_real_check (y, 1) == FAILURE)
1141 if (scalar_check (y, 1) == FAILURE)
1149 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1151 if (logical_array_check (mask, 0) == FAILURE)
1153 if (dim_check (dim, 1, false) == FAILURE)
1155 if (dim_rank_check (dim, mask, 0) == FAILURE)
1157 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1159 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1160 "with KIND argument at %L",
1161 gfc_current_intrinsic, &kind->where) == FAILURE)
1169 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
1171 if (array_check (array, 0) == FAILURE)
1174 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1177 if (dim_check (dim, 2, true) == FAILURE)
1180 if (dim_rank_check (dim, array, false) == FAILURE)
1183 if (array->rank == 1 || shift->rank == 0)
1185 if (scalar_check (shift, 1) == FAILURE)
1188 else if (shift->rank == array->rank - 1)
1193 else if (dim->expr_type == EXPR_CONSTANT)
1194 gfc_extract_int (dim, &d);
1201 for (i = 0, j = 0; i < array->rank; i++)
1204 if (!identical_dimen_shape (array, i, shift, j))
1206 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1207 "invalid shape in dimension %d (%ld/%ld)",
1208 gfc_current_intrinsic_arg[1]->name,
1209 gfc_current_intrinsic, &shift->where, i + 1,
1210 mpz_get_si (array->shape[i]),
1211 mpz_get_si (shift->shape[j]));
1221 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1222 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1223 gfc_current_intrinsic, &shift->where, array->rank - 1);
1232 gfc_check_ctime (gfc_expr *time)
1234 if (scalar_check (time, 0) == FAILURE)
1237 if (type_check (time, 0, BT_INTEGER) == FAILURE)
1244 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
1246 if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
1253 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
1255 if (numeric_check (x, 0) == FAILURE)
1260 if (numeric_check (y, 1) == FAILURE)
1263 if (x->ts.type == BT_COMPLEX)
1265 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1266 "present if 'x' is COMPLEX",
1267 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1272 if (y->ts.type == BT_COMPLEX)
1274 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1275 "of either REAL or INTEGER",
1276 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1287 gfc_check_dble (gfc_expr *x)
1289 if (numeric_check (x, 0) == FAILURE)
1297 gfc_check_digits (gfc_expr *x)
1299 if (int_or_real_check (x, 0) == FAILURE)
1307 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1309 switch (vector_a->ts.type)
1312 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1319 if (numeric_check (vector_b, 1) == FAILURE)
1324 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1325 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
1326 gfc_current_intrinsic, &vector_a->where);
1330 if (rank_check (vector_a, 0, 1) == FAILURE)
1333 if (rank_check (vector_b, 1, 1) == FAILURE)
1336 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1338 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1339 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
1340 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
1349 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1351 if (type_check (x, 0, BT_REAL) == FAILURE
1352 || type_check (y, 1, BT_REAL) == FAILURE)
1355 if (x->ts.kind != gfc_default_real_kind)
1357 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1358 "real", gfc_current_intrinsic_arg[0]->name,
1359 gfc_current_intrinsic, &x->where);
1363 if (y->ts.kind != gfc_default_real_kind)
1365 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1366 "real", gfc_current_intrinsic_arg[1]->name,
1367 gfc_current_intrinsic, &y->where);
1376 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
1378 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1381 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1384 if (same_type_check (i, 0, j, 1) == FAILURE)
1387 if (type_check (shift, 2, BT_INTEGER) == FAILURE)
1390 if (nonnegative_check ("SHIFT", shift) == FAILURE)
1393 if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
1401 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1404 if (array_check (array, 0) == FAILURE)
1407 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1410 if (dim_check (dim, 3, true) == FAILURE)
1413 if (dim_rank_check (dim, array, false) == FAILURE)
1416 if (array->rank == 1 || shift->rank == 0)
1418 if (scalar_check (shift, 1) == FAILURE)
1421 else if (shift->rank == array->rank - 1)
1426 else if (dim->expr_type == EXPR_CONSTANT)
1427 gfc_extract_int (dim, &d);
1434 for (i = 0, j = 0; i < array->rank; i++)
1437 if (!identical_dimen_shape (array, i, shift, j))
1439 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1440 "invalid shape in dimension %d (%ld/%ld)",
1441 gfc_current_intrinsic_arg[1]->name,
1442 gfc_current_intrinsic, &shift->where, i + 1,
1443 mpz_get_si (array->shape[i]),
1444 mpz_get_si (shift->shape[j]));
1454 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1455 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1456 gfc_current_intrinsic, &shift->where, array->rank - 1);
1460 if (boundary != NULL)
1462 if (same_type_check (array, 0, boundary, 2) == FAILURE)
1465 if (array->rank == 1 || boundary->rank == 0)
1467 if (scalar_check (boundary, 2) == FAILURE)
1470 else if (boundary->rank == array->rank - 1)
1472 if (gfc_check_conformance (shift, boundary,
1473 "arguments '%s' and '%s' for "
1475 gfc_current_intrinsic_arg[1]->name,
1476 gfc_current_intrinsic_arg[2]->name,
1477 gfc_current_intrinsic ) == FAILURE)
1482 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1483 "rank %d or be a scalar",
1484 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1485 &shift->where, array->rank - 1);
1494 gfc_check_float (gfc_expr *a)
1496 if (type_check (a, 0, BT_INTEGER) == FAILURE)
1499 if ((a->ts.kind != gfc_default_integer_kind)
1500 && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER "
1501 "kind argument to %s intrinsic at %L",
1502 gfc_current_intrinsic, &a->where) == FAILURE )
1508 /* A single complex argument. */
1511 gfc_check_fn_c (gfc_expr *a)
1513 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1519 /* A single real argument. */
1522 gfc_check_fn_r (gfc_expr *a)
1524 if (type_check (a, 0, BT_REAL) == FAILURE)
1530 /* A single double argument. */
1533 gfc_check_fn_d (gfc_expr *a)
1535 if (double_check (a, 0) == FAILURE)
1541 /* A single real or complex argument. */
1544 gfc_check_fn_rc (gfc_expr *a)
1546 if (real_or_complex_check (a, 0) == FAILURE)
1554 gfc_check_fn_rc2008 (gfc_expr *a)
1556 if (real_or_complex_check (a, 0) == FAILURE)
1559 if (a->ts.type == BT_COMPLEX
1560 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
1561 "argument of '%s' intrinsic at %L",
1562 gfc_current_intrinsic_arg[0]->name,
1563 gfc_current_intrinsic, &a->where) == FAILURE)
1571 gfc_check_fnum (gfc_expr *unit)
1573 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1576 if (scalar_check (unit, 0) == FAILURE)
1584 gfc_check_huge (gfc_expr *x)
1586 if (int_or_real_check (x, 0) == FAILURE)
1594 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1596 if (type_check (x, 0, BT_REAL) == FAILURE)
1598 if (same_type_check (x, 0, y, 1) == FAILURE)
1605 /* Check that the single argument is an integer. */
1608 gfc_check_i (gfc_expr *i)
1610 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1618 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1620 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1623 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1626 if (i->ts.kind != j->ts.kind)
1628 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1629 &i->where) == FAILURE)
1638 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1640 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1643 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1646 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1649 if (nonnegative_check ("pos", pos) == FAILURE)
1652 if (nonnegative_check ("len", len) == FAILURE)
1655 if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
1663 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1667 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1670 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1673 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1674 "with KIND argument at %L",
1675 gfc_current_intrinsic, &kind->where) == FAILURE)
1678 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1684 /* Substring references don't have the charlength set. */
1686 while (ref && ref->type != REF_SUBSTRING)
1689 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1693 /* Check that the argument is length one. Non-constant lengths
1694 can't be checked here, so assume they are ok. */
1695 if (c->ts.u.cl && c->ts.u.cl->length)
1697 /* If we already have a length for this expression then use it. */
1698 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1700 i = mpz_get_si (c->ts.u.cl->length->value.integer);
1707 start = ref->u.ss.start;
1708 end = ref->u.ss.end;
1711 if (end == NULL || end->expr_type != EXPR_CONSTANT
1712 || start->expr_type != EXPR_CONSTANT)
1715 i = mpz_get_si (end->value.integer) + 1
1716 - mpz_get_si (start->value.integer);
1724 gfc_error ("Argument of %s at %L must be of length one",
1725 gfc_current_intrinsic, &c->where);
1734 gfc_check_idnint (gfc_expr *a)
1736 if (double_check (a, 0) == FAILURE)
1744 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1746 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1749 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1752 if (i->ts.kind != j->ts.kind)
1754 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1755 &i->where) == FAILURE)
1764 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1767 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1768 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1771 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1774 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1776 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1777 "with KIND argument at %L",
1778 gfc_current_intrinsic, &kind->where) == FAILURE)
1781 if (string->ts.kind != substring->ts.kind)
1783 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1784 "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
1785 gfc_current_intrinsic, &substring->where,
1786 gfc_current_intrinsic_arg[0]->name);
1795 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1797 if (numeric_check (x, 0) == FAILURE)
1800 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1808 gfc_check_intconv (gfc_expr *x)
1810 if (numeric_check (x, 0) == FAILURE)
1818 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1820 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1823 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1826 if (i->ts.kind != j->ts.kind)
1828 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1829 &i->where) == FAILURE)
1838 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1840 if (type_check (i, 0, BT_INTEGER) == FAILURE
1841 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1849 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1851 if (type_check (i, 0, BT_INTEGER) == FAILURE
1852 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1855 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1863 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1865 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1868 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1876 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1878 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1881 if (scalar_check (pid, 0) == FAILURE)
1884 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1887 if (scalar_check (sig, 1) == FAILURE)
1893 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1896 if (scalar_check (status, 2) == FAILURE)
1904 gfc_check_kind (gfc_expr *x)
1906 if (x->ts.type == BT_DERIVED)
1908 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1909 "non-derived type", gfc_current_intrinsic_arg[0]->name,
1910 gfc_current_intrinsic, &x->where);
1919 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1921 if (array_check (array, 0) == FAILURE)
1924 if (dim_check (dim, 1, false) == FAILURE)
1927 if (dim_rank_check (dim, array, 1) == FAILURE)
1930 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1932 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1933 "with KIND argument at %L",
1934 gfc_current_intrinsic, &kind->where) == FAILURE)
1942 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
1944 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1946 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1950 if (coarray_check (coarray, 0) == FAILURE)
1955 if (dim_check (dim, 1, false) == FAILURE)
1958 if (dim_corank_check (dim, coarray) == FAILURE)
1962 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1970 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
1972 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
1975 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1977 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1978 "with KIND argument at %L",
1979 gfc_current_intrinsic, &kind->where) == FAILURE)
1987 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
1989 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1991 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
1994 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
1996 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
2004 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
2006 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2008 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2011 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2013 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2021 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2023 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2025 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2028 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2030 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
2036 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2039 if (scalar_check (status, 2) == FAILURE)
2047 gfc_check_loc (gfc_expr *expr)
2049 return variable_check (expr, 0, true);
2054 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
2056 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2058 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2061 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2063 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2071 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2073 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2075 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2078 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2080 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2086 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2089 if (scalar_check (status, 2) == FAILURE)
2097 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
2099 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
2101 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
2108 /* Min/max family. */
2111 min_max_args (gfc_actual_arglist *arg)
2113 if (arg == NULL || arg->next == NULL)
2115 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2116 gfc_current_intrinsic, gfc_current_intrinsic_where);
2125 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
2127 gfc_actual_arglist *arg, *tmp;
2132 if (min_max_args (arglist) == FAILURE)
2135 for (arg = arglist, n=1; arg; arg = arg->next, n++)
2138 if (x->ts.type != type || x->ts.kind != kind)
2140 if (x->ts.type == type)
2142 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
2143 "kinds at %L", &x->where) == FAILURE)
2148 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2149 "%s(%d)", n, gfc_current_intrinsic, &x->where,
2150 gfc_basic_typename (type), kind);
2155 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
2156 if (gfc_check_conformance (tmp->expr, x,
2157 "arguments 'a%d' and 'a%d' for "
2158 "intrinsic '%s'", m, n,
2159 gfc_current_intrinsic) == FAILURE)
2168 gfc_check_min_max (gfc_actual_arglist *arg)
2172 if (min_max_args (arg) == FAILURE)
2177 if (x->ts.type == BT_CHARACTER)
2179 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2180 "with CHARACTER argument at %L",
2181 gfc_current_intrinsic, &x->where) == FAILURE)
2184 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
2186 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2187 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
2191 return check_rest (x->ts.type, x->ts.kind, arg);
2196 gfc_check_min_max_integer (gfc_actual_arglist *arg)
2198 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
2203 gfc_check_min_max_real (gfc_actual_arglist *arg)
2205 return check_rest (BT_REAL, gfc_default_real_kind, arg);
2210 gfc_check_min_max_double (gfc_actual_arglist *arg)
2212 return check_rest (BT_REAL, gfc_default_double_kind, arg);
2216 /* End of min/max family. */
2219 gfc_check_malloc (gfc_expr *size)
2221 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2224 if (scalar_check (size, 0) == FAILURE)
2232 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
2234 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
2236 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2237 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2238 gfc_current_intrinsic, &matrix_a->where);
2242 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2244 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2245 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
2246 gfc_current_intrinsic, &matrix_b->where);
2250 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2251 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2253 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2254 gfc_current_intrinsic, &matrix_a->where,
2255 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2259 switch (matrix_a->rank)
2262 if (rank_check (matrix_b, 1, 2) == FAILURE)
2264 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2265 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2267 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2268 "and '%s' at %L for intrinsic matmul",
2269 gfc_current_intrinsic_arg[0]->name,
2270 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2276 if (matrix_b->rank != 2)
2278 if (rank_check (matrix_b, 1, 1) == FAILURE)
2281 /* matrix_b has rank 1 or 2 here. Common check for the cases
2282 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2283 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2284 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2286 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2287 "dimension 1 for argument '%s' at %L for intrinsic "
2288 "matmul", gfc_current_intrinsic_arg[0]->name,
2289 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2295 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2296 "1 or 2", gfc_current_intrinsic_arg[0]->name,
2297 gfc_current_intrinsic, &matrix_a->where);
2305 /* Whoever came up with this interface was probably on something.
2306 The possibilities for the occupation of the second and third
2313 NULL MASK minloc(array, mask=m)
2316 I.e. in the case of minloc(array,mask), mask will be in the second
2317 position of the argument list and we'll have to fix that up. */
2320 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2322 gfc_expr *a, *m, *d;
2325 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
2329 m = ap->next->next->expr;
2331 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2332 && ap->next->name == NULL)
2336 ap->next->expr = NULL;
2337 ap->next->next->expr = m;
2340 if (dim_check (d, 1, false) == FAILURE)
2343 if (dim_rank_check (d, a, 0) == FAILURE)
2346 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2350 && gfc_check_conformance (a, m,
2351 "arguments '%s' and '%s' for intrinsic %s",
2352 gfc_current_intrinsic_arg[0]->name,
2353 gfc_current_intrinsic_arg[2]->name,
2354 gfc_current_intrinsic ) == FAILURE)
2361 /* Similar to minloc/maxloc, the argument list might need to be
2362 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2363 difference is that MINLOC/MAXLOC take an additional KIND argument.
2364 The possibilities are:
2370 NULL MASK minval(array, mask=m)
2373 I.e. in the case of minval(array,mask), mask will be in the second
2374 position of the argument list and we'll have to fix that up. */
2377 check_reduction (gfc_actual_arglist *ap)
2379 gfc_expr *a, *m, *d;
2383 m = ap->next->next->expr;
2385 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2386 && ap->next->name == NULL)
2390 ap->next->expr = NULL;
2391 ap->next->next->expr = m;
2394 if (dim_check (d, 1, false) == FAILURE)
2397 if (dim_rank_check (d, a, 0) == FAILURE)
2400 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2404 && gfc_check_conformance (a, m,
2405 "arguments '%s' and '%s' for intrinsic %s",
2406 gfc_current_intrinsic_arg[0]->name,
2407 gfc_current_intrinsic_arg[2]->name,
2408 gfc_current_intrinsic) == FAILURE)
2416 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2418 if (int_or_real_check (ap->expr, 0) == FAILURE
2419 || array_check (ap->expr, 0) == FAILURE)
2422 return check_reduction (ap);
2427 gfc_check_product_sum (gfc_actual_arglist *ap)
2429 if (numeric_check (ap->expr, 0) == FAILURE
2430 || array_check (ap->expr, 0) == FAILURE)
2433 return check_reduction (ap);
2437 /* For IANY, IALL and IPARITY. */
2440 gfc_check_mask (gfc_expr *i, gfc_expr *kind)
2444 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2447 if (nonnegative_check ("I", i) == FAILURE)
2450 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2454 gfc_extract_int (kind, &k);
2456 k = gfc_default_integer_kind;
2458 if (less_than_bitsizekind ("I", i, k) == FAILURE)
2466 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
2468 if (ap->expr->ts.type != BT_INTEGER)
2470 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2471 gfc_current_intrinsic_arg[0]->name,
2472 gfc_current_intrinsic, &ap->expr->where);
2476 if (array_check (ap->expr, 0) == FAILURE)
2479 return check_reduction (ap);
2484 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2486 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2489 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2492 if (tsource->ts.type == BT_CHARACTER)
2493 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2500 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
2502 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2505 if (type_check (j, 1, BT_INTEGER) == FAILURE)
2508 if (type_check (mask, 2, BT_INTEGER) == FAILURE)
2511 if (same_type_check (i, 0, j, 1) == FAILURE)
2514 if (same_type_check (i, 0, mask, 2) == FAILURE)
2522 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2524 if (variable_check (from, 0, false) == FAILURE)
2526 if (allocatable_check (from, 0) == FAILURE)
2529 if (variable_check (to, 1, false) == FAILURE)
2531 if (allocatable_check (to, 1) == FAILURE)
2534 if (same_type_check (to, 1, from, 0) == FAILURE)
2537 if (to->rank != from->rank)
2539 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2540 "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
2541 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2542 &to->where, from->rank, to->rank);
2546 if (to->ts.kind != from->ts.kind)
2548 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2549 "be of the same kind %d/%d",
2550 gfc_current_intrinsic_arg[0]->name,
2551 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2552 &to->where, from->ts.kind, to->ts.kind);
2561 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2563 if (type_check (x, 0, BT_REAL) == FAILURE)
2566 if (type_check (s, 1, BT_REAL) == FAILURE)
2574 gfc_check_new_line (gfc_expr *a)
2576 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2584 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
2586 if (type_check (array, 0, BT_REAL) == FAILURE)
2589 if (array_check (array, 0) == FAILURE)
2592 if (dim_rank_check (dim, array, false) == FAILURE)
2599 gfc_check_null (gfc_expr *mold)
2601 symbol_attribute attr;
2606 if (variable_check (mold, 0, true) == FAILURE)
2609 attr = gfc_variable_attr (mold, NULL);
2611 if (!attr.pointer && !attr.proc_pointer)
2613 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2614 gfc_current_intrinsic_arg[0]->name,
2615 gfc_current_intrinsic, &mold->where);
2624 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2626 if (array_check (array, 0) == FAILURE)
2629 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2632 if (gfc_check_conformance (array, mask,
2633 "arguments '%s' and '%s' for intrinsic '%s'",
2634 gfc_current_intrinsic_arg[0]->name,
2635 gfc_current_intrinsic_arg[1]->name,
2636 gfc_current_intrinsic) == FAILURE)
2641 mpz_t array_size, vector_size;
2642 bool have_array_size, have_vector_size;
2644 if (same_type_check (array, 0, vector, 2) == FAILURE)
2647 if (rank_check (vector, 2, 1) == FAILURE)
2650 /* VECTOR requires at least as many elements as MASK
2651 has .TRUE. values. */
2652 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2653 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2655 if (have_vector_size
2656 && (mask->expr_type == EXPR_ARRAY
2657 || (mask->expr_type == EXPR_CONSTANT
2658 && have_array_size)))
2660 int mask_true_values = 0;
2662 if (mask->expr_type == EXPR_ARRAY)
2664 gfc_constructor *mask_ctor;
2665 mask_ctor = gfc_constructor_first (mask->value.constructor);
2668 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2670 mask_true_values = 0;
2674 if (mask_ctor->expr->value.logical)
2677 mask_ctor = gfc_constructor_next (mask_ctor);
2680 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2681 mask_true_values = mpz_get_si (array_size);
2683 if (mpz_get_si (vector_size) < mask_true_values)
2685 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2686 "provide at least as many elements as there "
2687 "are .TRUE. values in '%s' (%ld/%d)",
2688 gfc_current_intrinsic_arg[2]->name,
2689 gfc_current_intrinsic, &vector->where,
2690 gfc_current_intrinsic_arg[1]->name,
2691 mpz_get_si (vector_size), mask_true_values);
2696 if (have_array_size)
2697 mpz_clear (array_size);
2698 if (have_vector_size)
2699 mpz_clear (vector_size);
2707 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
2709 if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
2712 if (array_check (mask, 0) == FAILURE)
2715 if (dim_rank_check (dim, mask, false) == FAILURE)
2723 gfc_check_precision (gfc_expr *x)
2725 if (real_or_complex_check (x, 0) == FAILURE)
2733 gfc_check_present (gfc_expr *a)
2737 if (variable_check (a, 0, true) == FAILURE)
2740 sym = a->symtree->n.sym;
2741 if (!sym->attr.dummy)
2743 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2744 "dummy variable", gfc_current_intrinsic_arg[0]->name,
2745 gfc_current_intrinsic, &a->where);
2749 if (!sym->attr.optional)
2751 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2752 "an OPTIONAL dummy variable",
2753 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2758 /* 13.14.82 PRESENT(A)
2760 Argument. A shall be the name of an optional dummy argument that is
2761 accessible in the subprogram in which the PRESENT function reference
2765 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2766 && a->ref->u.ar.type == AR_FULL))
2768 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2769 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
2770 gfc_current_intrinsic, &a->where, sym->name);
2779 gfc_check_radix (gfc_expr *x)
2781 if (int_or_real_check (x, 0) == FAILURE)
2789 gfc_check_range (gfc_expr *x)
2791 if (numeric_check (x, 0) == FAILURE)
2798 /* real, float, sngl. */
2800 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2802 if (numeric_check (a, 0) == FAILURE)
2805 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2813 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2815 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2817 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2820 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2822 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2830 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2832 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2834 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2837 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2839 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2845 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2848 if (scalar_check (status, 2) == FAILURE)
2856 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2858 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2861 if (scalar_check (x, 0) == FAILURE)
2864 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2867 if (scalar_check (y, 1) == FAILURE)
2875 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2876 gfc_expr *pad, gfc_expr *order)
2882 if (array_check (source, 0) == FAILURE)
2885 if (rank_check (shape, 1, 1) == FAILURE)
2888 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2891 if (gfc_array_size (shape, &size) != SUCCESS)
2893 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2894 "array of constant size", &shape->where);
2898 shape_size = mpz_get_ui (size);
2901 if (shape_size <= 0)
2903 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
2904 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2908 else if (shape_size > GFC_MAX_DIMENSIONS)
2910 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2911 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2914 else if (shape->expr_type == EXPR_ARRAY)
2918 for (i = 0; i < shape_size; ++i)
2920 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
2921 if (e->expr_type != EXPR_CONSTANT)
2924 gfc_extract_int (e, &extent);
2927 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2928 "negative element (%d)",
2929 gfc_current_intrinsic_arg[1]->name,
2930 gfc_current_intrinsic, &e->where, extent);
2938 if (same_type_check (source, 0, pad, 2) == FAILURE)
2941 if (array_check (pad, 2) == FAILURE)
2947 if (array_check (order, 3) == FAILURE)
2950 if (type_check (order, 3, BT_INTEGER) == FAILURE)
2953 if (order->expr_type == EXPR_ARRAY)
2955 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
2958 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
2961 gfc_array_size (order, &size);
2962 order_size = mpz_get_ui (size);
2965 if (order_size != shape_size)
2967 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2968 "has wrong number of elements (%d/%d)",
2969 gfc_current_intrinsic_arg[3]->name,
2970 gfc_current_intrinsic, &order->where,
2971 order_size, shape_size);
2975 for (i = 1; i <= order_size; ++i)
2977 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
2978 if (e->expr_type != EXPR_CONSTANT)
2981 gfc_extract_int (e, &dim);
2983 if (dim < 1 || dim > order_size)
2985 gfc_error ("'%s' argument of '%s' intrinsic at %L "
2986 "has out-of-range dimension (%d)",
2987 gfc_current_intrinsic_arg[3]->name,
2988 gfc_current_intrinsic, &e->where, dim);
2992 if (perm[dim-1] != 0)
2994 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2995 "invalid permutation of dimensions (dimension "
2997 gfc_current_intrinsic_arg[3]->name,
2998 gfc_current_intrinsic, &e->where, dim);
3007 if (pad == NULL && shape->expr_type == EXPR_ARRAY
3008 && gfc_is_constant_expr (shape)
3009 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
3010 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
3012 /* Check the match in size between source and destination. */
3013 if (gfc_array_size (source, &nelems) == SUCCESS)
3019 mpz_init_set_ui (size, 1);
3020 for (c = gfc_constructor_first (shape->value.constructor);
3021 c; c = gfc_constructor_next (c))
3022 mpz_mul (size, size, c->expr->value.integer);
3024 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
3030 gfc_error ("Without padding, there are not enough elements "
3031 "in the intrinsic RESHAPE source at %L to match "
3032 "the shape", &source->where);
3043 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
3046 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
3048 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3049 "must be of a derived type",
3050 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3055 if (!gfc_type_is_extensible (a->ts.u.derived))
3057 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3058 "must be of an extensible type",
3059 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3064 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
3066 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3067 "must be of a derived type",
3068 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3073 if (!gfc_type_is_extensible (b->ts.u.derived))
3075 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3076 "must be of an extensible type",
3077 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3087 gfc_check_scale (gfc_expr *x, gfc_expr *i)
3089 if (type_check (x, 0, BT_REAL) == FAILURE)
3092 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3100 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3102 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3105 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
3108 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3111 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3113 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3114 "with KIND argument at %L",
3115 gfc_current_intrinsic, &kind->where) == FAILURE)
3118 if (same_type_check (x, 0, y, 1) == FAILURE)
3126 gfc_check_secnds (gfc_expr *r)
3128 if (type_check (r, 0, BT_REAL) == FAILURE)
3131 if (kind_value_check (r, 0, 4) == FAILURE)
3134 if (scalar_check (r, 0) == FAILURE)
3142 gfc_check_selected_char_kind (gfc_expr *name)
3144 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3147 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3150 if (scalar_check (name, 0) == FAILURE)
3158 gfc_check_selected_int_kind (gfc_expr *r)
3160 if (type_check (r, 0, BT_INTEGER) == FAILURE)
3163 if (scalar_check (r, 0) == FAILURE)
3171 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
3173 if (p == NULL && r == NULL
3174 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
3175 " neither 'P' nor 'R' argument at %L",
3176 gfc_current_intrinsic_where) == FAILURE)
3181 if (type_check (p, 0, BT_INTEGER) == FAILURE)
3184 if (scalar_check (p, 0) == FAILURE)
3190 if (type_check (r, 1, BT_INTEGER) == FAILURE)
3193 if (scalar_check (r, 1) == FAILURE)
3199 if (type_check (radix, 1, BT_INTEGER) == FAILURE)
3202 if (scalar_check (radix, 1) == FAILURE)
3205 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
3206 "RADIX argument at %L", gfc_current_intrinsic,
3207 &radix->where) == FAILURE)
3216 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
3218 if (type_check (x, 0, BT_REAL) == FAILURE)
3221 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3229 gfc_check_shape (gfc_expr *source)
3233 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3236 ar = gfc_find_array_ref (source);
3238 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
3240 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3241 "an assumed size array", &source->where);
3250 gfc_check_shift (gfc_expr *i, gfc_expr *shift)
3252 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3255 if (type_check (shift, 0, BT_INTEGER) == FAILURE)
3258 if (nonnegative_check ("SHIFT", shift) == FAILURE)
3261 if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
3269 gfc_check_sign (gfc_expr *a, gfc_expr *b)
3271 if (int_or_real_check (a, 0) == FAILURE)
3274 if (same_type_check (a, 0, b, 1) == FAILURE)
3282 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3284 if (array_check (array, 0) == FAILURE)
3287 if (dim_check (dim, 1, true) == FAILURE)
3290 if (dim_rank_check (dim, array, 0) == FAILURE)
3293 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3295 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3296 "with KIND argument at %L",
3297 gfc_current_intrinsic, &kind->where) == FAILURE)
3306 gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
3313 gfc_check_c_sizeof (gfc_expr *arg)
3315 if (verify_c_interop (&arg->ts) != SUCCESS)
3317 gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an "
3318 "interoperable data entity",
3319 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3328 gfc_check_sleep_sub (gfc_expr *seconds)
3330 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3333 if (scalar_check (seconds, 0) == FAILURE)
3340 gfc_check_sngl (gfc_expr *a)
3342 if (type_check (a, 0, BT_REAL) == FAILURE)
3345 if ((a->ts.kind != gfc_default_double_kind)
3346 && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision"
3347 "REAL argument to %s intrinsic at %L",
3348 gfc_current_intrinsic, &a->where) == FAILURE)
3355 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
3357 if (source->rank >= GFC_MAX_DIMENSIONS)
3359 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3360 "than rank %d", gfc_current_intrinsic_arg[0]->name,
3361 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
3369 if (dim_check (dim, 1, false) == FAILURE)
3372 /* dim_rank_check() does not apply here. */
3374 && dim->expr_type == EXPR_CONSTANT
3375 && (mpz_cmp_ui (dim->value.integer, 1) < 0
3376 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
3378 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3379 "dimension index", gfc_current_intrinsic_arg[1]->name,
3380 gfc_current_intrinsic, &dim->where);
3384 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
3387 if (scalar_check (ncopies, 2) == FAILURE)
3394 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3398 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3400 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3403 if (scalar_check (unit, 0) == FAILURE)
3406 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3408 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3414 if (type_check (status, 2, BT_INTEGER) == FAILURE
3415 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3416 || scalar_check (status, 2) == FAILURE)
3424 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3426 return gfc_check_fgetputc_sub (unit, c, NULL);
3431 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3433 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3435 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3441 if (type_check (status, 1, BT_INTEGER) == FAILURE
3442 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3443 || scalar_check (status, 1) == FAILURE)
3451 gfc_check_fgetput (gfc_expr *c)
3453 return gfc_check_fgetput_sub (c, NULL);
3458 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3460 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3463 if (scalar_check (unit, 0) == FAILURE)
3466 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3469 if (scalar_check (offset, 1) == FAILURE)
3472 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3475 if (scalar_check (whence, 2) == FAILURE)
3481 if (type_check (status, 3, BT_INTEGER) == FAILURE)
3484 if (kind_value_check (status, 3, 4) == FAILURE)
3487 if (scalar_check (status, 3) == FAILURE)
3496 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
3498 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3501 if (scalar_check (unit, 0) == FAILURE)
3504 if (type_check (array, 1, BT_INTEGER) == FAILURE
3505 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
3508 if (array_check (array, 1) == FAILURE)
3516 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3518 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3521 if (scalar_check (unit, 0) == FAILURE)
3524 if (type_check (array, 1, BT_INTEGER) == FAILURE
3525 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3528 if (array_check (array, 1) == FAILURE)
3534 if (type_check (status, 2, BT_INTEGER) == FAILURE
3535 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3538 if (scalar_check (status, 2) == FAILURE)
3546 gfc_check_ftell (gfc_expr *unit)
3548 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3551 if (scalar_check (unit, 0) == FAILURE)
3559 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3561 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3564 if (scalar_check (unit, 0) == FAILURE)
3567 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3570 if (scalar_check (offset, 1) == FAILURE)
3578 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3580 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3582 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3585 if (type_check (array, 1, BT_INTEGER) == FAILURE
3586 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3589 if (array_check (array, 1) == FAILURE)
3597 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3599 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3601 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3604 if (type_check (array, 1, BT_INTEGER) == FAILURE
3605 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3608 if (array_check (array, 1) == FAILURE)
3614 if (type_check (status, 2, BT_INTEGER) == FAILURE
3615 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3618 if (scalar_check (status, 2) == FAILURE)
3626 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3628 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3630 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3634 if (coarray_check (coarray, 0) == FAILURE)
3639 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3640 gfc_current_intrinsic_arg[1]->name, &sub->where);
3649 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3651 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3653 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3657 if (dim != NULL && coarray == NULL)
3659 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3660 "intrinsic at %L", &dim->where);
3664 if (coarray == NULL)
3667 if (coarray_check (coarray, 0) == FAILURE)
3672 if (dim_check (dim, 1, false) == FAILURE)
3675 if (dim_corank_check (dim, coarray) == FAILURE)
3684 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
3685 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
3687 if (mold->ts.type == BT_HOLLERITH)
3689 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3690 &mold->where, gfc_basic_typename (BT_HOLLERITH));
3696 if (type_check (size, 2, BT_INTEGER) == FAILURE)
3699 if (scalar_check (size, 2) == FAILURE)
3702 if (nonoptional_check (size, 2) == FAILURE)
3711 gfc_check_transpose (gfc_expr *matrix)
3713 if (rank_check (matrix, 0, 2) == FAILURE)
3721 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3723 if (array_check (array, 0) == FAILURE)
3726 if (dim_check (dim, 1, false) == FAILURE)
3729 if (dim_rank_check (dim, array, 0) == FAILURE)
3732 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3734 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3735 "with KIND argument at %L",
3736 gfc_current_intrinsic, &kind->where) == FAILURE)
3744 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
3746 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3748 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3752 if (coarray_check (coarray, 0) == FAILURE)
3757 if (dim_check (dim, 1, false) == FAILURE)
3760 if (dim_corank_check (dim, coarray) == FAILURE)
3764 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3772 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
3776 if (rank_check (vector, 0, 1) == FAILURE)
3779 if (array_check (mask, 1) == FAILURE)
3782 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
3785 if (same_type_check (vector, 0, field, 2) == FAILURE)
3788 if (mask->expr_type == EXPR_ARRAY
3789 && gfc_array_size (vector, &vector_size) == SUCCESS)
3791 int mask_true_count = 0;
3792 gfc_constructor *mask_ctor;
3793 mask_ctor = gfc_constructor_first (mask->value.constructor);
3796 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
3798 mask_true_count = 0;
3802 if (mask_ctor->expr->value.logical)
3805 mask_ctor = gfc_constructor_next (mask_ctor);
3808 if (mpz_get_si (vector_size) < mask_true_count)
3810 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3811 "provide at least as many elements as there "
3812 "are .TRUE. values in '%s' (%ld/%d)",
3813 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3814 &vector->where, gfc_current_intrinsic_arg[1]->name,
3815 mpz_get_si (vector_size), mask_true_count);
3819 mpz_clear (vector_size);
3822 if (mask->rank != field->rank && field->rank != 0)
3824 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
3825 "the same rank as '%s' or be a scalar",
3826 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
3827 &field->where, gfc_current_intrinsic_arg[1]->name);
3831 if (mask->rank == field->rank)
3834 for (i = 0; i < field->rank; i++)
3835 if (! identical_dimen_shape (mask, i, field, i))
3837 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
3838 "must have identical shape.",
3839 gfc_current_intrinsic_arg[2]->name,
3840 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3850 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3852 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3855 if (same_type_check (x, 0, y, 1) == FAILURE)
3858 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3861 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3863 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3864 "with KIND argument at %L",
3865 gfc_current_intrinsic, &kind->where) == FAILURE)
3873 gfc_check_trim (gfc_expr *x)
3875 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3878 if (scalar_check (x, 0) == FAILURE)
3886 gfc_check_ttynam (gfc_expr *unit)
3888 if (scalar_check (unit, 0) == FAILURE)
3891 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3898 /* Common check function for the half a dozen intrinsics that have a
3899 single real argument. */
3902 gfc_check_x (gfc_expr *x)
3904 if (type_check (x, 0, BT_REAL) == FAILURE)
3911 /************* Check functions for intrinsic subroutines *************/
3914 gfc_check_cpu_time (gfc_expr *time)
3916 if (scalar_check (time, 0) == FAILURE)
3919 if (type_check (time, 0, BT_REAL) == FAILURE)
3922 if (variable_check (time, 0, false) == FAILURE)
3930 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
3931 gfc_expr *zone, gfc_expr *values)
3935 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3937 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3939 if (scalar_check (date, 0) == FAILURE)
3941 if (variable_check (date, 0, false) == FAILURE)
3947 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
3949 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
3951 if (scalar_check (time, 1) == FAILURE)
3953 if (variable_check (time, 1, false) == FAILURE)
3959 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
3961 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
3963 if (scalar_check (zone, 2) == FAILURE)
3965 if (variable_check (zone, 2, false) == FAILURE)
3971 if (type_check (values, 3, BT_INTEGER) == FAILURE)
3973 if (array_check (values, 3) == FAILURE)
3975 if (rank_check (values, 3, 1) == FAILURE)
3977 if (variable_check (values, 3, false) == FAILURE)
3986 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
3987 gfc_expr *to, gfc_expr *topos)
3989 if (type_check (from, 0, BT_INTEGER) == FAILURE)
3992 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
3995 if (type_check (len, 2, BT_INTEGER) == FAILURE)
3998 if (same_type_check (from, 0, to, 3) == FAILURE)
4001 if (variable_check (to, 3, false) == FAILURE)
4004 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
4007 if (nonnegative_check ("frompos", frompos) == FAILURE)
4010 if (nonnegative_check ("topos", topos) == FAILURE)
4013 if (nonnegative_check ("len", len) == FAILURE)
4016 if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
4020 if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
4028 gfc_check_random_number (gfc_expr *harvest)
4030 if (type_check (harvest, 0, BT_REAL) == FAILURE)
4033 if (variable_check (harvest, 0, false) == FAILURE)
4041 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
4043 unsigned int nargs = 0, kiss_size;
4044 locus *where = NULL;
4045 mpz_t put_size, get_size;
4046 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4048 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
4050 /* Keep the number of bytes in sync with kiss_size in
4051 libgfortran/intrinsics/random.c. */
4052 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
4056 if (size->expr_type != EXPR_VARIABLE
4057 || !size->symtree->n.sym->attr.optional)
4060 if (scalar_check (size, 0) == FAILURE)
4063 if (type_check (size, 0, BT_INTEGER) == FAILURE)
4066 if (variable_check (size, 0, false) == FAILURE)
4069 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
4075 if (put->expr_type != EXPR_VARIABLE
4076 || !put->symtree->n.sym->attr.optional)
4079 where = &put->where;
4082 if (array_check (put, 1) == FAILURE)
4085 if (rank_check (put, 1, 1) == FAILURE)
4088 if (type_check (put, 1, BT_INTEGER) == FAILURE)
4091 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
4094 if (gfc_array_size (put, &put_size) == SUCCESS
4095 && mpz_get_ui (put_size) < kiss_size)
4096 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4097 "too small (%i/%i)",
4098 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4099 where, (int) mpz_get_ui (put_size), kiss_size);
4104 if (get->expr_type != EXPR_VARIABLE
4105 || !get->symtree->n.sym->attr.optional)
4108 where = &get->where;
4111 if (array_check (get, 2) == FAILURE)
4114 if (rank_check (get, 2, 1) == FAILURE)
4117 if (type_check (get, 2, BT_INTEGER) == FAILURE)
4120 if (variable_check (get, 2, false) == FAILURE)
4123 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
4126 if (gfc_array_size (get, &get_size) == SUCCESS
4127 && mpz_get_ui (get_size) < kiss_size)
4128 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4129 "too small (%i/%i)",
4130 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4131 where, (int) mpz_get_ui (get_size), kiss_size);
4134 /* RANDOM_SEED may not have more than one non-optional argument. */
4136 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
4143 gfc_check_second_sub (gfc_expr *time)
4145 if (scalar_check (time, 0) == FAILURE)
4148 if (type_check (time, 0, BT_REAL) == FAILURE)
4151 if (kind_value_check(time, 0, 4) == FAILURE)
4158 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
4159 count, count_rate, and count_max are all optional arguments */
4162 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
4163 gfc_expr *count_max)
4167 if (scalar_check (count, 0) == FAILURE)
4170 if (type_check (count, 0, BT_INTEGER) == FAILURE)
4173 if (variable_check (count, 0, false) == FAILURE)
4177 if (count_rate != NULL)
4179 if (scalar_check (count_rate, 1) == FAILURE)
4182 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
4185 if (variable_check (count_rate, 1, false) == FAILURE)
4189 && same_type_check (count, 0, count_rate, 1) == FAILURE)
4194 if (count_max != NULL)
4196 if (scalar_check (count_max, 2) == FAILURE)
4199 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
4202 if (variable_check (count_max, 2, false) == FAILURE)
4206 && same_type_check (count, 0, count_max, 2) == FAILURE)
4209 if (count_rate != NULL
4210 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
4219 gfc_check_irand (gfc_expr *x)
4224 if (scalar_check (x, 0) == FAILURE)
4227 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4230 if (kind_value_check(x, 0, 4) == FAILURE)
4238 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
4240 if (scalar_check (seconds, 0) == FAILURE)
4242 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
4245 if (int_or_proc_check (handler, 1) == FAILURE)
4247 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4253 if (scalar_check (status, 2) == FAILURE)
4255 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4257 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
4265 gfc_check_rand (gfc_expr *x)
4270 if (scalar_check (x, 0) == FAILURE)
4273 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4276 if (kind_value_check(x, 0, 4) == FAILURE)
4284 gfc_check_srand (gfc_expr *x)
4286 if (scalar_check (x, 0) == FAILURE)
4289 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4292 if (kind_value_check(x, 0, 4) == FAILURE)
4300 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
4302 if (scalar_check (time, 0) == FAILURE)
4304 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4307 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
4309 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
4317 gfc_check_dtime_etime (gfc_expr *x)
4319 if (array_check (x, 0) == FAILURE)
4322 if (rank_check (x, 0, 1) == FAILURE)
4325 if (variable_check (x, 0, false) == FAILURE)
4328 if (type_check (x, 0, BT_REAL) == FAILURE)
4331 if (kind_value_check(x, 0, 4) == FAILURE)
4339 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
4341 if (array_check (values, 0) == FAILURE)
4344 if (rank_check (values, 0, 1) == FAILURE)
4347 if (variable_check (values, 0, false) == FAILURE)
4350 if (type_check (values, 0, BT_REAL) == FAILURE)
4353 if (kind_value_check(values, 0, 4) == FAILURE)
4356 if (scalar_check (time, 1) == FAILURE)
4359 if (type_check (time, 1, BT_REAL) == FAILURE)
4362 if (kind_value_check(time, 1, 4) == FAILURE)
4370 gfc_check_fdate_sub (gfc_expr *date)
4372 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4374 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4382 gfc_check_gerror (gfc_expr *msg)
4384 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4386 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4394 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4396 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4398 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4404 if (scalar_check (status, 1) == FAILURE)
4407 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4415 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4417 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4420 if (pos->ts.kind > gfc_default_integer_kind)
4422 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4423 "not wider than the default kind (%d)",
4424 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4425 &pos->where, gfc_default_integer_kind);
4429 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4431 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4439 gfc_check_getlog (gfc_expr *msg)
4441 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4443 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4451 gfc_check_exit (gfc_expr *status)
4456 if (type_check (status, 0, BT_INTEGER) == FAILURE)
4459 if (scalar_check (status, 0) == FAILURE)
4467 gfc_check_flush (gfc_expr *unit)
4472 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4475 if (scalar_check (unit, 0) == FAILURE)
4483 gfc_check_free (gfc_expr *i)
4485 if (type_check (i, 0, BT_INTEGER) == FAILURE)
4488 if (scalar_check (i, 0) == FAILURE)
4496 gfc_check_hostnm (gfc_expr *name)
4498 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4500 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4508 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4510 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4512 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4518 if (scalar_check (status, 1) == FAILURE)
4521 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4529 gfc_check_itime_idate (gfc_expr *values)
4531 if (array_check (values, 0) == FAILURE)
4534 if (rank_check (values, 0, 1) == FAILURE)
4537 if (variable_check (values, 0, false) == FAILURE)
4540 if (type_check (values, 0, BT_INTEGER) == FAILURE)
4543 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4551 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4553 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4556 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4559 if (scalar_check (time, 0) == FAILURE)
4562 if (array_check (values, 1) == FAILURE)
4565 if (rank_check (values, 1, 1) == FAILURE)
4568 if (variable_check (values, 1, false) == FAILURE)
4571 if (type_check (values, 1, BT_INTEGER) == FAILURE)
4574 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4582 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4584 if (scalar_check (unit, 0) == FAILURE)
4587 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4590 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4592 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4600 gfc_check_isatty (gfc_expr *unit)
4605 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4608 if (scalar_check (unit, 0) == FAILURE)
4616 gfc_check_isnan (gfc_expr *x)
4618 if (type_check (x, 0, BT_REAL) == FAILURE)
4626 gfc_check_perror (gfc_expr *string)
4628 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
4630 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
4638 gfc_check_umask (gfc_expr *mask)
4640 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4643 if (scalar_check (mask, 0) == FAILURE)
4651 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
4653 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4656 if (scalar_check (mask, 0) == FAILURE)
4662 if (scalar_check (old, 1) == FAILURE)
4665 if (type_check (old, 1, BT_INTEGER) == FAILURE)
4673 gfc_check_unlink (gfc_expr *name)
4675 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4677 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4685 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
4687 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4689 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4695 if (scalar_check (status, 1) == FAILURE)
4698 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4706 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
4708 if (scalar_check (number, 0) == FAILURE)
4710 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4713 if (int_or_proc_check (handler, 1) == FAILURE)
4715 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4723 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
4725 if (scalar_check (number, 0) == FAILURE)
4727 if (type_check (number, 0, BT_INTEGER) == FAILURE)
4730 if (int_or_proc_check (handler, 1) == FAILURE)
4732 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4738 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4740 if (scalar_check (status, 2) == FAILURE)
4748 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
4750 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
4752 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
4755 if (scalar_check (status, 1) == FAILURE)
4758 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4761 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
4768 /* This is used for the GNU intrinsics AND, OR and XOR. */
4770 gfc_check_and (gfc_expr *i, gfc_expr *j)
4772 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
4774 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4775 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
4776 gfc_current_intrinsic, &i->where);
4780 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
4782 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4783 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
4784 gfc_current_intrinsic, &j->where);
4788 if (i->ts.type != j->ts.type)
4790 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
4791 "have the same type", gfc_current_intrinsic_arg[0]->name,
4792 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4797 if (scalar_check (i, 0) == FAILURE)
4800 if (scalar_check (j, 1) == FAILURE)
4808 gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
4813 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
4816 if (scalar_check (kind, 1) == FAILURE)
4819 if (kind->expr_type != EXPR_CONSTANT)
4821 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
4822 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,