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"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
41 scalar_check (gfc_expr *e, int n)
46 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
54 /* Check the type of an expression. */
57 type_check (gfc_expr *e, int n, bt type)
59 if (e->ts.type == type)
62 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
63 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
64 &e->where, gfc_basic_typename (type));
70 /* Check that the expression is a numeric type. */
73 numeric_check (gfc_expr *e, int n)
75 if (gfc_numeric_ts (&e->ts))
78 /* If the expression has not got a type, check if its namespace can
79 offer a default type. */
80 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
81 && e->symtree->n.sym->ts.type == BT_UNKNOWN
82 && gfc_set_default_type (e->symtree->n.sym, 0,
83 e->symtree->n.sym->ns) == SUCCESS
84 && gfc_numeric_ts (&e->symtree->n.sym->ts))
86 e->ts = e->symtree->n.sym->ts;
90 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
91 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
98 /* Check that an expression is integer or real. */
101 int_or_real_check (gfc_expr *e, int n)
103 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
105 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
106 "or REAL", gfc_current_intrinsic_arg[n]->name,
107 gfc_current_intrinsic, &e->where);
115 /* Check that an expression is real or complex. */
118 real_or_complex_check (gfc_expr *e, int n)
120 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
122 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
123 "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
124 gfc_current_intrinsic, &e->where);
132 /* Check that an expression is INTEGER or PROCEDURE. */
135 int_or_proc_check (gfc_expr *e, int n)
137 if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
139 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
140 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
141 gfc_current_intrinsic, &e->where);
149 /* Check that the expression is an optional constant integer
150 and that it specifies a valid kind for that type. */
153 kind_check (gfc_expr *k, int n, bt type)
160 if (type_check (k, n, BT_INTEGER) == FAILURE)
163 if (scalar_check (k, n) == FAILURE)
166 if (k->expr_type != EXPR_CONSTANT)
168 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
169 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
174 if (gfc_extract_int (k, &kind) != NULL
175 || gfc_validate_kind (type, kind, true) < 0)
177 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
186 /* Make sure the expression is a double precision real. */
189 double_check (gfc_expr *d, int n)
191 if (type_check (d, n, BT_REAL) == FAILURE)
194 if (d->ts.kind != gfc_default_double_kind)
196 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
197 "precision", gfc_current_intrinsic_arg[n]->name,
198 gfc_current_intrinsic, &d->where);
207 coarray_check (gfc_expr *e, int n)
209 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
210 && CLASS_DATA (e)->attr.codimension
211 && CLASS_DATA (e)->as->corank)
213 gfc_add_class_array_ref (e);
217 if (!gfc_is_coarray (e))
219 gfc_error ("Expected coarray variable as '%s' argument to the %s "
220 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
221 gfc_current_intrinsic, &e->where);
229 /* Make sure the expression is a logical array. */
232 logical_array_check (gfc_expr *array, int n)
234 if (array->ts.type != BT_LOGICAL || array->rank == 0)
236 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
237 "array", gfc_current_intrinsic_arg[n]->name,
238 gfc_current_intrinsic, &array->where);
246 /* Make sure an expression is an array. */
249 array_check (gfc_expr *e, int n)
251 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
252 && CLASS_DATA (e)->attr.dimension
253 && CLASS_DATA (e)->as->rank)
255 gfc_add_class_array_ref (e);
262 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
263 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
270 /* If expr is a constant, then check to ensure that it is greater than
274 nonnegative_check (const char *arg, gfc_expr *expr)
278 if (expr->expr_type == EXPR_CONSTANT)
280 gfc_extract_int (expr, &i);
283 gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
292 /* If expr2 is constant, then check that the value is less than
293 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
296 less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
297 gfc_expr *expr2, bool or_equal)
301 if (expr2->expr_type == EXPR_CONSTANT)
303 gfc_extract_int (expr2, &i2);
304 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
306 /* For ISHFT[C], check that |shift| <= bit_size(i). */
312 if (i2 > gfc_integer_kinds[i3].bit_size)
314 gfc_error ("The absolute value of SHIFT at %L must be less "
315 "than or equal to BIT_SIZE('%s')",
316 &expr2->where, arg1);
323 if (i2 > gfc_integer_kinds[i3].bit_size)
325 gfc_error ("'%s' at %L must be less than "
326 "or equal to BIT_SIZE('%s')",
327 arg2, &expr2->where, arg1);
333 if (i2 >= gfc_integer_kinds[i3].bit_size)
335 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
336 arg2, &expr2->where, arg1);
346 /* If expr is constant, then check that the value is less than or equal
347 to the bit_size of the kind k. */
350 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
354 if (expr->expr_type != EXPR_CONSTANT)
357 i = gfc_validate_kind (BT_INTEGER, k, false);
358 gfc_extract_int (expr, &val);
360 if (val > gfc_integer_kinds[i].bit_size)
362 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
363 "INTEGER(KIND=%d)", arg, &expr->where, k);
371 /* If expr2 and expr3 are constants, then check that the value is less than
372 or equal to bit_size(expr1). */
375 less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
376 gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
380 if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
382 gfc_extract_int (expr2, &i2);
383 gfc_extract_int (expr3, &i3);
385 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
386 if (i2 > gfc_integer_kinds[i3].bit_size)
388 gfc_error ("'%s + %s' at %L must be less than or equal "
390 arg2, arg3, &expr2->where, arg1);
398 /* Make sure two expressions have the same type. */
401 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
403 if (gfc_compare_types (&e->ts, &f->ts))
406 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
407 "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
408 gfc_current_intrinsic, &f->where,
409 gfc_current_intrinsic_arg[n]->name);
415 /* Make sure that an expression has a certain (nonzero) rank. */
418 rank_check (gfc_expr *e, int n, int rank)
423 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
424 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
431 /* Make sure a variable expression is not an optional dummy argument. */
434 nonoptional_check (gfc_expr *e, int n)
436 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
438 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
439 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
443 /* TODO: Recursive check on nonoptional variables? */
449 /* Check for ALLOCATABLE attribute. */
452 allocatable_check (gfc_expr *e, int n)
454 symbol_attribute attr;
456 attr = gfc_variable_attr (e, NULL);
457 if (!attr.allocatable)
459 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
460 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
469 /* Check that an expression has a particular kind. */
472 kind_value_check (gfc_expr *e, int n, int k)
477 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
478 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
485 /* Make sure an expression is a variable. */
488 variable_check (gfc_expr *e, int n, bool allow_proc)
490 if (e->expr_type == EXPR_VARIABLE
491 && e->symtree->n.sym->attr.intent == INTENT_IN
492 && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
493 || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
496 bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
497 && CLASS_DATA (e->symtree->n.sym)
498 ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
499 : e->symtree->n.sym->attr.pointer;
501 for (ref = e->ref; ref; ref = ref->next)
503 if (pointer && ref->type == REF_COMPONENT)
505 if (ref->type == REF_COMPONENT
506 && ((ref->u.c.component->ts.type == BT_CLASS
507 && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
508 || (ref->u.c.component->ts.type != BT_CLASS
509 && ref->u.c.component->attr.pointer)))
515 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
516 "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
517 gfc_current_intrinsic, &e->where);
522 if (e->expr_type == EXPR_VARIABLE
523 && e->symtree->n.sym->attr.flavor != FL_PARAMETER
524 && (allow_proc || !e->symtree->n.sym->attr.function))
527 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
528 && e->symtree->n.sym == e->symtree->n.sym->result)
531 for (ns = gfc_current_ns; ns; ns = ns->parent)
532 if (ns->proc_name == e->symtree->n.sym)
536 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
537 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
543 /* Check the common DIM parameter for correctness. */
546 dim_check (gfc_expr *dim, int n, bool optional)
551 if (type_check (dim, n, BT_INTEGER) == FAILURE)
554 if (scalar_check (dim, n) == FAILURE)
557 if (!optional && nonoptional_check (dim, n) == FAILURE)
564 /* If a coarray DIM parameter is a constant, make sure that it is greater than
565 zero and less than or equal to the corank of the given array. */
568 dim_corank_check (gfc_expr *dim, gfc_expr *array)
572 gcc_assert (array->expr_type == EXPR_VARIABLE);
574 if (dim->expr_type != EXPR_CONSTANT)
577 if (array->ts.type == BT_CLASS)
580 corank = gfc_get_corank (array);
582 if (mpz_cmp_ui (dim->value.integer, 1) < 0
583 || mpz_cmp_ui (dim->value.integer, corank) > 0)
585 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
586 "codimension index", gfc_current_intrinsic, &dim->where);
595 /* If a DIM parameter is a constant, make sure that it is greater than
596 zero and less than or equal to the rank of the given array. If
597 allow_assumed is zero then dim must be less than the rank of the array
598 for assumed size arrays. */
601 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
609 if (dim->expr_type != EXPR_CONSTANT)
612 if (array->ts.type == BT_CLASS)
615 if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
616 && array->value.function.isym->id == GFC_ISYM_SPREAD)
617 rank = array->rank + 1;
621 if (array->expr_type == EXPR_VARIABLE)
623 ar = gfc_find_array_ref (array);
624 if (ar->as->type == AS_ASSUMED_SIZE
626 && ar->type != AR_ELEMENT
627 && ar->type != AR_SECTION)
631 if (mpz_cmp_ui (dim->value.integer, 1) < 0
632 || mpz_cmp_ui (dim->value.integer, rank) > 0)
634 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
635 "dimension index", gfc_current_intrinsic, &dim->where);
644 /* Compare the size of a along dimension ai with the size of b along
645 dimension bi, returning 0 if they are known not to be identical,
646 and 1 if they are identical, or if this cannot be determined. */
649 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
651 mpz_t a_size, b_size;
654 gcc_assert (a->rank > ai);
655 gcc_assert (b->rank > bi);
659 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
661 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
663 if (mpz_cmp (a_size, b_size) != 0)
673 /* Calculate the length of a character variable, including substrings.
674 Strip away parentheses if necessary. Return -1 if no length could
678 gfc_var_strlen (const gfc_expr *a)
682 while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
685 for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
692 if (ra->u.ss.start->expr_type == EXPR_CONSTANT
693 && ra->u.ss.end->expr_type == EXPR_CONSTANT)
695 start_a = mpz_get_si (ra->u.ss.start->value.integer);
696 end_a = mpz_get_si (ra->u.ss.end->value.integer);
697 return end_a - start_a + 1;
699 else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
705 if (a->ts.u.cl && a->ts.u.cl->length
706 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
707 return mpz_get_si (a->ts.u.cl->length->value.integer);
708 else if (a->expr_type == EXPR_CONSTANT
709 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
710 return a->value.character.length;
716 /* Check whether two character expressions have the same length;
717 returns SUCCESS if they have or if the length cannot be determined,
718 otherwise return FAILURE and raise a gfc_error. */
721 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
725 len_a = gfc_var_strlen(a);
726 len_b = gfc_var_strlen(b);
728 if (len_a == -1 || len_b == -1 || len_a == len_b)
732 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
733 len_a, len_b, name, &a->where);
739 /***** Check functions *****/
741 /* Check subroutine suitable for intrinsics taking a real argument and
742 a kind argument for the result. */
745 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
747 if (type_check (a, 0, BT_REAL) == FAILURE)
749 if (kind_check (kind, 1, type) == FAILURE)
756 /* Check subroutine suitable for ceiling, floor and nint. */
759 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
761 return check_a_kind (a, kind, BT_INTEGER);
765 /* Check subroutine suitable for aint, anint. */
768 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
770 return check_a_kind (a, kind, BT_REAL);
775 gfc_check_abs (gfc_expr *a)
777 if (numeric_check (a, 0) == FAILURE)
785 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
787 if (type_check (a, 0, BT_INTEGER) == FAILURE)
789 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
797 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
799 if (type_check (name, 0, BT_CHARACTER) == FAILURE
800 || scalar_check (name, 0) == FAILURE)
802 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
805 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
806 || scalar_check (mode, 1) == FAILURE)
808 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
816 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
818 if (logical_array_check (mask, 0) == FAILURE)
821 if (dim_check (dim, 1, false) == FAILURE)
824 if (dim_rank_check (dim, mask, 0) == FAILURE)
832 gfc_check_allocated (gfc_expr *array)
834 if (variable_check (array, 0, false) == FAILURE)
836 if (allocatable_check (array, 0) == FAILURE)
843 /* Common check function where the first argument must be real or
844 integer and the second argument must be the same as the first. */
847 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
849 if (int_or_real_check (a, 0) == FAILURE)
852 if (a->ts.type != p->ts.type)
854 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
855 "have the same type", gfc_current_intrinsic_arg[0]->name,
856 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
861 if (a->ts.kind != p->ts.kind)
863 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
864 &p->where) == FAILURE)
873 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
875 if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
883 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
885 symbol_attribute attr1, attr2;
890 where = &pointer->where;
892 if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
893 attr1 = gfc_expr_attr (pointer);
894 else if (pointer->expr_type == EXPR_NULL)
897 gcc_assert (0); /* Pointer must be a variable or a function. */
899 if (!attr1.pointer && !attr1.proc_pointer)
901 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
902 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
908 if (attr1.pointer && gfc_is_coindexed (pointer))
910 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
911 "conindexed", gfc_current_intrinsic_arg[0]->name,
912 gfc_current_intrinsic, &pointer->where);
916 /* Target argument is optional. */
920 where = &target->where;
921 if (target->expr_type == EXPR_NULL)
924 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
925 attr2 = gfc_expr_attr (target);
928 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
929 "or target VARIABLE or FUNCTION",
930 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
935 if (attr1.pointer && !attr2.pointer && !attr2.target)
937 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
938 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
939 gfc_current_intrinsic, &target->where);
944 if (attr1.pointer && gfc_is_coindexed (target))
946 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
947 "conindexed", gfc_current_intrinsic_arg[1]->name,
948 gfc_current_intrinsic, &target->where);
953 if (same_type_check (pointer, 0, target, 1) == FAILURE)
955 if (rank_check (target, 0, pointer->rank) == FAILURE)
957 if (target->rank > 0)
959 for (i = 0; i < target->rank; i++)
960 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
962 gfc_error ("Array section with a vector subscript at %L shall not "
963 "be the target of a pointer",
973 gfc_error ("NULL pointer at %L is not permitted as actual argument "
974 "of '%s' intrinsic function", where, gfc_current_intrinsic);
981 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
983 /* gfc_notify_std would be a waste of time as the return value
984 is seemingly used only for the generic resolution. The error
985 will be: Too many arguments. */
986 if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
989 return gfc_check_atan2 (y, x);
994 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
996 if (type_check (y, 0, BT_REAL) == FAILURE)
998 if (same_type_check (y, 0, x, 1) == FAILURE)
1006 gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
1008 if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
1009 && !(atom->ts.type == BT_LOGICAL
1010 && atom->ts.kind == gfc_atomic_logical_kind))
1012 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1013 "integer of ATOMIC_INT_KIND or a logical of "
1014 "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
1018 if (!gfc_expr_attr (atom).codimension)
1020 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1021 "coarray or coindexed", &atom->where, gfc_current_intrinsic);
1025 if (atom->ts.type != value->ts.type)
1027 gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
1028 "have the same type at %L", gfc_current_intrinsic,
1038 gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
1040 if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
1043 if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
1045 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1046 "definable", gfc_current_intrinsic, &atom->where);
1050 return gfc_check_atomic (atom, value);
1055 gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
1057 if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
1060 if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
1062 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1063 "definable", gfc_current_intrinsic, &value->where);
1067 return gfc_check_atomic (atom, value);
1071 /* BESJN and BESYN functions. */
1074 gfc_check_besn (gfc_expr *n, gfc_expr *x)
1076 if (type_check (n, 0, BT_INTEGER) == FAILURE)
1078 if (n->expr_type == EXPR_CONSTANT)
1081 gfc_extract_int (n, &i);
1082 if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument "
1083 "N at %L", &n->where) == FAILURE)
1087 if (type_check (x, 1, BT_REAL) == FAILURE)
1094 /* Transformational version of the Bessel JN and YN functions. */
1097 gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1099 if (type_check (n1, 0, BT_INTEGER) == FAILURE)
1101 if (scalar_check (n1, 0) == FAILURE)
1103 if (nonnegative_check("N1", n1) == FAILURE)
1106 if (type_check (n2, 1, BT_INTEGER) == FAILURE)
1108 if (scalar_check (n2, 1) == FAILURE)
1110 if (nonnegative_check("N2", n2) == FAILURE)
1113 if (type_check (x, 2, BT_REAL) == FAILURE)
1115 if (scalar_check (x, 2) == FAILURE)
1123 gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1125 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1128 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1136 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
1138 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1141 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1144 if (nonnegative_check ("pos", pos) == FAILURE)
1147 if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
1155 gfc_check_char (gfc_expr *i, gfc_expr *kind)
1157 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1159 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
1167 gfc_check_chdir (gfc_expr *dir)
1169 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1171 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1179 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
1181 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1183 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1189 if (type_check (status, 1, BT_INTEGER) == FAILURE)
1191 if (scalar_check (status, 1) == FAILURE)
1199 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
1201 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1203 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1206 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1208 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1216 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
1218 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1220 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1223 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1225 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1231 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1234 if (scalar_check (status, 2) == FAILURE)
1242 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
1244 if (numeric_check (x, 0) == FAILURE)
1249 if (numeric_check (y, 1) == FAILURE)
1252 if (x->ts.type == BT_COMPLEX)
1254 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1255 "present if 'x' is COMPLEX",
1256 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1261 if (y->ts.type == BT_COMPLEX)
1263 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1264 "of either REAL or INTEGER",
1265 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1272 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
1280 gfc_check_complex (gfc_expr *x, gfc_expr *y)
1282 if (int_or_real_check (x, 0) == FAILURE)
1284 if (scalar_check (x, 0) == FAILURE)
1287 if (int_or_real_check (y, 1) == FAILURE)
1289 if (scalar_check (y, 1) == FAILURE)
1297 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1299 if (logical_array_check (mask, 0) == FAILURE)
1301 if (dim_check (dim, 1, false) == FAILURE)
1303 if (dim_rank_check (dim, mask, 0) == FAILURE)
1305 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1307 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1308 "with KIND argument at %L",
1309 gfc_current_intrinsic, &kind->where) == FAILURE)
1317 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
1319 if (array_check (array, 0) == FAILURE)
1322 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1325 if (dim_check (dim, 2, true) == FAILURE)
1328 if (dim_rank_check (dim, array, false) == FAILURE)
1331 if (array->rank == 1 || shift->rank == 0)
1333 if (scalar_check (shift, 1) == FAILURE)
1336 else if (shift->rank == array->rank - 1)
1341 else if (dim->expr_type == EXPR_CONSTANT)
1342 gfc_extract_int (dim, &d);
1349 for (i = 0, j = 0; i < array->rank; i++)
1352 if (!identical_dimen_shape (array, i, shift, j))
1354 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1355 "invalid shape in dimension %d (%ld/%ld)",
1356 gfc_current_intrinsic_arg[1]->name,
1357 gfc_current_intrinsic, &shift->where, i + 1,
1358 mpz_get_si (array->shape[i]),
1359 mpz_get_si (shift->shape[j]));
1369 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1370 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1371 gfc_current_intrinsic, &shift->where, array->rank - 1);
1380 gfc_check_ctime (gfc_expr *time)
1382 if (scalar_check (time, 0) == FAILURE)
1385 if (type_check (time, 0, BT_INTEGER) == FAILURE)
1392 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
1394 if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
1401 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
1403 if (numeric_check (x, 0) == FAILURE)
1408 if (numeric_check (y, 1) == FAILURE)
1411 if (x->ts.type == BT_COMPLEX)
1413 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1414 "present if 'x' is COMPLEX",
1415 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1420 if (y->ts.type == BT_COMPLEX)
1422 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1423 "of either REAL or INTEGER",
1424 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1435 gfc_check_dble (gfc_expr *x)
1437 if (numeric_check (x, 0) == FAILURE)
1445 gfc_check_digits (gfc_expr *x)
1447 if (int_or_real_check (x, 0) == FAILURE)
1455 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1457 switch (vector_a->ts.type)
1460 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1467 if (numeric_check (vector_b, 1) == FAILURE)
1472 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1473 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
1474 gfc_current_intrinsic, &vector_a->where);
1478 if (rank_check (vector_a, 0, 1) == FAILURE)
1481 if (rank_check (vector_b, 1, 1) == FAILURE)
1484 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1486 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1487 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
1488 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
1497 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1499 if (type_check (x, 0, BT_REAL) == FAILURE
1500 || type_check (y, 1, BT_REAL) == FAILURE)
1503 if (x->ts.kind != gfc_default_real_kind)
1505 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1506 "real", gfc_current_intrinsic_arg[0]->name,
1507 gfc_current_intrinsic, &x->where);
1511 if (y->ts.kind != gfc_default_real_kind)
1513 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1514 "real", gfc_current_intrinsic_arg[1]->name,
1515 gfc_current_intrinsic, &y->where);
1524 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
1526 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1529 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1532 if (i->is_boz && j->is_boz)
1534 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1535 "constants", &i->where, &j->where);
1539 if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE)
1542 if (type_check (shift, 2, BT_INTEGER) == FAILURE)
1545 if (nonnegative_check ("SHIFT", shift) == FAILURE)
1550 if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE)
1552 i->ts.kind = j->ts.kind;
1556 if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
1558 j->ts.kind = i->ts.kind;
1566 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1569 if (array_check (array, 0) == FAILURE)
1572 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1575 if (dim_check (dim, 3, true) == FAILURE)
1578 if (dim_rank_check (dim, array, false) == FAILURE)
1581 if (array->rank == 1 || shift->rank == 0)
1583 if (scalar_check (shift, 1) == FAILURE)
1586 else if (shift->rank == array->rank - 1)
1591 else if (dim->expr_type == EXPR_CONSTANT)
1592 gfc_extract_int (dim, &d);
1599 for (i = 0, j = 0; i < array->rank; i++)
1602 if (!identical_dimen_shape (array, i, shift, j))
1604 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1605 "invalid shape in dimension %d (%ld/%ld)",
1606 gfc_current_intrinsic_arg[1]->name,
1607 gfc_current_intrinsic, &shift->where, i + 1,
1608 mpz_get_si (array->shape[i]),
1609 mpz_get_si (shift->shape[j]));
1619 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1620 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1621 gfc_current_intrinsic, &shift->where, array->rank - 1);
1625 if (boundary != NULL)
1627 if (same_type_check (array, 0, boundary, 2) == FAILURE)
1630 if (array->rank == 1 || boundary->rank == 0)
1632 if (scalar_check (boundary, 2) == FAILURE)
1635 else if (boundary->rank == array->rank - 1)
1637 if (gfc_check_conformance (shift, boundary,
1638 "arguments '%s' and '%s' for "
1640 gfc_current_intrinsic_arg[1]->name,
1641 gfc_current_intrinsic_arg[2]->name,
1642 gfc_current_intrinsic ) == FAILURE)
1647 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1648 "rank %d or be a scalar",
1649 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1650 &shift->where, array->rank - 1);
1659 gfc_check_float (gfc_expr *a)
1661 if (type_check (a, 0, BT_INTEGER) == FAILURE)
1664 if ((a->ts.kind != gfc_default_integer_kind)
1665 && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER "
1666 "kind argument to %s intrinsic at %L",
1667 gfc_current_intrinsic, &a->where) == FAILURE )
1673 /* A single complex argument. */
1676 gfc_check_fn_c (gfc_expr *a)
1678 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1684 /* A single real argument. */
1687 gfc_check_fn_r (gfc_expr *a)
1689 if (type_check (a, 0, BT_REAL) == FAILURE)
1695 /* A single double argument. */
1698 gfc_check_fn_d (gfc_expr *a)
1700 if (double_check (a, 0) == FAILURE)
1706 /* A single real or complex argument. */
1709 gfc_check_fn_rc (gfc_expr *a)
1711 if (real_or_complex_check (a, 0) == FAILURE)
1719 gfc_check_fn_rc2008 (gfc_expr *a)
1721 if (real_or_complex_check (a, 0) == FAILURE)
1724 if (a->ts.type == BT_COMPLEX
1725 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
1726 "argument of '%s' intrinsic at %L",
1727 gfc_current_intrinsic_arg[0]->name,
1728 gfc_current_intrinsic, &a->where) == FAILURE)
1736 gfc_check_fnum (gfc_expr *unit)
1738 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1741 if (scalar_check (unit, 0) == FAILURE)
1749 gfc_check_huge (gfc_expr *x)
1751 if (int_or_real_check (x, 0) == FAILURE)
1759 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1761 if (type_check (x, 0, BT_REAL) == FAILURE)
1763 if (same_type_check (x, 0, y, 1) == FAILURE)
1770 /* Check that the single argument is an integer. */
1773 gfc_check_i (gfc_expr *i)
1775 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1783 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1785 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1788 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1791 if (i->ts.kind != j->ts.kind)
1793 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1794 &i->where) == FAILURE)
1803 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1805 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1808 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1811 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1814 if (nonnegative_check ("pos", pos) == FAILURE)
1817 if (nonnegative_check ("len", len) == FAILURE)
1820 if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
1828 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1832 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1835 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1838 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1839 "with KIND argument at %L",
1840 gfc_current_intrinsic, &kind->where) == FAILURE)
1843 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1849 /* Substring references don't have the charlength set. */
1851 while (ref && ref->type != REF_SUBSTRING)
1854 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1858 /* Check that the argument is length one. Non-constant lengths
1859 can't be checked here, so assume they are ok. */
1860 if (c->ts.u.cl && c->ts.u.cl->length)
1862 /* If we already have a length for this expression then use it. */
1863 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1865 i = mpz_get_si (c->ts.u.cl->length->value.integer);
1872 start = ref->u.ss.start;
1873 end = ref->u.ss.end;
1876 if (end == NULL || end->expr_type != EXPR_CONSTANT
1877 || start->expr_type != EXPR_CONSTANT)
1880 i = mpz_get_si (end->value.integer) + 1
1881 - mpz_get_si (start->value.integer);
1889 gfc_error ("Argument of %s at %L must be of length one",
1890 gfc_current_intrinsic, &c->where);
1899 gfc_check_idnint (gfc_expr *a)
1901 if (double_check (a, 0) == FAILURE)
1909 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1911 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1914 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1917 if (i->ts.kind != j->ts.kind)
1919 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1920 &i->where) == FAILURE)
1929 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1932 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1933 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1936 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1939 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1941 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1942 "with KIND argument at %L",
1943 gfc_current_intrinsic, &kind->where) == FAILURE)
1946 if (string->ts.kind != substring->ts.kind)
1948 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1949 "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
1950 gfc_current_intrinsic, &substring->where,
1951 gfc_current_intrinsic_arg[0]->name);
1960 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1962 if (numeric_check (x, 0) == FAILURE)
1965 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1973 gfc_check_intconv (gfc_expr *x)
1975 if (numeric_check (x, 0) == FAILURE)
1983 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1985 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1988 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1991 if (i->ts.kind != j->ts.kind)
1993 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1994 &i->where) == FAILURE)
2003 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
2005 if (type_check (i, 0, BT_INTEGER) == FAILURE
2006 || type_check (shift, 1, BT_INTEGER) == FAILURE)
2009 if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
2017 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
2019 if (type_check (i, 0, BT_INTEGER) == FAILURE
2020 || type_check (shift, 1, BT_INTEGER) == FAILURE)
2027 if (type_check (size, 2, BT_INTEGER) == FAILURE)
2030 if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE)
2033 if (size->expr_type == EXPR_CONSTANT)
2035 gfc_extract_int (size, &i3);
2038 gfc_error ("SIZE at %L must be positive", &size->where);
2042 if (shift->expr_type == EXPR_CONSTANT)
2044 gfc_extract_int (shift, &i2);
2050 gfc_error ("The absolute value of SHIFT at %L must be less "
2051 "than or equal to SIZE at %L", &shift->where,
2058 else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
2066 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
2068 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2071 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2079 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
2081 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2084 if (scalar_check (pid, 0) == FAILURE)
2087 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2090 if (scalar_check (sig, 1) == FAILURE)
2096 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2099 if (scalar_check (status, 2) == FAILURE)
2107 gfc_check_kind (gfc_expr *x)
2109 if (x->ts.type == BT_DERIVED)
2111 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2112 "non-derived type", gfc_current_intrinsic_arg[0]->name,
2113 gfc_current_intrinsic, &x->where);
2122 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2124 if (array_check (array, 0) == FAILURE)
2127 if (dim_check (dim, 1, false) == FAILURE)
2130 if (dim_rank_check (dim, array, 1) == FAILURE)
2133 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2135 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2136 "with KIND argument at %L",
2137 gfc_current_intrinsic, &kind->where) == FAILURE)
2145 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
2147 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2149 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2153 if (coarray_check (coarray, 0) == FAILURE)
2158 if (dim_check (dim, 1, false) == FAILURE)
2161 if (dim_corank_check (dim, coarray) == FAILURE)
2165 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2173 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
2175 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
2178 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2180 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2181 "with KIND argument at %L",
2182 gfc_current_intrinsic, &kind->where) == FAILURE)
2190 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
2192 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2194 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
2197 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
2199 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
2207 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
2209 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2211 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2214 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2216 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2224 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2226 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2228 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2231 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2233 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
2239 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2242 if (scalar_check (status, 2) == FAILURE)
2250 gfc_check_loc (gfc_expr *expr)
2252 return variable_check (expr, 0, true);
2257 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
2259 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2261 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2264 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2266 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2274 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2276 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2278 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2281 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2283 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2289 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2292 if (scalar_check (status, 2) == FAILURE)
2300 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
2302 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
2304 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
2311 /* Min/max family. */
2314 min_max_args (gfc_actual_arglist *arg)
2316 if (arg == NULL || arg->next == NULL)
2318 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2319 gfc_current_intrinsic, gfc_current_intrinsic_where);
2328 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
2330 gfc_actual_arglist *arg, *tmp;
2335 if (min_max_args (arglist) == FAILURE)
2338 for (arg = arglist, n=1; arg; arg = arg->next, n++)
2341 if (x->ts.type != type || x->ts.kind != kind)
2343 if (x->ts.type == type)
2345 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
2346 "kinds at %L", &x->where) == FAILURE)
2351 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2352 "%s(%d)", n, gfc_current_intrinsic, &x->where,
2353 gfc_basic_typename (type), kind);
2358 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
2359 if (gfc_check_conformance (tmp->expr, x,
2360 "arguments 'a%d' and 'a%d' for "
2361 "intrinsic '%s'", m, n,
2362 gfc_current_intrinsic) == FAILURE)
2371 gfc_check_min_max (gfc_actual_arglist *arg)
2375 if (min_max_args (arg) == FAILURE)
2380 if (x->ts.type == BT_CHARACTER)
2382 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2383 "with CHARACTER argument at %L",
2384 gfc_current_intrinsic, &x->where) == FAILURE)
2387 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
2389 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2390 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
2394 return check_rest (x->ts.type, x->ts.kind, arg);
2399 gfc_check_min_max_integer (gfc_actual_arglist *arg)
2401 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
2406 gfc_check_min_max_real (gfc_actual_arglist *arg)
2408 return check_rest (BT_REAL, gfc_default_real_kind, arg);
2413 gfc_check_min_max_double (gfc_actual_arglist *arg)
2415 return check_rest (BT_REAL, gfc_default_double_kind, arg);
2419 /* End of min/max family. */
2422 gfc_check_malloc (gfc_expr *size)
2424 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2427 if (scalar_check (size, 0) == FAILURE)
2435 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
2437 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
2439 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2440 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2441 gfc_current_intrinsic, &matrix_a->where);
2445 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2447 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2448 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
2449 gfc_current_intrinsic, &matrix_b->where);
2453 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2454 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2456 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2457 gfc_current_intrinsic, &matrix_a->where,
2458 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2462 switch (matrix_a->rank)
2465 if (rank_check (matrix_b, 1, 2) == FAILURE)
2467 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2468 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2470 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2471 "and '%s' at %L for intrinsic matmul",
2472 gfc_current_intrinsic_arg[0]->name,
2473 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2479 if (matrix_b->rank != 2)
2481 if (rank_check (matrix_b, 1, 1) == FAILURE)
2484 /* matrix_b has rank 1 or 2 here. Common check for the cases
2485 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2486 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2487 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2489 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2490 "dimension 1 for argument '%s' at %L for intrinsic "
2491 "matmul", gfc_current_intrinsic_arg[0]->name,
2492 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2498 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2499 "1 or 2", gfc_current_intrinsic_arg[0]->name,
2500 gfc_current_intrinsic, &matrix_a->where);
2508 /* Whoever came up with this interface was probably on something.
2509 The possibilities for the occupation of the second and third
2516 NULL MASK minloc(array, mask=m)
2519 I.e. in the case of minloc(array,mask), mask will be in the second
2520 position of the argument list and we'll have to fix that up. */
2523 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2525 gfc_expr *a, *m, *d;
2528 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
2532 m = ap->next->next->expr;
2534 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2535 && ap->next->name == NULL)
2539 ap->next->expr = NULL;
2540 ap->next->next->expr = m;
2543 if (dim_check (d, 1, false) == FAILURE)
2546 if (dim_rank_check (d, a, 0) == FAILURE)
2549 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2553 && gfc_check_conformance (a, m,
2554 "arguments '%s' and '%s' for intrinsic %s",
2555 gfc_current_intrinsic_arg[0]->name,
2556 gfc_current_intrinsic_arg[2]->name,
2557 gfc_current_intrinsic ) == FAILURE)
2564 /* Similar to minloc/maxloc, the argument list might need to be
2565 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2566 difference is that MINLOC/MAXLOC take an additional KIND argument.
2567 The possibilities are:
2573 NULL MASK minval(array, mask=m)
2576 I.e. in the case of minval(array,mask), mask will be in the second
2577 position of the argument list and we'll have to fix that up. */
2580 check_reduction (gfc_actual_arglist *ap)
2582 gfc_expr *a, *m, *d;
2586 m = ap->next->next->expr;
2588 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2589 && ap->next->name == NULL)
2593 ap->next->expr = NULL;
2594 ap->next->next->expr = m;
2597 if (dim_check (d, 1, false) == FAILURE)
2600 if (dim_rank_check (d, a, 0) == FAILURE)
2603 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2607 && gfc_check_conformance (a, m,
2608 "arguments '%s' and '%s' for intrinsic %s",
2609 gfc_current_intrinsic_arg[0]->name,
2610 gfc_current_intrinsic_arg[2]->name,
2611 gfc_current_intrinsic) == FAILURE)
2619 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2621 if (int_or_real_check (ap->expr, 0) == FAILURE
2622 || array_check (ap->expr, 0) == FAILURE)
2625 return check_reduction (ap);
2630 gfc_check_product_sum (gfc_actual_arglist *ap)
2632 if (numeric_check (ap->expr, 0) == FAILURE
2633 || array_check (ap->expr, 0) == FAILURE)
2636 return check_reduction (ap);
2640 /* For IANY, IALL and IPARITY. */
2643 gfc_check_mask (gfc_expr *i, gfc_expr *kind)
2647 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2650 if (nonnegative_check ("I", i) == FAILURE)
2653 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2657 gfc_extract_int (kind, &k);
2659 k = gfc_default_integer_kind;
2661 if (less_than_bitsizekind ("I", i, k) == FAILURE)
2669 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
2671 if (ap->expr->ts.type != BT_INTEGER)
2673 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2674 gfc_current_intrinsic_arg[0]->name,
2675 gfc_current_intrinsic, &ap->expr->where);
2679 if (array_check (ap->expr, 0) == FAILURE)
2682 return check_reduction (ap);
2687 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2689 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2692 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2695 if (tsource->ts.type == BT_CHARACTER)
2696 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2703 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
2705 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2708 if (type_check (j, 1, BT_INTEGER) == FAILURE)
2711 if (type_check (mask, 2, BT_INTEGER) == FAILURE)
2714 if (same_type_check (i, 0, j, 1) == FAILURE)
2717 if (same_type_check (i, 0, mask, 2) == FAILURE)
2725 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2727 if (variable_check (from, 0, false) == FAILURE)
2729 if (allocatable_check (from, 0) == FAILURE)
2732 if (variable_check (to, 1, false) == FAILURE)
2734 if (allocatable_check (to, 1) == FAILURE)
2737 if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
2739 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2740 "polymorphic if FROM is polymorphic",
2745 if (same_type_check (to, 1, from, 0) == FAILURE)
2748 if (to->rank != from->rank)
2750 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2751 "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
2752 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2753 &to->where, from->rank, to->rank);
2757 if (to->ts.kind != from->ts.kind)
2759 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2760 "be of the same kind %d/%d",
2761 gfc_current_intrinsic_arg[0]->name,
2762 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2763 &to->where, from->ts.kind, to->ts.kind);
2767 /* CLASS arguments: Make sure the vtab of from is present. */
2768 if (to->ts.type == BT_CLASS)
2769 gfc_find_derived_vtab (from->ts.u.derived);
2776 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2778 if (type_check (x, 0, BT_REAL) == FAILURE)
2781 if (type_check (s, 1, BT_REAL) == FAILURE)
2784 if (s->expr_type == EXPR_CONSTANT)
2786 if (mpfr_sgn (s->value.real) == 0)
2788 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2799 gfc_check_new_line (gfc_expr *a)
2801 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2809 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
2811 if (type_check (array, 0, BT_REAL) == FAILURE)
2814 if (array_check (array, 0) == FAILURE)
2817 if (dim_rank_check (dim, array, false) == FAILURE)
2824 gfc_check_null (gfc_expr *mold)
2826 symbol_attribute attr;
2831 if (variable_check (mold, 0, true) == FAILURE)
2834 attr = gfc_variable_attr (mold, NULL);
2836 if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
2838 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2839 "ALLOCATABLE or procedure pointer",
2840 gfc_current_intrinsic_arg[0]->name,
2841 gfc_current_intrinsic, &mold->where);
2845 if (attr.allocatable
2846 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with "
2847 "allocatable MOLD at %L", &mold->where) == FAILURE)
2851 if (gfc_is_coindexed (mold))
2853 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2854 "conindexed", gfc_current_intrinsic_arg[0]->name,
2855 gfc_current_intrinsic, &mold->where);
2864 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2866 if (array_check (array, 0) == FAILURE)
2869 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2872 if (gfc_check_conformance (array, mask,
2873 "arguments '%s' and '%s' for intrinsic '%s'",
2874 gfc_current_intrinsic_arg[0]->name,
2875 gfc_current_intrinsic_arg[1]->name,
2876 gfc_current_intrinsic) == FAILURE)
2881 mpz_t array_size, vector_size;
2882 bool have_array_size, have_vector_size;
2884 if (same_type_check (array, 0, vector, 2) == FAILURE)
2887 if (rank_check (vector, 2, 1) == FAILURE)
2890 /* VECTOR requires at least as many elements as MASK
2891 has .TRUE. values. */
2892 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2893 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2895 if (have_vector_size
2896 && (mask->expr_type == EXPR_ARRAY
2897 || (mask->expr_type == EXPR_CONSTANT
2898 && have_array_size)))
2900 int mask_true_values = 0;
2902 if (mask->expr_type == EXPR_ARRAY)
2904 gfc_constructor *mask_ctor;
2905 mask_ctor = gfc_constructor_first (mask->value.constructor);
2908 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2910 mask_true_values = 0;
2914 if (mask_ctor->expr->value.logical)
2917 mask_ctor = gfc_constructor_next (mask_ctor);
2920 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2921 mask_true_values = mpz_get_si (array_size);
2923 if (mpz_get_si (vector_size) < mask_true_values)
2925 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2926 "provide at least as many elements as there "
2927 "are .TRUE. values in '%s' (%ld/%d)",
2928 gfc_current_intrinsic_arg[2]->name,
2929 gfc_current_intrinsic, &vector->where,
2930 gfc_current_intrinsic_arg[1]->name,
2931 mpz_get_si (vector_size), mask_true_values);
2936 if (have_array_size)
2937 mpz_clear (array_size);
2938 if (have_vector_size)
2939 mpz_clear (vector_size);
2947 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
2949 if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
2952 if (array_check (mask, 0) == FAILURE)
2955 if (dim_rank_check (dim, mask, false) == FAILURE)
2963 gfc_check_precision (gfc_expr *x)
2965 if (real_or_complex_check (x, 0) == FAILURE)
2973 gfc_check_present (gfc_expr *a)
2977 if (variable_check (a, 0, true) == FAILURE)
2980 sym = a->symtree->n.sym;
2981 if (!sym->attr.dummy)
2983 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2984 "dummy variable", gfc_current_intrinsic_arg[0]->name,
2985 gfc_current_intrinsic, &a->where);
2989 if (!sym->attr.optional)
2991 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2992 "an OPTIONAL dummy variable",
2993 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2998 /* 13.14.82 PRESENT(A)
3000 Argument. A shall be the name of an optional dummy argument that is
3001 accessible in the subprogram in which the PRESENT function reference
3005 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
3006 && (a->ref->u.ar.type == AR_FULL
3007 || (a->ref->u.ar.type == AR_ELEMENT
3008 && a->ref->u.ar.as->rank == 0))))
3010 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3011 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
3012 gfc_current_intrinsic, &a->where, sym->name);
3021 gfc_check_radix (gfc_expr *x)
3023 if (int_or_real_check (x, 0) == FAILURE)
3031 gfc_check_range (gfc_expr *x)
3033 if (numeric_check (x, 0) == FAILURE)
3041 gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
3043 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3044 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3046 bool is_variable = true;
3048 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3049 if (a->expr_type == EXPR_FUNCTION)
3050 is_variable = a->value.function.esym
3051 ? a->value.function.esym->result->attr.pointer
3052 : a->symtree->n.sym->result->attr.pointer;
3054 if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
3055 || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
3058 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3059 "object", &a->where);
3067 /* real, float, sngl. */
3069 gfc_check_real (gfc_expr *a, gfc_expr *kind)
3071 if (numeric_check (a, 0) == FAILURE)
3074 if (kind_check (kind, 1, BT_REAL) == FAILURE)
3082 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
3084 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3086 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3089 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3091 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3099 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3101 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3103 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3106 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3108 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3114 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3117 if (scalar_check (status, 2) == FAILURE)
3125 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
3127 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3130 if (scalar_check (x, 0) == FAILURE)
3133 if (type_check (y, 0, BT_INTEGER) == FAILURE)
3136 if (scalar_check (y, 1) == FAILURE)
3144 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
3145 gfc_expr *pad, gfc_expr *order)
3151 if (array_check (source, 0) == FAILURE)
3154 if (rank_check (shape, 1, 1) == FAILURE)
3157 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
3160 if (gfc_array_size (shape, &size) != SUCCESS)
3162 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3163 "array of constant size", &shape->where);
3167 shape_size = mpz_get_ui (size);
3170 if (shape_size <= 0)
3172 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3173 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3177 else if (shape_size > GFC_MAX_DIMENSIONS)
3179 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3180 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
3183 else if (shape->expr_type == EXPR_ARRAY)
3187 for (i = 0; i < shape_size; ++i)
3189 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
3190 if (e->expr_type != EXPR_CONSTANT)
3193 gfc_extract_int (e, &extent);
3196 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3197 "negative element (%d)",
3198 gfc_current_intrinsic_arg[1]->name,
3199 gfc_current_intrinsic, &e->where, extent);
3207 if (same_type_check (source, 0, pad, 2) == FAILURE)
3210 if (array_check (pad, 2) == FAILURE)
3216 if (array_check (order, 3) == FAILURE)
3219 if (type_check (order, 3, BT_INTEGER) == FAILURE)
3222 if (order->expr_type == EXPR_ARRAY)
3224 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
3227 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
3230 gfc_array_size (order, &size);
3231 order_size = mpz_get_ui (size);
3234 if (order_size != shape_size)
3236 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3237 "has wrong number of elements (%d/%d)",
3238 gfc_current_intrinsic_arg[3]->name,
3239 gfc_current_intrinsic, &order->where,
3240 order_size, shape_size);
3244 for (i = 1; i <= order_size; ++i)
3246 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
3247 if (e->expr_type != EXPR_CONSTANT)
3250 gfc_extract_int (e, &dim);
3252 if (dim < 1 || dim > order_size)
3254 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3255 "has out-of-range dimension (%d)",
3256 gfc_current_intrinsic_arg[3]->name,
3257 gfc_current_intrinsic, &e->where, dim);
3261 if (perm[dim-1] != 0)
3263 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3264 "invalid permutation of dimensions (dimension "
3266 gfc_current_intrinsic_arg[3]->name,
3267 gfc_current_intrinsic, &e->where, dim);
3276 if (pad == NULL && shape->expr_type == EXPR_ARRAY
3277 && gfc_is_constant_expr (shape)
3278 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
3279 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
3281 /* Check the match in size between source and destination. */
3282 if (gfc_array_size (source, &nelems) == SUCCESS)
3288 mpz_init_set_ui (size, 1);
3289 for (c = gfc_constructor_first (shape->value.constructor);
3290 c; c = gfc_constructor_next (c))
3291 mpz_mul (size, size, c->expr->value.integer);
3293 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
3299 gfc_error ("Without padding, there are not enough elements "
3300 "in the intrinsic RESHAPE source at %L to match "
3301 "the shape", &source->where);
3312 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
3315 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
3317 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3318 "must be of a derived type",
3319 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3324 if (!gfc_type_is_extensible (a->ts.u.derived))
3326 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3327 "must be of an extensible type",
3328 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3333 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
3335 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3336 "must be of a derived type",
3337 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3342 if (!gfc_type_is_extensible (b->ts.u.derived))
3344 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3345 "must be of an extensible type",
3346 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3356 gfc_check_scale (gfc_expr *x, gfc_expr *i)
3358 if (type_check (x, 0, BT_REAL) == FAILURE)
3361 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3369 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3371 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3374 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
3377 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3380 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3382 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3383 "with KIND argument at %L",
3384 gfc_current_intrinsic, &kind->where) == FAILURE)
3387 if (same_type_check (x, 0, y, 1) == FAILURE)
3395 gfc_check_secnds (gfc_expr *r)
3397 if (type_check (r, 0, BT_REAL) == FAILURE)
3400 if (kind_value_check (r, 0, 4) == FAILURE)
3403 if (scalar_check (r, 0) == FAILURE)
3411 gfc_check_selected_char_kind (gfc_expr *name)
3413 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3416 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3419 if (scalar_check (name, 0) == FAILURE)
3427 gfc_check_selected_int_kind (gfc_expr *r)
3429 if (type_check (r, 0, BT_INTEGER) == FAILURE)
3432 if (scalar_check (r, 0) == FAILURE)
3440 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
3442 if (p == NULL && r == NULL
3443 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
3444 " neither 'P' nor 'R' argument at %L",
3445 gfc_current_intrinsic_where) == FAILURE)
3450 if (type_check (p, 0, BT_INTEGER) == FAILURE)
3453 if (scalar_check (p, 0) == FAILURE)
3459 if (type_check (r, 1, BT_INTEGER) == FAILURE)
3462 if (scalar_check (r, 1) == FAILURE)
3468 if (type_check (radix, 1, BT_INTEGER) == FAILURE)
3471 if (scalar_check (radix, 1) == FAILURE)
3474 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
3475 "RADIX argument at %L", gfc_current_intrinsic,
3476 &radix->where) == FAILURE)
3485 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
3487 if (type_check (x, 0, BT_REAL) == FAILURE)
3490 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3498 gfc_check_shape (gfc_expr *source, gfc_expr *kind)
3502 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3505 ar = gfc_find_array_ref (source);
3507 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
3509 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3510 "an assumed size array", &source->where);
3514 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
3516 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3517 "with KIND argument at %L",
3518 gfc_current_intrinsic, &kind->where) == FAILURE)
3526 gfc_check_shift (gfc_expr *i, gfc_expr *shift)
3528 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3531 if (type_check (shift, 0, BT_INTEGER) == FAILURE)
3534 if (nonnegative_check ("SHIFT", shift) == FAILURE)
3537 if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
3545 gfc_check_sign (gfc_expr *a, gfc_expr *b)
3547 if (int_or_real_check (a, 0) == FAILURE)
3550 if (same_type_check (a, 0, b, 1) == FAILURE)
3558 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3560 if (array_check (array, 0) == FAILURE)
3563 if (dim_check (dim, 1, true) == FAILURE)
3566 if (dim_rank_check (dim, array, 0) == FAILURE)
3569 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3571 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3572 "with KIND argument at %L",
3573 gfc_current_intrinsic, &kind->where) == FAILURE)
3582 gfc_check_sizeof (gfc_expr *arg)
3584 if (arg->ts.type == BT_PROCEDURE)
3586 gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
3587 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3596 gfc_check_c_sizeof (gfc_expr *arg)
3598 if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
3600 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3601 "interoperable data entity",
3602 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3611 gfc_check_sleep_sub (gfc_expr *seconds)
3613 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3616 if (scalar_check (seconds, 0) == FAILURE)
3623 gfc_check_sngl (gfc_expr *a)
3625 if (type_check (a, 0, BT_REAL) == FAILURE)
3628 if ((a->ts.kind != gfc_default_double_kind)
3629 && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision "
3630 "REAL argument to %s intrinsic at %L",
3631 gfc_current_intrinsic, &a->where) == FAILURE)
3638 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
3640 if (source->rank >= GFC_MAX_DIMENSIONS)
3642 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3643 "than rank %d", gfc_current_intrinsic_arg[0]->name,
3644 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
3652 if (dim_check (dim, 1, false) == FAILURE)
3655 /* dim_rank_check() does not apply here. */
3657 && dim->expr_type == EXPR_CONSTANT
3658 && (mpz_cmp_ui (dim->value.integer, 1) < 0
3659 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
3661 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3662 "dimension index", gfc_current_intrinsic_arg[1]->name,
3663 gfc_current_intrinsic, &dim->where);
3667 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
3670 if (scalar_check (ncopies, 2) == FAILURE)
3677 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3681 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3683 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3686 if (scalar_check (unit, 0) == FAILURE)
3689 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3691 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3697 if (type_check (status, 2, BT_INTEGER) == FAILURE
3698 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3699 || scalar_check (status, 2) == FAILURE)
3707 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3709 return gfc_check_fgetputc_sub (unit, c, NULL);
3714 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3716 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3718 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3724 if (type_check (status, 1, BT_INTEGER) == FAILURE
3725 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3726 || scalar_check (status, 1) == FAILURE)
3734 gfc_check_fgetput (gfc_expr *c)
3736 return gfc_check_fgetput_sub (c, NULL);
3741 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3743 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3746 if (scalar_check (unit, 0) == FAILURE)
3749 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3752 if (scalar_check (offset, 1) == FAILURE)
3755 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3758 if (scalar_check (whence, 2) == FAILURE)
3764 if (type_check (status, 3, BT_INTEGER) == FAILURE)
3767 if (kind_value_check (status, 3, 4) == FAILURE)
3770 if (scalar_check (status, 3) == FAILURE)
3779 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
3781 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3784 if (scalar_check (unit, 0) == FAILURE)
3787 if (type_check (array, 1, BT_INTEGER) == FAILURE
3788 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
3791 if (array_check (array, 1) == FAILURE)
3799 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3801 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3804 if (scalar_check (unit, 0) == FAILURE)
3807 if (type_check (array, 1, BT_INTEGER) == FAILURE
3808 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3811 if (array_check (array, 1) == FAILURE)
3817 if (type_check (status, 2, BT_INTEGER) == FAILURE
3818 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3821 if (scalar_check (status, 2) == FAILURE)
3829 gfc_check_ftell (gfc_expr *unit)
3831 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3834 if (scalar_check (unit, 0) == FAILURE)
3842 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3844 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3847 if (scalar_check (unit, 0) == FAILURE)
3850 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3853 if (scalar_check (offset, 1) == FAILURE)
3861 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3863 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3865 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3868 if (type_check (array, 1, BT_INTEGER) == FAILURE
3869 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3872 if (array_check (array, 1) == FAILURE)
3880 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3882 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3884 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3887 if (type_check (array, 1, BT_INTEGER) == FAILURE
3888 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3891 if (array_check (array, 1) == FAILURE)
3897 if (type_check (status, 2, BT_INTEGER) == FAILURE
3898 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3901 if (scalar_check (status, 2) == FAILURE)
3909 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3913 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3915 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3919 if (coarray_check (coarray, 0) == FAILURE)
3924 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3925 gfc_current_intrinsic_arg[1]->name, &sub->where);
3929 if (gfc_array_size (sub, &nelems) == SUCCESS)
3931 int corank = gfc_get_corank (coarray);
3933 if (mpz_cmp_ui (nelems, corank) != 0)
3935 gfc_error ("The number of array elements of the SUB argument to "
3936 "IMAGE_INDEX at %L shall be %d (corank) not %d",
3937 &sub->where, corank, (int) mpz_get_si (nelems));
3949 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3951 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3953 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3957 if (dim != NULL && coarray == NULL)
3959 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3960 "intrinsic at %L", &dim->where);
3964 if (coarray == NULL)
3967 if (coarray_check (coarray, 0) == FAILURE)
3972 if (dim_check (dim, 1, false) == FAILURE)
3975 if (dim_corank_check (dim, coarray) == FAILURE)
3982 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
3983 by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
3986 gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
3987 size_t *source_size, size_t *result_size,
3988 size_t *result_length_p)
3991 size_t result_elt_size;
3993 gfc_expr *mold_element;
3995 if (source->expr_type == EXPR_FUNCTION)
3998 /* Calculate the size of the source. */
3999 if (source->expr_type == EXPR_ARRAY
4000 && gfc_array_size (source, &tmp) == FAILURE)
4003 *source_size = gfc_target_expr_size (source);
4005 mold_element = mold->expr_type == EXPR_ARRAY
4006 ? gfc_constructor_first (mold->value.constructor)->expr
4009 /* Determine the size of the element. */
4010 result_elt_size = gfc_target_expr_size (mold_element);
4011 if (result_elt_size == 0)
4014 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4019 result_length = (size_t)mpz_get_ui (size->value.integer);
4022 result_length = *source_size / result_elt_size;
4023 if (result_length * result_elt_size < *source_size)
4027 *result_size = result_length * result_elt_size;
4028 if (result_length_p)
4029 *result_length_p = result_length;
4032 *result_size = result_elt_size;
4039 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4044 if (mold->ts.type == BT_HOLLERITH)
4046 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4047 &mold->where, gfc_basic_typename (BT_HOLLERITH));
4053 if (type_check (size, 2, BT_INTEGER) == FAILURE)
4056 if (scalar_check (size, 2) == FAILURE)
4059 if (nonoptional_check (size, 2) == FAILURE)
4063 if (!gfc_option.warn_surprising)
4066 /* If we can't calculate the sizes, we cannot check any more.
4067 Return SUCCESS for that case. */
4069 if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
4070 &result_size, NULL) == FAILURE)
4073 if (source_size < result_size)
4074 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4075 "source size %ld < result size %ld", &source->where,
4076 (long) source_size, (long) result_size);
4083 gfc_check_transpose (gfc_expr *matrix)
4085 if (rank_check (matrix, 0, 2) == FAILURE)
4093 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4095 if (array_check (array, 0) == FAILURE)
4098 if (dim_check (dim, 1, false) == FAILURE)
4101 if (dim_rank_check (dim, array, 0) == FAILURE)
4104 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4106 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4107 "with KIND argument at %L",
4108 gfc_current_intrinsic, &kind->where) == FAILURE)
4116 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
4118 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4120 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4124 if (coarray_check (coarray, 0) == FAILURE)
4129 if (dim_check (dim, 1, false) == FAILURE)
4132 if (dim_corank_check (dim, coarray) == FAILURE)
4136 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4144 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
4148 if (rank_check (vector, 0, 1) == FAILURE)
4151 if (array_check (mask, 1) == FAILURE)
4154 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
4157 if (same_type_check (vector, 0, field, 2) == FAILURE)
4160 if (mask->expr_type == EXPR_ARRAY
4161 && gfc_array_size (vector, &vector_size) == SUCCESS)
4163 int mask_true_count = 0;
4164 gfc_constructor *mask_ctor;
4165 mask_ctor = gfc_constructor_first (mask->value.constructor);
4168 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4170 mask_true_count = 0;
4174 if (mask_ctor->expr->value.logical)
4177 mask_ctor = gfc_constructor_next (mask_ctor);
4180 if (mpz_get_si (vector_size) < mask_true_count)
4182 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4183 "provide at least as many elements as there "
4184 "are .TRUE. values in '%s' (%ld/%d)",
4185 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4186 &vector->where, gfc_current_intrinsic_arg[1]->name,
4187 mpz_get_si (vector_size), mask_true_count);
4191 mpz_clear (vector_size);
4194 if (mask->rank != field->rank && field->rank != 0)
4196 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4197 "the same rank as '%s' or be a scalar",
4198 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4199 &field->where, gfc_current_intrinsic_arg[1]->name);
4203 if (mask->rank == field->rank)
4206 for (i = 0; i < field->rank; i++)
4207 if (! identical_dimen_shape (mask, i, field, i))
4209 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4210 "must have identical shape.",
4211 gfc_current_intrinsic_arg[2]->name,
4212 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4222 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4224 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4227 if (same_type_check (x, 0, y, 1) == FAILURE)
4230 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
4233 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
4235 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4236 "with KIND argument at %L",
4237 gfc_current_intrinsic, &kind->where) == FAILURE)
4245 gfc_check_trim (gfc_expr *x)
4247 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4250 if (scalar_check (x, 0) == FAILURE)
4258 gfc_check_ttynam (gfc_expr *unit)
4260 if (scalar_check (unit, 0) == FAILURE)
4263 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4270 /* Common check function for the half a dozen intrinsics that have a
4271 single real argument. */
4274 gfc_check_x (gfc_expr *x)
4276 if (type_check (x, 0, BT_REAL) == FAILURE)
4283 /************* Check functions for intrinsic subroutines *************/
4286 gfc_check_cpu_time (gfc_expr *time)
4288 if (scalar_check (time, 0) == FAILURE)
4291 if (type_check (time, 0, BT_REAL) == FAILURE)
4294 if (variable_check (time, 0, false) == FAILURE)
4302 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
4303 gfc_expr *zone, gfc_expr *values)
4307 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4309 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4311 if (scalar_check (date, 0) == FAILURE)
4313 if (variable_check (date, 0, false) == FAILURE)
4319 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
4321 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
4323 if (scalar_check (time, 1) == FAILURE)
4325 if (variable_check (time, 1, false) == FAILURE)
4331 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
4333 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
4335 if (scalar_check (zone, 2) == FAILURE)
4337 if (variable_check (zone, 2, false) == FAILURE)
4343 if (type_check (values, 3, BT_INTEGER) == FAILURE)
4345 if (array_check (values, 3) == FAILURE)
4347 if (rank_check (values, 3, 1) == FAILURE)
4349 if (variable_check (values, 3, false) == FAILURE)
4358 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
4359 gfc_expr *to, gfc_expr *topos)
4361 if (type_check (from, 0, BT_INTEGER) == FAILURE)
4364 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
4367 if (type_check (len, 2, BT_INTEGER) == FAILURE)
4370 if (same_type_check (from, 0, to, 3) == FAILURE)
4373 if (variable_check (to, 3, false) == FAILURE)
4376 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
4379 if (nonnegative_check ("frompos", frompos) == FAILURE)
4382 if (nonnegative_check ("topos", topos) == FAILURE)
4385 if (nonnegative_check ("len", len) == FAILURE)
4388 if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
4392 if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
4400 gfc_check_random_number (gfc_expr *harvest)
4402 if (type_check (harvest, 0, BT_REAL) == FAILURE)
4405 if (variable_check (harvest, 0, false) == FAILURE)
4413 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
4415 unsigned int nargs = 0, kiss_size;
4416 locus *where = NULL;
4417 mpz_t put_size, get_size;
4418 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4420 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
4422 /* Keep the number of bytes in sync with kiss_size in
4423 libgfortran/intrinsics/random.c. */
4424 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
4428 if (size->expr_type != EXPR_VARIABLE
4429 || !size->symtree->n.sym->attr.optional)
4432 if (scalar_check (size, 0) == FAILURE)
4435 if (type_check (size, 0, BT_INTEGER) == FAILURE)
4438 if (variable_check (size, 0, false) == FAILURE)
4441 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
4447 if (put->expr_type != EXPR_VARIABLE
4448 || !put->symtree->n.sym->attr.optional)
4451 where = &put->where;
4454 if (array_check (put, 1) == FAILURE)
4457 if (rank_check (put, 1, 1) == FAILURE)
4460 if (type_check (put, 1, BT_INTEGER) == FAILURE)
4463 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
4466 if (gfc_array_size (put, &put_size) == SUCCESS
4467 && mpz_get_ui (put_size) < kiss_size)
4468 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4469 "too small (%i/%i)",
4470 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4471 where, (int) mpz_get_ui (put_size), kiss_size);
4476 if (get->expr_type != EXPR_VARIABLE
4477 || !get->symtree->n.sym->attr.optional)
4480 where = &get->where;
4483 if (array_check (get, 2) == FAILURE)
4486 if (rank_check (get, 2, 1) == FAILURE)
4489 if (type_check (get, 2, BT_INTEGER) == FAILURE)
4492 if (variable_check (get, 2, false) == FAILURE)
4495 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
4498 if (gfc_array_size (get, &get_size) == SUCCESS
4499 && mpz_get_ui (get_size) < kiss_size)
4500 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4501 "too small (%i/%i)",
4502 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4503 where, (int) mpz_get_ui (get_size), kiss_size);
4506 /* RANDOM_SEED may not have more than one non-optional argument. */
4508 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
4515 gfc_check_second_sub (gfc_expr *time)
4517 if (scalar_check (time, 0) == FAILURE)
4520 if (type_check (time, 0, BT_REAL) == FAILURE)
4523 if (kind_value_check(time, 0, 4) == FAILURE)
4530 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
4531 count, count_rate, and count_max are all optional arguments */
4534 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
4535 gfc_expr *count_max)
4539 if (scalar_check (count, 0) == FAILURE)
4542 if (type_check (count, 0, BT_INTEGER) == FAILURE)
4545 if (variable_check (count, 0, false) == FAILURE)
4549 if (count_rate != NULL)
4551 if (scalar_check (count_rate, 1) == FAILURE)
4554 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
4557 if (variable_check (count_rate, 1, false) == FAILURE)
4561 && same_type_check (count, 0, count_rate, 1) == FAILURE)
4566 if (count_max != NULL)
4568 if (scalar_check (count_max, 2) == FAILURE)
4571 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
4574 if (variable_check (count_max, 2, false) == FAILURE)
4578 && same_type_check (count, 0, count_max, 2) == FAILURE)
4581 if (count_rate != NULL
4582 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
4591 gfc_check_irand (gfc_expr *x)
4596 if (scalar_check (x, 0) == FAILURE)
4599 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4602 if (kind_value_check(x, 0, 4) == FAILURE)
4610 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
4612 if (scalar_check (seconds, 0) == FAILURE)
4614 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
4617 if (int_or_proc_check (handler, 1) == FAILURE)
4619 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4625 if (scalar_check (status, 2) == FAILURE)
4627 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4629 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
4637 gfc_check_rand (gfc_expr *x)
4642 if (scalar_check (x, 0) == FAILURE)
4645 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4648 if (kind_value_check(x, 0, 4) == FAILURE)
4656 gfc_check_srand (gfc_expr *x)
4658 if (scalar_check (x, 0) == FAILURE)
4661 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4664 if (kind_value_check(x, 0, 4) == FAILURE)
4672 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
4674 if (scalar_check (time, 0) == FAILURE)
4676 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4679 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
4681 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
4689 gfc_check_dtime_etime (gfc_expr *x)
4691 if (array_check (x, 0) == FAILURE)
4694 if (rank_check (x, 0, 1) == FAILURE)
4697 if (variable_check (x, 0, false) == FAILURE)
4700 if (type_check (x, 0, BT_REAL) == FAILURE)
4703 if (kind_value_check(x, 0, 4) == FAILURE)
4711 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
4713 if (array_check (values, 0) == FAILURE)
4716 if (rank_check (values, 0, 1) == FAILURE)
4719 if (variable_check (values, 0, false) == FAILURE)
4722 if (type_check (values, 0, BT_REAL) == FAILURE)
4725 if (kind_value_check(values, 0, 4) == FAILURE)
4728 if (scalar_check (time, 1) == FAILURE)
4731 if (type_check (time, 1, BT_REAL) == FAILURE)
4734 if (kind_value_check(time, 1, 4) == FAILURE)
4742 gfc_check_fdate_sub (gfc_expr *date)
4744 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4746 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4754 gfc_check_gerror (gfc_expr *msg)
4756 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4758 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4766 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4768 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4770 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4776 if (scalar_check (status, 1) == FAILURE)
4779 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4787 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4789 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4792 if (pos->ts.kind > gfc_default_integer_kind)
4794 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4795 "not wider than the default kind (%d)",
4796 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4797 &pos->where, gfc_default_integer_kind);
4801 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4803 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4811 gfc_check_getlog (gfc_expr *msg)
4813 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4815 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4823 gfc_check_exit (gfc_expr *status)
4828 if (type_check (status, 0, BT_INTEGER) == FAILURE)
4831 if (scalar_check (status, 0) == FAILURE)
4839 gfc_check_flush (gfc_expr *unit)
4844 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4847 if (scalar_check (unit, 0) == FAILURE)
4855 gfc_check_free (gfc_expr *i)
4857 if (type_check (i, 0, BT_INTEGER) == FAILURE)
4860 if (scalar_check (i, 0) == FAILURE)
4868 gfc_check_hostnm (gfc_expr *name)
4870 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4872 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4880 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4882 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4884 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4890 if (scalar_check (status, 1) == FAILURE)
4893 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4901 gfc_check_itime_idate (gfc_expr *values)
4903 if (array_check (values, 0) == FAILURE)
4906 if (rank_check (values, 0, 1) == FAILURE)
4909 if (variable_check (values, 0, false) == FAILURE)
4912 if (type_check (values, 0, BT_INTEGER) == FAILURE)
4915 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4923 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4925 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4928 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4931 if (scalar_check (time, 0) == FAILURE)
4934 if (array_check (values, 1) == FAILURE)
4937 if (rank_check (values, 1, 1) == FAILURE)
4940 if (variable_check (values, 1, false) == FAILURE)
4943 if (type_check (values, 1, BT_INTEGER) == FAILURE)
4946 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4954 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4956 if (scalar_check (unit, 0) == FAILURE)
4959 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4962 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4964 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4972 gfc_check_isatty (gfc_expr *unit)
4977 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4980 if (scalar_check (unit, 0) == FAILURE)
4988 gfc_check_isnan (gfc_expr *x)
4990 if (type_check (x, 0, BT_REAL) == FAILURE)
4998 gfc_check_perror (gfc_expr *string)
5000 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
5002 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
5010 gfc_check_umask (gfc_expr *mask)
5012 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5015 if (scalar_check (mask, 0) == FAILURE)
5023 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
5025 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5028 if (scalar_check (mask, 0) == FAILURE)
5034 if (scalar_check (old, 1) == FAILURE)
5037 if (type_check (old, 1, BT_INTEGER) == FAILURE)
5045 gfc_check_unlink (gfc_expr *name)
5047 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5049 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5057 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
5059 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5061 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5067 if (scalar_check (status, 1) == FAILURE)
5070 if (type_check (status, 1, BT_INTEGER) == FAILURE)
5078 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
5080 if (scalar_check (number, 0) == FAILURE)
5082 if (type_check (number, 0, BT_INTEGER) == FAILURE)
5085 if (int_or_proc_check (handler, 1) == FAILURE)
5087 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5095 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
5097 if (scalar_check (number, 0) == FAILURE)
5099 if (type_check (number, 0, BT_INTEGER) == FAILURE)
5102 if (int_or_proc_check (handler, 1) == FAILURE)
5104 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5110 if (type_check (status, 2, BT_INTEGER) == FAILURE)
5112 if (scalar_check (status, 2) == FAILURE)
5120 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
5122 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
5124 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
5127 if (scalar_check (status, 1) == FAILURE)
5130 if (type_check (status, 1, BT_INTEGER) == FAILURE)
5133 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
5140 /* This is used for the GNU intrinsics AND, OR and XOR. */
5142 gfc_check_and (gfc_expr *i, gfc_expr *j)
5144 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
5146 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5147 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
5148 gfc_current_intrinsic, &i->where);
5152 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
5154 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5155 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
5156 gfc_current_intrinsic, &j->where);
5160 if (i->ts.type != j->ts.type)
5162 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5163 "have the same type", gfc_current_intrinsic_arg[0]->name,
5164 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5169 if (scalar_check (i, 0) == FAILURE)
5172 if (scalar_check (j, 1) == FAILURE)
5180 gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
5185 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
5188 if (scalar_check (kind, 1) == FAILURE)
5191 if (kind->expr_type != EXPR_CONSTANT)
5193 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5194 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,