2013-07-27 Janus Weil <janus@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / check.c
blob758639e27afaeba36c0e1d5f0c28ec912ed666fb
1 /* Check functions
2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
28 #include "config.h"
29 #include "system.h"
30 #include "coretypes.h"
31 #include "flags.h"
32 #include "gfortran.h"
33 #include "intrinsic.h"
34 #include "constructor.h"
35 #include "target-memory.h"
38 /* Make sure an expression is a scalar. */
40 static bool
41 scalar_check (gfc_expr *e, int n)
43 if (e->rank == 0)
44 return true;
46 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
47 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
48 &e->where);
50 return false;
54 /* Check the type of an expression. */
56 static bool
57 type_check (gfc_expr *e, int n, bt type)
59 if (e->ts.type == type)
60 return true;
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));
66 return false;
70 /* Check that the expression is a numeric type. */
72 static bool
73 numeric_check (gfc_expr *e, int n)
75 if (gfc_numeric_ts (&e->ts))
76 return true;
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_FUNCTION)
81 && e->symtree->n.sym->ts.type == BT_UNKNOWN
82 && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
83 && gfc_numeric_ts (&e->symtree->n.sym->ts))
85 e->ts = e->symtree->n.sym->ts;
86 return true;
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,
91 &e->where);
93 return false;
97 /* Check that an expression is integer or real. */
99 static bool
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);
107 return false;
110 return true;
114 /* Check that an expression is real or complex. */
116 static bool
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);
124 return false;
127 return true;
131 /* Check that an expression is INTEGER or PROCEDURE. */
133 static bool
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);
141 return false;
144 return true;
148 /* Check that the expression is an optional constant integer
149 and that it specifies a valid kind for that type. */
151 static bool
152 kind_check (gfc_expr *k, int n, bt type)
154 int kind;
156 if (k == NULL)
157 return true;
159 if (!type_check (k, n, BT_INTEGER))
160 return false;
162 if (!scalar_check (k, n))
163 return false;
165 if (!gfc_check_init_expr (k))
167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
168 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
169 &k->where);
170 return false;
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),
177 &k->where);
178 return false;
181 return true;
185 /* Make sure the expression is a double precision real. */
187 static bool
188 double_check (gfc_expr *d, int n)
190 if (!type_check (d, n, BT_REAL))
191 return false;
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);
198 return false;
201 return true;
205 static bool
206 coarray_check (gfc_expr *e, int n)
208 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
209 && CLASS_DATA (e)->attr.codimension
210 && CLASS_DATA (e)->as->corank)
212 gfc_add_class_array_ref (e);
213 return true;
216 if (!gfc_is_coarray (e))
218 gfc_error ("Expected coarray variable as '%s' argument to the %s "
219 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
220 gfc_current_intrinsic, &e->where);
221 return false;
224 return true;
228 /* Make sure the expression is a logical array. */
230 static bool
231 logical_array_check (gfc_expr *array, int n)
233 if (array->ts.type != BT_LOGICAL || array->rank == 0)
235 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
236 "array", gfc_current_intrinsic_arg[n]->name,
237 gfc_current_intrinsic, &array->where);
238 return false;
241 return true;
245 /* Make sure an expression is an array. */
247 static bool
248 array_check (gfc_expr *e, int n)
250 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
251 && CLASS_DATA (e)->attr.dimension
252 && CLASS_DATA (e)->as->rank)
254 gfc_add_class_array_ref (e);
255 return true;
258 if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
259 return true;
261 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
262 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
263 &e->where);
265 return false;
269 /* If expr is a constant, then check to ensure that it is greater than
270 of equal to zero. */
272 static bool
273 nonnegative_check (const char *arg, gfc_expr *expr)
275 int i;
277 if (expr->expr_type == EXPR_CONSTANT)
279 gfc_extract_int (expr, &i);
280 if (i < 0)
282 gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
283 return false;
287 return true;
291 /* If expr2 is constant, then check that the value is less than
292 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
294 static bool
295 less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
296 gfc_expr *expr2, bool or_equal)
298 int i2, i3;
300 if (expr2->expr_type == EXPR_CONSTANT)
302 gfc_extract_int (expr2, &i2);
303 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
305 /* For ISHFT[C], check that |shift| <= bit_size(i). */
306 if (arg2 == NULL)
308 if (i2 < 0)
309 i2 = -i2;
311 if (i2 > gfc_integer_kinds[i3].bit_size)
313 gfc_error ("The absolute value of SHIFT at %L must be less "
314 "than or equal to BIT_SIZE('%s')",
315 &expr2->where, arg1);
316 return false;
320 if (or_equal)
322 if (i2 > gfc_integer_kinds[i3].bit_size)
324 gfc_error ("'%s' at %L must be less than "
325 "or equal to BIT_SIZE('%s')",
326 arg2, &expr2->where, arg1);
327 return false;
330 else
332 if (i2 >= gfc_integer_kinds[i3].bit_size)
334 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
335 arg2, &expr2->where, arg1);
336 return false;
341 return true;
345 /* If expr is constant, then check that the value is less than or equal
346 to the bit_size of the kind k. */
348 static bool
349 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
351 int i, val;
353 if (expr->expr_type != EXPR_CONSTANT)
354 return true;
356 i = gfc_validate_kind (BT_INTEGER, k, false);
357 gfc_extract_int (expr, &val);
359 if (val > gfc_integer_kinds[i].bit_size)
361 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
362 "INTEGER(KIND=%d)", arg, &expr->where, k);
363 return false;
366 return true;
370 /* If expr2 and expr3 are constants, then check that the value is less than
371 or equal to bit_size(expr1). */
373 static bool
374 less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
375 gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
377 int i2, i3;
379 if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
381 gfc_extract_int (expr2, &i2);
382 gfc_extract_int (expr3, &i3);
383 i2 += i3;
384 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
385 if (i2 > gfc_integer_kinds[i3].bit_size)
387 gfc_error ("'%s + %s' at %L must be less than or equal "
388 "to BIT_SIZE('%s')",
389 arg2, arg3, &expr2->where, arg1);
390 return false;
394 return true;
397 /* Make sure two expressions have the same type. */
399 static bool
400 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
402 if (gfc_compare_types (&e->ts, &f->ts))
403 return true;
405 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
406 "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
407 gfc_current_intrinsic, &f->where,
408 gfc_current_intrinsic_arg[n]->name);
410 return false;
414 /* Make sure that an expression has a certain (nonzero) rank. */
416 static bool
417 rank_check (gfc_expr *e, int n, int rank)
419 if (e->rank == rank)
420 return true;
422 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
423 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
424 &e->where, rank);
426 return false;
430 /* Make sure a variable expression is not an optional dummy argument. */
432 static bool
433 nonoptional_check (gfc_expr *e, int n)
435 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
437 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
438 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
439 &e->where);
442 /* TODO: Recursive check on nonoptional variables? */
444 return true;
448 /* Check for ALLOCATABLE attribute. */
450 static bool
451 allocatable_check (gfc_expr *e, int n)
453 symbol_attribute attr;
455 attr = gfc_variable_attr (e, NULL);
456 if (!attr.allocatable || attr.associate_var)
458 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
459 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
460 &e->where);
461 return false;
464 return true;
468 /* Check that an expression has a particular kind. */
470 static bool
471 kind_value_check (gfc_expr *e, int n, int k)
473 if (e->ts.kind == k)
474 return true;
476 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
477 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
478 &e->where, k);
480 return false;
484 /* Make sure an expression is a variable. */
486 static bool
487 variable_check (gfc_expr *e, int n, bool allow_proc)
489 if (e->expr_type == EXPR_VARIABLE
490 && e->symtree->n.sym->attr.intent == INTENT_IN
491 && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
492 || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
494 gfc_ref *ref;
495 bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
496 && CLASS_DATA (e->symtree->n.sym)
497 ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
498 : e->symtree->n.sym->attr.pointer;
500 for (ref = e->ref; ref; ref = ref->next)
502 if (pointer && ref->type == REF_COMPONENT)
503 break;
504 if (ref->type == REF_COMPONENT
505 && ((ref->u.c.component->ts.type == BT_CLASS
506 && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
507 || (ref->u.c.component->ts.type != BT_CLASS
508 && ref->u.c.component->attr.pointer)))
509 break;
512 if (!ref)
514 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
515 "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
516 gfc_current_intrinsic, &e->where);
517 return false;
521 if (e->expr_type == EXPR_VARIABLE
522 && e->symtree->n.sym->attr.flavor != FL_PARAMETER
523 && (allow_proc || !e->symtree->n.sym->attr.function))
524 return true;
526 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
527 && e->symtree->n.sym == e->symtree->n.sym->result)
529 gfc_namespace *ns;
530 for (ns = gfc_current_ns; ns; ns = ns->parent)
531 if (ns->proc_name == e->symtree->n.sym)
532 return true;
535 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
536 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
538 return false;
542 /* Check the common DIM parameter for correctness. */
544 static bool
545 dim_check (gfc_expr *dim, int n, bool optional)
547 if (dim == NULL)
548 return true;
550 if (!type_check (dim, n, BT_INTEGER))
551 return false;
553 if (!scalar_check (dim, n))
554 return false;
556 if (!optional && !nonoptional_check (dim, n))
557 return false;
559 return true;
563 /* If a coarray DIM parameter is a constant, make sure that it is greater than
564 zero and less than or equal to the corank of the given array. */
566 static bool
567 dim_corank_check (gfc_expr *dim, gfc_expr *array)
569 int corank;
571 gcc_assert (array->expr_type == EXPR_VARIABLE);
573 if (dim->expr_type != EXPR_CONSTANT)
574 return true;
576 if (array->ts.type == BT_CLASS)
577 return true;
579 corank = gfc_get_corank (array);
581 if (mpz_cmp_ui (dim->value.integer, 1) < 0
582 || mpz_cmp_ui (dim->value.integer, corank) > 0)
584 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
585 "codimension index", gfc_current_intrinsic, &dim->where);
587 return false;
590 return true;
594 /* If a DIM parameter is a constant, make sure that it is greater than
595 zero and less than or equal to the rank of the given array. If
596 allow_assumed is zero then dim must be less than the rank of the array
597 for assumed size arrays. */
599 static bool
600 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
602 gfc_array_ref *ar;
603 int rank;
605 if (dim == NULL)
606 return true;
608 if (dim->expr_type != EXPR_CONSTANT)
609 return true;
611 if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
612 && array->value.function.isym->id == GFC_ISYM_SPREAD)
613 rank = array->rank + 1;
614 else
615 rank = array->rank;
617 /* Assumed-rank array. */
618 if (rank == -1)
619 rank = GFC_MAX_DIMENSIONS;
621 if (array->expr_type == EXPR_VARIABLE)
623 ar = gfc_find_array_ref (array);
624 if (ar->as->type == AS_ASSUMED_SIZE
625 && !allow_assumed
626 && ar->type != AR_ELEMENT
627 && ar->type != AR_SECTION)
628 rank--;
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);
637 return false;
640 return true;
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. */
648 static int
649 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
651 mpz_t a_size, b_size;
652 int ret;
654 gcc_assert (a->rank > ai);
655 gcc_assert (b->rank > bi);
657 ret = 1;
659 if (gfc_array_dimen_size (a, ai, &a_size))
661 if (gfc_array_dimen_size (b, bi, &b_size))
663 if (mpz_cmp (a_size, b_size) != 0)
664 ret = 0;
666 mpz_clear (b_size);
668 mpz_clear (a_size);
670 return ret;
673 /* Calculate the length of a character variable, including substrings.
674 Strip away parentheses if necessary. Return -1 if no length could
675 be determined. */
677 static long
678 gfc_var_strlen (const gfc_expr *a)
680 gfc_ref *ra;
682 while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
683 a = a->value.op.op1;
685 for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
688 if (ra)
690 long start_a, end_a;
692 if (!ra->u.ss.end)
693 return -1;
695 if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
696 && ra->u.ss.end->expr_type == EXPR_CONSTANT)
698 start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
699 : 1;
700 end_a = mpz_get_si (ra->u.ss.end->value.integer);
701 return (end_a < start_a) ? 0 : end_a - start_a + 1;
703 else if (ra->u.ss.start
704 && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
705 return 1;
706 else
707 return -1;
710 if (a->ts.u.cl && a->ts.u.cl->length
711 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
712 return mpz_get_si (a->ts.u.cl->length->value.integer);
713 else if (a->expr_type == EXPR_CONSTANT
714 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
715 return a->value.character.length;
716 else
717 return -1;
721 /* Check whether two character expressions have the same length;
722 returns true if they have or if the length cannot be determined,
723 otherwise return false and raise a gfc_error. */
725 bool
726 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
728 long len_a, len_b;
730 len_a = gfc_var_strlen(a);
731 len_b = gfc_var_strlen(b);
733 if (len_a == -1 || len_b == -1 || len_a == len_b)
734 return true;
735 else
737 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
738 len_a, len_b, name, &a->where);
739 return false;
744 /***** Check functions *****/
746 /* Check subroutine suitable for intrinsics taking a real argument and
747 a kind argument for the result. */
749 static bool
750 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
752 if (!type_check (a, 0, BT_REAL))
753 return false;
754 if (!kind_check (kind, 1, type))
755 return false;
757 return true;
761 /* Check subroutine suitable for ceiling, floor and nint. */
763 bool
764 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
766 return check_a_kind (a, kind, BT_INTEGER);
770 /* Check subroutine suitable for aint, anint. */
772 bool
773 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
775 return check_a_kind (a, kind, BT_REAL);
779 bool
780 gfc_check_abs (gfc_expr *a)
782 if (!numeric_check (a, 0))
783 return false;
785 return true;
789 bool
790 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
792 if (!type_check (a, 0, BT_INTEGER))
793 return false;
794 if (!kind_check (kind, 1, BT_CHARACTER))
795 return false;
797 return true;
801 bool
802 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
804 if (!type_check (name, 0, BT_CHARACTER)
805 || !scalar_check (name, 0))
806 return false;
807 if (!kind_value_check (name, 0, gfc_default_character_kind))
808 return false;
810 if (!type_check (mode, 1, BT_CHARACTER)
811 || !scalar_check (mode, 1))
812 return false;
813 if (!kind_value_check (mode, 1, gfc_default_character_kind))
814 return false;
816 return true;
820 bool
821 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
823 if (!logical_array_check (mask, 0))
824 return false;
826 if (!dim_check (dim, 1, false))
827 return false;
829 if (!dim_rank_check (dim, mask, 0))
830 return false;
832 return true;
836 bool
837 gfc_check_allocated (gfc_expr *array)
839 if (!variable_check (array, 0, false))
840 return false;
841 if (!allocatable_check (array, 0))
842 return false;
844 return true;
848 /* Common check function where the first argument must be real or
849 integer and the second argument must be the same as the first. */
851 bool
852 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
854 if (!int_or_real_check (a, 0))
855 return false;
857 if (a->ts.type != p->ts.type)
859 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
860 "have the same type", gfc_current_intrinsic_arg[0]->name,
861 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
862 &p->where);
863 return false;
866 if (a->ts.kind != p->ts.kind)
868 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
869 &p->where))
870 return false;
873 return true;
877 bool
878 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
880 if (!double_check (x, 0) || !double_check (y, 1))
881 return false;
883 return true;
887 bool
888 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
890 symbol_attribute attr1, attr2;
891 int i;
892 bool t;
893 locus *where;
895 where = &pointer->where;
897 if (pointer->expr_type == EXPR_NULL)
898 goto null_arg;
900 attr1 = gfc_expr_attr (pointer);
902 if (!attr1.pointer && !attr1.proc_pointer)
904 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
905 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
906 &pointer->where);
907 return false;
910 /* F2008, C1242. */
911 if (attr1.pointer && gfc_is_coindexed (pointer))
913 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
914 "coindexed", gfc_current_intrinsic_arg[0]->name,
915 gfc_current_intrinsic, &pointer->where);
916 return false;
919 /* Target argument is optional. */
920 if (target == NULL)
921 return true;
923 where = &target->where;
924 if (target->expr_type == EXPR_NULL)
925 goto null_arg;
927 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
928 attr2 = gfc_expr_attr (target);
929 else
931 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
932 "or target VARIABLE or FUNCTION",
933 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
934 &target->where);
935 return false;
938 if (attr1.pointer && !attr2.pointer && !attr2.target)
940 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
941 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
942 gfc_current_intrinsic, &target->where);
943 return false;
946 /* F2008, C1242. */
947 if (attr1.pointer && gfc_is_coindexed (target))
949 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
950 "coindexed", gfc_current_intrinsic_arg[1]->name,
951 gfc_current_intrinsic, &target->where);
952 return false;
955 t = true;
956 if (!same_type_check (pointer, 0, target, 1))
957 t = false;
958 if (!rank_check (target, 0, pointer->rank))
959 t = false;
960 if (target->rank > 0)
962 for (i = 0; i < target->rank; i++)
963 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
965 gfc_error ("Array section with a vector subscript at %L shall not "
966 "be the target of a pointer",
967 &target->where);
968 t = false;
969 break;
972 return t;
974 null_arg:
976 gfc_error ("NULL pointer at %L is not permitted as actual argument "
977 "of '%s' intrinsic function", where, gfc_current_intrinsic);
978 return false;
983 bool
984 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
986 /* gfc_notify_std would be a waste of time as the return value
987 is seemingly used only for the generic resolution. The error
988 will be: Too many arguments. */
989 if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
990 return false;
992 return gfc_check_atan2 (y, x);
996 bool
997 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
999 if (!type_check (y, 0, BT_REAL))
1000 return false;
1001 if (!same_type_check (y, 0, x, 1))
1002 return false;
1004 return true;
1008 static bool
1009 gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
1011 if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
1012 && !(atom->ts.type == BT_LOGICAL
1013 && atom->ts.kind == gfc_atomic_logical_kind))
1015 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1016 "integer of ATOMIC_INT_KIND or a logical of "
1017 "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
1018 return false;
1021 if (!gfc_expr_attr (atom).codimension)
1023 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1024 "coarray or coindexed", &atom->where, gfc_current_intrinsic);
1025 return false;
1028 if (atom->ts.type != value->ts.type)
1030 gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
1031 "have the same type at %L", gfc_current_intrinsic,
1032 &value->where);
1033 return false;
1036 return true;
1040 bool
1041 gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
1043 if (!scalar_check (atom, 0) || !scalar_check (value, 1))
1044 return false;
1046 if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1048 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1049 "definable", gfc_current_intrinsic, &atom->where);
1050 return false;
1053 return gfc_check_atomic (atom, value);
1057 bool
1058 gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
1060 if (!scalar_check (value, 0) || !scalar_check (atom, 1))
1061 return false;
1063 if (!gfc_check_vardef_context (value, false, false, false, NULL))
1065 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1066 "definable", gfc_current_intrinsic, &value->where);
1067 return false;
1070 return gfc_check_atomic (atom, value);
1074 /* BESJN and BESYN functions. */
1076 bool
1077 gfc_check_besn (gfc_expr *n, gfc_expr *x)
1079 if (!type_check (n, 0, BT_INTEGER))
1080 return false;
1081 if (n->expr_type == EXPR_CONSTANT)
1083 int i;
1084 gfc_extract_int (n, &i);
1085 if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument "
1086 "N at %L", &n->where))
1087 return false;
1090 if (!type_check (x, 1, BT_REAL))
1091 return false;
1093 return true;
1097 /* Transformational version of the Bessel JN and YN functions. */
1099 bool
1100 gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1102 if (!type_check (n1, 0, BT_INTEGER))
1103 return false;
1104 if (!scalar_check (n1, 0))
1105 return false;
1106 if (!nonnegative_check ("N1", n1))
1107 return false;
1109 if (!type_check (n2, 1, BT_INTEGER))
1110 return false;
1111 if (!scalar_check (n2, 1))
1112 return false;
1113 if (!nonnegative_check ("N2", n2))
1114 return false;
1116 if (!type_check (x, 2, BT_REAL))
1117 return false;
1118 if (!scalar_check (x, 2))
1119 return false;
1121 return true;
1125 bool
1126 gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1128 if (!type_check (i, 0, BT_INTEGER))
1129 return false;
1131 if (!type_check (j, 1, BT_INTEGER))
1132 return false;
1134 return true;
1138 bool
1139 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
1141 if (!type_check (i, 0, BT_INTEGER))
1142 return false;
1144 if (!type_check (pos, 1, BT_INTEGER))
1145 return false;
1147 if (!nonnegative_check ("pos", pos))
1148 return false;
1150 if (!less_than_bitsize1 ("i", i, "pos", pos, false))
1151 return false;
1153 return true;
1157 bool
1158 gfc_check_char (gfc_expr *i, gfc_expr *kind)
1160 if (!type_check (i, 0, BT_INTEGER))
1161 return false;
1162 if (!kind_check (kind, 1, BT_CHARACTER))
1163 return false;
1165 return true;
1169 bool
1170 gfc_check_chdir (gfc_expr *dir)
1172 if (!type_check (dir, 0, BT_CHARACTER))
1173 return false;
1174 if (!kind_value_check (dir, 0, gfc_default_character_kind))
1175 return false;
1177 return true;
1181 bool
1182 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
1184 if (!type_check (dir, 0, BT_CHARACTER))
1185 return false;
1186 if (!kind_value_check (dir, 0, gfc_default_character_kind))
1187 return false;
1189 if (status == NULL)
1190 return true;
1192 if (!type_check (status, 1, BT_INTEGER))
1193 return false;
1194 if (!scalar_check (status, 1))
1195 return false;
1197 return true;
1201 bool
1202 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
1204 if (!type_check (name, 0, BT_CHARACTER))
1205 return false;
1206 if (!kind_value_check (name, 0, gfc_default_character_kind))
1207 return false;
1209 if (!type_check (mode, 1, BT_CHARACTER))
1210 return false;
1211 if (!kind_value_check (mode, 1, gfc_default_character_kind))
1212 return false;
1214 return true;
1218 bool
1219 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
1221 if (!type_check (name, 0, BT_CHARACTER))
1222 return false;
1223 if (!kind_value_check (name, 0, gfc_default_character_kind))
1224 return false;
1226 if (!type_check (mode, 1, BT_CHARACTER))
1227 return false;
1228 if (!kind_value_check (mode, 1, gfc_default_character_kind))
1229 return false;
1231 if (status == NULL)
1232 return true;
1234 if (!type_check (status, 2, BT_INTEGER))
1235 return false;
1237 if (!scalar_check (status, 2))
1238 return false;
1240 return true;
1244 bool
1245 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
1247 if (!numeric_check (x, 0))
1248 return false;
1250 if (y != NULL)
1252 if (!numeric_check (y, 1))
1253 return false;
1255 if (x->ts.type == BT_COMPLEX)
1257 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1258 "present if 'x' is COMPLEX",
1259 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1260 &y->where);
1261 return false;
1264 if (y->ts.type == BT_COMPLEX)
1266 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1267 "of either REAL or INTEGER",
1268 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1269 &y->where);
1270 return false;
1275 if (!kind_check (kind, 2, BT_COMPLEX))
1276 return false;
1278 if (!kind && gfc_option.gfc_warn_conversion
1279 && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
1280 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1281 "might loose precision, consider using the KIND argument",
1282 gfc_typename (&x->ts), gfc_default_real_kind, &x->where);
1283 else if (y && !kind && gfc_option.gfc_warn_conversion
1284 && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
1285 gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L "
1286 "might loose precision, consider using the KIND argument",
1287 gfc_typename (&y->ts), gfc_default_real_kind, &y->where);
1289 return true;
1293 bool
1294 gfc_check_complex (gfc_expr *x, gfc_expr *y)
1296 if (!int_or_real_check (x, 0))
1297 return false;
1298 if (!scalar_check (x, 0))
1299 return false;
1301 if (!int_or_real_check (y, 1))
1302 return false;
1303 if (!scalar_check (y, 1))
1304 return false;
1306 return true;
1310 bool
1311 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1313 if (!logical_array_check (mask, 0))
1314 return false;
1315 if (!dim_check (dim, 1, false))
1316 return false;
1317 if (!dim_rank_check (dim, mask, 0))
1318 return false;
1319 if (!kind_check (kind, 2, BT_INTEGER))
1320 return false;
1321 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
1322 "with KIND argument at %L",
1323 gfc_current_intrinsic, &kind->where))
1324 return false;
1326 return true;
1330 bool
1331 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
1333 if (!array_check (array, 0))
1334 return false;
1336 if (!type_check (shift, 1, BT_INTEGER))
1337 return false;
1339 if (!dim_check (dim, 2, true))
1340 return false;
1342 if (!dim_rank_check (dim, array, false))
1343 return false;
1345 if (array->rank == 1 || shift->rank == 0)
1347 if (!scalar_check (shift, 1))
1348 return false;
1350 else if (shift->rank == array->rank - 1)
1352 int d;
1353 if (!dim)
1354 d = 1;
1355 else if (dim->expr_type == EXPR_CONSTANT)
1356 gfc_extract_int (dim, &d);
1357 else
1358 d = -1;
1360 if (d > 0)
1362 int i, j;
1363 for (i = 0, j = 0; i < array->rank; i++)
1364 if (i != d - 1)
1366 if (!identical_dimen_shape (array, i, shift, j))
1368 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1369 "invalid shape in dimension %d (%ld/%ld)",
1370 gfc_current_intrinsic_arg[1]->name,
1371 gfc_current_intrinsic, &shift->where, i + 1,
1372 mpz_get_si (array->shape[i]),
1373 mpz_get_si (shift->shape[j]));
1374 return false;
1377 j += 1;
1381 else
1383 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1384 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1385 gfc_current_intrinsic, &shift->where, array->rank - 1);
1386 return false;
1389 return true;
1393 bool
1394 gfc_check_ctime (gfc_expr *time)
1396 if (!scalar_check (time, 0))
1397 return false;
1399 if (!type_check (time, 0, BT_INTEGER))
1400 return false;
1402 return true;
1406 bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
1408 if (!double_check (y, 0) || !double_check (x, 1))
1409 return false;
1411 return true;
1414 bool
1415 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
1417 if (!numeric_check (x, 0))
1418 return false;
1420 if (y != NULL)
1422 if (!numeric_check (y, 1))
1423 return false;
1425 if (x->ts.type == BT_COMPLEX)
1427 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1428 "present if 'x' is COMPLEX",
1429 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1430 &y->where);
1431 return false;
1434 if (y->ts.type == BT_COMPLEX)
1436 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1437 "of either REAL or INTEGER",
1438 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1439 &y->where);
1440 return false;
1444 return true;
1448 bool
1449 gfc_check_dble (gfc_expr *x)
1451 if (!numeric_check (x, 0))
1452 return false;
1454 return true;
1458 bool
1459 gfc_check_digits (gfc_expr *x)
1461 if (!int_or_real_check (x, 0))
1462 return false;
1464 return true;
1468 bool
1469 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1471 switch (vector_a->ts.type)
1473 case BT_LOGICAL:
1474 if (!type_check (vector_b, 1, BT_LOGICAL))
1475 return false;
1476 break;
1478 case BT_INTEGER:
1479 case BT_REAL:
1480 case BT_COMPLEX:
1481 if (!numeric_check (vector_b, 1))
1482 return false;
1483 break;
1485 default:
1486 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1487 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
1488 gfc_current_intrinsic, &vector_a->where);
1489 return false;
1492 if (!rank_check (vector_a, 0, 1))
1493 return false;
1495 if (!rank_check (vector_b, 1, 1))
1496 return false;
1498 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1500 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1501 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
1502 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
1503 return false;
1506 return true;
1510 bool
1511 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1513 if (!type_check (x, 0, BT_REAL)
1514 || !type_check (y, 1, BT_REAL))
1515 return false;
1517 if (x->ts.kind != gfc_default_real_kind)
1519 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1520 "real", gfc_current_intrinsic_arg[0]->name,
1521 gfc_current_intrinsic, &x->where);
1522 return false;
1525 if (y->ts.kind != gfc_default_real_kind)
1527 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1528 "real", gfc_current_intrinsic_arg[1]->name,
1529 gfc_current_intrinsic, &y->where);
1530 return false;
1533 return true;
1537 bool
1538 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
1540 if (!type_check (i, 0, BT_INTEGER))
1541 return false;
1543 if (!type_check (j, 1, BT_INTEGER))
1544 return false;
1546 if (i->is_boz && j->is_boz)
1548 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1549 "constants", &i->where, &j->where);
1550 return false;
1553 if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1))
1554 return false;
1556 if (!type_check (shift, 2, BT_INTEGER))
1557 return false;
1559 if (!nonnegative_check ("SHIFT", shift))
1560 return false;
1562 if (i->is_boz)
1564 if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true))
1565 return false;
1566 i->ts.kind = j->ts.kind;
1568 else
1570 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
1571 return false;
1572 j->ts.kind = i->ts.kind;
1575 return true;
1579 bool
1580 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1581 gfc_expr *dim)
1583 if (!array_check (array, 0))
1584 return false;
1586 if (!type_check (shift, 1, BT_INTEGER))
1587 return false;
1589 if (!dim_check (dim, 3, true))
1590 return false;
1592 if (!dim_rank_check (dim, array, false))
1593 return false;
1595 if (array->rank == 1 || shift->rank == 0)
1597 if (!scalar_check (shift, 1))
1598 return false;
1600 else if (shift->rank == array->rank - 1)
1602 int d;
1603 if (!dim)
1604 d = 1;
1605 else if (dim->expr_type == EXPR_CONSTANT)
1606 gfc_extract_int (dim, &d);
1607 else
1608 d = -1;
1610 if (d > 0)
1612 int i, j;
1613 for (i = 0, j = 0; i < array->rank; i++)
1614 if (i != d - 1)
1616 if (!identical_dimen_shape (array, i, shift, j))
1618 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1619 "invalid shape in dimension %d (%ld/%ld)",
1620 gfc_current_intrinsic_arg[1]->name,
1621 gfc_current_intrinsic, &shift->where, i + 1,
1622 mpz_get_si (array->shape[i]),
1623 mpz_get_si (shift->shape[j]));
1624 return false;
1627 j += 1;
1631 else
1633 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1634 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1635 gfc_current_intrinsic, &shift->where, array->rank - 1);
1636 return false;
1639 if (boundary != NULL)
1641 if (!same_type_check (array, 0, boundary, 2))
1642 return false;
1644 if (array->rank == 1 || boundary->rank == 0)
1646 if (!scalar_check (boundary, 2))
1647 return false;
1649 else if (boundary->rank == array->rank - 1)
1651 if (!gfc_check_conformance (shift, boundary,
1652 "arguments '%s' and '%s' for "
1653 "intrinsic %s",
1654 gfc_current_intrinsic_arg[1]->name,
1655 gfc_current_intrinsic_arg[2]->name,
1656 gfc_current_intrinsic))
1657 return false;
1659 else
1661 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1662 "rank %d or be a scalar",
1663 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1664 &shift->where, array->rank - 1);
1665 return false;
1669 return true;
1672 bool
1673 gfc_check_float (gfc_expr *a)
1675 if (!type_check (a, 0, BT_INTEGER))
1676 return false;
1678 if ((a->ts.kind != gfc_default_integer_kind)
1679 && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
1680 "kind argument to %s intrinsic at %L",
1681 gfc_current_intrinsic, &a->where))
1682 return false;
1684 return true;
1687 /* A single complex argument. */
1689 bool
1690 gfc_check_fn_c (gfc_expr *a)
1692 if (!type_check (a, 0, BT_COMPLEX))
1693 return false;
1695 return true;
1698 /* A single real argument. */
1700 bool
1701 gfc_check_fn_r (gfc_expr *a)
1703 if (!type_check (a, 0, BT_REAL))
1704 return false;
1706 return true;
1709 /* A single double argument. */
1711 bool
1712 gfc_check_fn_d (gfc_expr *a)
1714 if (!double_check (a, 0))
1715 return false;
1717 return true;
1720 /* A single real or complex argument. */
1722 bool
1723 gfc_check_fn_rc (gfc_expr *a)
1725 if (!real_or_complex_check (a, 0))
1726 return false;
1728 return true;
1732 bool
1733 gfc_check_fn_rc2008 (gfc_expr *a)
1735 if (!real_or_complex_check (a, 0))
1736 return false;
1738 if (a->ts.type == BT_COMPLEX
1739 && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' "
1740 "argument of '%s' intrinsic at %L",
1741 gfc_current_intrinsic_arg[0]->name,
1742 gfc_current_intrinsic, &a->where))
1743 return false;
1745 return true;
1749 bool
1750 gfc_check_fnum (gfc_expr *unit)
1752 if (!type_check (unit, 0, BT_INTEGER))
1753 return false;
1755 if (!scalar_check (unit, 0))
1756 return false;
1758 return true;
1762 bool
1763 gfc_check_huge (gfc_expr *x)
1765 if (!int_or_real_check (x, 0))
1766 return false;
1768 return true;
1772 bool
1773 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1775 if (!type_check (x, 0, BT_REAL))
1776 return false;
1777 if (!same_type_check (x, 0, y, 1))
1778 return false;
1780 return true;
1784 /* Check that the single argument is an integer. */
1786 bool
1787 gfc_check_i (gfc_expr *i)
1789 if (!type_check (i, 0, BT_INTEGER))
1790 return false;
1792 return true;
1796 bool
1797 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1799 if (!type_check (i, 0, BT_INTEGER))
1800 return false;
1802 if (!type_check (j, 1, BT_INTEGER))
1803 return false;
1805 if (i->ts.kind != j->ts.kind)
1807 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
1808 &i->where))
1809 return false;
1812 return true;
1816 bool
1817 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1819 if (!type_check (i, 0, BT_INTEGER))
1820 return false;
1822 if (!type_check (pos, 1, BT_INTEGER))
1823 return false;
1825 if (!type_check (len, 2, BT_INTEGER))
1826 return false;
1828 if (!nonnegative_check ("pos", pos))
1829 return false;
1831 if (!nonnegative_check ("len", len))
1832 return false;
1834 if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len))
1835 return false;
1837 return true;
1841 bool
1842 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1844 int i;
1846 if (!type_check (c, 0, BT_CHARACTER))
1847 return false;
1849 if (!kind_check (kind, 1, BT_INTEGER))
1850 return false;
1852 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
1853 "with KIND argument at %L",
1854 gfc_current_intrinsic, &kind->where))
1855 return false;
1857 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1859 gfc_expr *start;
1860 gfc_expr *end;
1861 gfc_ref *ref;
1863 /* Substring references don't have the charlength set. */
1864 ref = c->ref;
1865 while (ref && ref->type != REF_SUBSTRING)
1866 ref = ref->next;
1868 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1870 if (!ref)
1872 /* Check that the argument is length one. Non-constant lengths
1873 can't be checked here, so assume they are ok. */
1874 if (c->ts.u.cl && c->ts.u.cl->length)
1876 /* If we already have a length for this expression then use it. */
1877 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1878 return true;
1879 i = mpz_get_si (c->ts.u.cl->length->value.integer);
1881 else
1882 return true;
1884 else
1886 start = ref->u.ss.start;
1887 end = ref->u.ss.end;
1889 gcc_assert (start);
1890 if (end == NULL || end->expr_type != EXPR_CONSTANT
1891 || start->expr_type != EXPR_CONSTANT)
1892 return true;
1894 i = mpz_get_si (end->value.integer) + 1
1895 - mpz_get_si (start->value.integer);
1898 else
1899 return true;
1901 if (i != 1)
1903 gfc_error ("Argument of %s at %L must be of length one",
1904 gfc_current_intrinsic, &c->where);
1905 return false;
1908 return true;
1912 bool
1913 gfc_check_idnint (gfc_expr *a)
1915 if (!double_check (a, 0))
1916 return false;
1918 return true;
1922 bool
1923 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1925 if (!type_check (i, 0, BT_INTEGER))
1926 return false;
1928 if (!type_check (j, 1, BT_INTEGER))
1929 return false;
1931 if (i->ts.kind != j->ts.kind)
1933 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
1934 &i->where))
1935 return false;
1938 return true;
1942 bool
1943 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1944 gfc_expr *kind)
1946 if (!type_check (string, 0, BT_CHARACTER)
1947 || !type_check (substring, 1, BT_CHARACTER))
1948 return false;
1950 if (back != NULL && !type_check (back, 2, BT_LOGICAL))
1951 return false;
1953 if (!kind_check (kind, 3, BT_INTEGER))
1954 return false;
1955 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
1956 "with KIND argument at %L",
1957 gfc_current_intrinsic, &kind->where))
1958 return false;
1960 if (string->ts.kind != substring->ts.kind)
1962 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1963 "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
1964 gfc_current_intrinsic, &substring->where,
1965 gfc_current_intrinsic_arg[0]->name);
1966 return false;
1969 return true;
1973 bool
1974 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1976 if (!numeric_check (x, 0))
1977 return false;
1979 if (!kind_check (kind, 1, BT_INTEGER))
1980 return false;
1982 return true;
1986 bool
1987 gfc_check_intconv (gfc_expr *x)
1989 if (!numeric_check (x, 0))
1990 return false;
1992 return true;
1996 bool
1997 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1999 if (!type_check (i, 0, BT_INTEGER))
2000 return false;
2002 if (!type_check (j, 1, BT_INTEGER))
2003 return false;
2005 if (i->ts.kind != j->ts.kind)
2007 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
2008 &i->where))
2009 return false;
2012 return true;
2016 bool
2017 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
2019 if (!type_check (i, 0, BT_INTEGER)
2020 || !type_check (shift, 1, BT_INTEGER))
2021 return false;
2023 if (!less_than_bitsize1 ("I", i, NULL, shift, true))
2024 return false;
2026 return true;
2030 bool
2031 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
2033 if (!type_check (i, 0, BT_INTEGER)
2034 || !type_check (shift, 1, BT_INTEGER))
2035 return false;
2037 if (size != NULL)
2039 int i2, i3;
2041 if (!type_check (size, 2, BT_INTEGER))
2042 return false;
2044 if (!less_than_bitsize1 ("I", i, "SIZE", size, true))
2045 return false;
2047 if (size->expr_type == EXPR_CONSTANT)
2049 gfc_extract_int (size, &i3);
2050 if (i3 <= 0)
2052 gfc_error ("SIZE at %L must be positive", &size->where);
2053 return false;
2056 if (shift->expr_type == EXPR_CONSTANT)
2058 gfc_extract_int (shift, &i2);
2059 if (i2 < 0)
2060 i2 = -i2;
2062 if (i2 > i3)
2064 gfc_error ("The absolute value of SHIFT at %L must be less "
2065 "than or equal to SIZE at %L", &shift->where,
2066 &size->where);
2067 return false;
2072 else if (!less_than_bitsize1 ("I", i, NULL, shift, true))
2073 return false;
2075 return true;
2079 bool
2080 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
2082 if (!type_check (pid, 0, BT_INTEGER))
2083 return false;
2085 if (!type_check (sig, 1, BT_INTEGER))
2086 return false;
2088 return true;
2092 bool
2093 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
2095 if (!type_check (pid, 0, BT_INTEGER))
2096 return false;
2098 if (!scalar_check (pid, 0))
2099 return false;
2101 if (!type_check (sig, 1, BT_INTEGER))
2102 return false;
2104 if (!scalar_check (sig, 1))
2105 return false;
2107 if (status == NULL)
2108 return true;
2110 if (!type_check (status, 2, BT_INTEGER))
2111 return false;
2113 if (!scalar_check (status, 2))
2114 return false;
2116 return true;
2120 bool
2121 gfc_check_kind (gfc_expr *x)
2123 if (x->ts.type == BT_DERIVED)
2125 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2126 "non-derived type", gfc_current_intrinsic_arg[0]->name,
2127 gfc_current_intrinsic, &x->where);
2128 return false;
2131 return true;
2135 bool
2136 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2138 if (!array_check (array, 0))
2139 return false;
2141 if (!dim_check (dim, 1, false))
2142 return false;
2144 if (!dim_rank_check (dim, array, 1))
2145 return false;
2147 if (!kind_check (kind, 2, BT_INTEGER))
2148 return false;
2149 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
2150 "with KIND argument at %L",
2151 gfc_current_intrinsic, &kind->where))
2152 return false;
2154 return true;
2158 bool
2159 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
2161 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2163 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2164 return false;
2167 if (!coarray_check (coarray, 0))
2168 return false;
2170 if (dim != NULL)
2172 if (!dim_check (dim, 1, false))
2173 return false;
2175 if (!dim_corank_check (dim, coarray))
2176 return false;
2179 if (!kind_check (kind, 2, BT_INTEGER))
2180 return false;
2182 return true;
2186 bool
2187 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
2189 if (!type_check (s, 0, BT_CHARACTER))
2190 return false;
2192 if (!kind_check (kind, 1, BT_INTEGER))
2193 return false;
2194 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
2195 "with KIND argument at %L",
2196 gfc_current_intrinsic, &kind->where))
2197 return false;
2199 return true;
2203 bool
2204 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
2206 if (!type_check (a, 0, BT_CHARACTER))
2207 return false;
2208 if (!kind_value_check (a, 0, gfc_default_character_kind))
2209 return false;
2211 if (!type_check (b, 1, BT_CHARACTER))
2212 return false;
2213 if (!kind_value_check (b, 1, gfc_default_character_kind))
2214 return false;
2216 return true;
2220 bool
2221 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
2223 if (!type_check (path1, 0, BT_CHARACTER))
2224 return false;
2225 if (!kind_value_check (path1, 0, gfc_default_character_kind))
2226 return false;
2228 if (!type_check (path2, 1, BT_CHARACTER))
2229 return false;
2230 if (!kind_value_check (path2, 1, gfc_default_character_kind))
2231 return false;
2233 return true;
2237 bool
2238 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2240 if (!type_check (path1, 0, BT_CHARACTER))
2241 return false;
2242 if (!kind_value_check (path1, 0, gfc_default_character_kind))
2243 return false;
2245 if (!type_check (path2, 1, BT_CHARACTER))
2246 return false;
2247 if (!kind_value_check (path2, 0, gfc_default_character_kind))
2248 return false;
2250 if (status == NULL)
2251 return true;
2253 if (!type_check (status, 2, BT_INTEGER))
2254 return false;
2256 if (!scalar_check (status, 2))
2257 return false;
2259 return true;
2263 bool
2264 gfc_check_loc (gfc_expr *expr)
2266 return variable_check (expr, 0, true);
2270 bool
2271 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
2273 if (!type_check (path1, 0, BT_CHARACTER))
2274 return false;
2275 if (!kind_value_check (path1, 0, gfc_default_character_kind))
2276 return false;
2278 if (!type_check (path2, 1, BT_CHARACTER))
2279 return false;
2280 if (!kind_value_check (path2, 1, gfc_default_character_kind))
2281 return false;
2283 return true;
2287 bool
2288 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2290 if (!type_check (path1, 0, BT_CHARACTER))
2291 return false;
2292 if (!kind_value_check (path1, 0, gfc_default_character_kind))
2293 return false;
2295 if (!type_check (path2, 1, BT_CHARACTER))
2296 return false;
2297 if (!kind_value_check (path2, 1, gfc_default_character_kind))
2298 return false;
2300 if (status == NULL)
2301 return true;
2303 if (!type_check (status, 2, BT_INTEGER))
2304 return false;
2306 if (!scalar_check (status, 2))
2307 return false;
2309 return true;
2313 bool
2314 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
2316 if (!type_check (a, 0, BT_LOGICAL))
2317 return false;
2318 if (!kind_check (kind, 1, BT_LOGICAL))
2319 return false;
2321 return true;
2325 /* Min/max family. */
2327 static bool
2328 min_max_args (gfc_actual_arglist *args)
2330 gfc_actual_arglist *arg;
2331 int i, j, nargs, *nlabels, nlabelless;
2332 bool a1 = false, a2 = false;
2334 if (args == NULL || args->next == NULL)
2336 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2337 gfc_current_intrinsic, gfc_current_intrinsic_where);
2338 return false;
2341 if (!args->name)
2342 a1 = true;
2344 if (!args->next->name)
2345 a2 = true;
2347 nargs = 0;
2348 for (arg = args; arg; arg = arg->next)
2349 if (arg->name)
2350 nargs++;
2352 if (nargs == 0)
2353 return true;
2355 /* Note: Having a keywordless argument after an "arg=" is checked before. */
2356 nlabelless = 0;
2357 nlabels = XALLOCAVEC (int, nargs);
2358 for (arg = args, i = 0; arg; arg = arg->next, i++)
2359 if (arg->name)
2361 int n;
2362 char *endp;
2364 if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
2365 goto unknown;
2366 n = strtol (&arg->name[1], &endp, 10);
2367 if (endp[0] != '\0')
2368 goto unknown;
2369 if (n <= 0)
2370 goto unknown;
2371 if (n <= nlabelless)
2372 goto duplicate;
2373 nlabels[i] = n;
2374 if (n == 1)
2375 a1 = true;
2376 if (n == 2)
2377 a2 = true;
2379 else
2380 nlabelless++;
2382 if (!a1 || !a2)
2384 gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
2385 !a1 ? "a1" : "a2", gfc_current_intrinsic,
2386 gfc_current_intrinsic_where);
2387 return false;
2390 /* Check for duplicates. */
2391 for (i = 0; i < nargs; i++)
2392 for (j = i + 1; j < nargs; j++)
2393 if (nlabels[i] == nlabels[j])
2394 goto duplicate;
2396 return true;
2398 duplicate:
2399 gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg->name,
2400 &arg->expr->where, gfc_current_intrinsic);
2401 return false;
2403 unknown:
2404 gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg->name,
2405 &arg->expr->where, gfc_current_intrinsic);
2406 return false;
2410 static bool
2411 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
2413 gfc_actual_arglist *arg, *tmp;
2414 gfc_expr *x;
2415 int m, n;
2417 if (!min_max_args (arglist))
2418 return false;
2420 for (arg = arglist, n=1; arg; arg = arg->next, n++)
2422 x = arg->expr;
2423 if (x->ts.type != type || x->ts.kind != kind)
2425 if (x->ts.type == type)
2427 if (!gfc_notify_std (GFC_STD_GNU, "Different type "
2428 "kinds at %L", &x->where))
2429 return false;
2431 else
2433 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2434 "%s(%d)", n, gfc_current_intrinsic, &x->where,
2435 gfc_basic_typename (type), kind);
2436 return false;
2440 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
2441 if (!gfc_check_conformance (tmp->expr, x,
2442 "arguments 'a%d' and 'a%d' for "
2443 "intrinsic '%s'", m, n,
2444 gfc_current_intrinsic))
2445 return false;
2448 return true;
2452 bool
2453 gfc_check_min_max (gfc_actual_arglist *arg)
2455 gfc_expr *x;
2457 if (!min_max_args (arg))
2458 return false;
2460 x = arg->expr;
2462 if (x->ts.type == BT_CHARACTER)
2464 if (!gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
2465 "with CHARACTER argument at %L",
2466 gfc_current_intrinsic, &x->where))
2467 return false;
2469 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
2471 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2472 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
2473 return false;
2476 return check_rest (x->ts.type, x->ts.kind, arg);
2480 bool
2481 gfc_check_min_max_integer (gfc_actual_arglist *arg)
2483 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
2487 bool
2488 gfc_check_min_max_real (gfc_actual_arglist *arg)
2490 return check_rest (BT_REAL, gfc_default_real_kind, arg);
2494 bool
2495 gfc_check_min_max_double (gfc_actual_arglist *arg)
2497 return check_rest (BT_REAL, gfc_default_double_kind, arg);
2501 /* End of min/max family. */
2503 bool
2504 gfc_check_malloc (gfc_expr *size)
2506 if (!type_check (size, 0, BT_INTEGER))
2507 return false;
2509 if (!scalar_check (size, 0))
2510 return false;
2512 return true;
2516 bool
2517 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
2519 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
2521 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2522 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2523 gfc_current_intrinsic, &matrix_a->where);
2524 return false;
2527 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2529 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2530 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
2531 gfc_current_intrinsic, &matrix_b->where);
2532 return false;
2535 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2536 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2538 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2539 gfc_current_intrinsic, &matrix_a->where,
2540 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2541 return false;
2544 switch (matrix_a->rank)
2546 case 1:
2547 if (!rank_check (matrix_b, 1, 2))
2548 return false;
2549 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2550 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2552 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2553 "and '%s' at %L for intrinsic matmul",
2554 gfc_current_intrinsic_arg[0]->name,
2555 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2556 return false;
2558 break;
2560 case 2:
2561 if (matrix_b->rank != 2)
2563 if (!rank_check (matrix_b, 1, 1))
2564 return false;
2566 /* matrix_b has rank 1 or 2 here. Common check for the cases
2567 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2568 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2569 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2571 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2572 "dimension 1 for argument '%s' at %L for intrinsic "
2573 "matmul", gfc_current_intrinsic_arg[0]->name,
2574 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2575 return false;
2577 break;
2579 default:
2580 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2581 "1 or 2", gfc_current_intrinsic_arg[0]->name,
2582 gfc_current_intrinsic, &matrix_a->where);
2583 return false;
2586 return true;
2590 /* Whoever came up with this interface was probably on something.
2591 The possibilities for the occupation of the second and third
2592 parameters are:
2594 Arg #2 Arg #3
2595 NULL NULL
2596 DIM NULL
2597 MASK NULL
2598 NULL MASK minloc(array, mask=m)
2599 DIM MASK
2601 I.e. in the case of minloc(array,mask), mask will be in the second
2602 position of the argument list and we'll have to fix that up. */
2604 bool
2605 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2607 gfc_expr *a, *m, *d;
2609 a = ap->expr;
2610 if (!int_or_real_check (a, 0) || !array_check (a, 0))
2611 return false;
2613 d = ap->next->expr;
2614 m = ap->next->next->expr;
2616 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2617 && ap->next->name == NULL)
2619 m = d;
2620 d = NULL;
2621 ap->next->expr = NULL;
2622 ap->next->next->expr = m;
2625 if (!dim_check (d, 1, false))
2626 return false;
2628 if (!dim_rank_check (d, a, 0))
2629 return false;
2631 if (m != NULL && !type_check (m, 2, BT_LOGICAL))
2632 return false;
2634 if (m != NULL
2635 && !gfc_check_conformance (a, m,
2636 "arguments '%s' and '%s' for intrinsic %s",
2637 gfc_current_intrinsic_arg[0]->name,
2638 gfc_current_intrinsic_arg[2]->name,
2639 gfc_current_intrinsic))
2640 return false;
2642 return true;
2646 /* Similar to minloc/maxloc, the argument list might need to be
2647 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2648 difference is that MINLOC/MAXLOC take an additional KIND argument.
2649 The possibilities are:
2651 Arg #2 Arg #3
2652 NULL NULL
2653 DIM NULL
2654 MASK NULL
2655 NULL MASK minval(array, mask=m)
2656 DIM MASK
2658 I.e. in the case of minval(array,mask), mask will be in the second
2659 position of the argument list and we'll have to fix that up. */
2661 static bool
2662 check_reduction (gfc_actual_arglist *ap)
2664 gfc_expr *a, *m, *d;
2666 a = ap->expr;
2667 d = ap->next->expr;
2668 m = ap->next->next->expr;
2670 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2671 && ap->next->name == NULL)
2673 m = d;
2674 d = NULL;
2675 ap->next->expr = NULL;
2676 ap->next->next->expr = m;
2679 if (!dim_check (d, 1, false))
2680 return false;
2682 if (!dim_rank_check (d, a, 0))
2683 return false;
2685 if (m != NULL && !type_check (m, 2, BT_LOGICAL))
2686 return false;
2688 if (m != NULL
2689 && !gfc_check_conformance (a, m,
2690 "arguments '%s' and '%s' for intrinsic %s",
2691 gfc_current_intrinsic_arg[0]->name,
2692 gfc_current_intrinsic_arg[2]->name,
2693 gfc_current_intrinsic))
2694 return false;
2696 return true;
2700 bool
2701 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2703 if (!int_or_real_check (ap->expr, 0)
2704 || !array_check (ap->expr, 0))
2705 return false;
2707 return check_reduction (ap);
2711 bool
2712 gfc_check_product_sum (gfc_actual_arglist *ap)
2714 if (!numeric_check (ap->expr, 0)
2715 || !array_check (ap->expr, 0))
2716 return false;
2718 return check_reduction (ap);
2722 /* For IANY, IALL and IPARITY. */
2724 bool
2725 gfc_check_mask (gfc_expr *i, gfc_expr *kind)
2727 int k;
2729 if (!type_check (i, 0, BT_INTEGER))
2730 return false;
2732 if (!nonnegative_check ("I", i))
2733 return false;
2735 if (!kind_check (kind, 1, BT_INTEGER))
2736 return false;
2738 if (kind)
2739 gfc_extract_int (kind, &k);
2740 else
2741 k = gfc_default_integer_kind;
2743 if (!less_than_bitsizekind ("I", i, k))
2744 return false;
2746 return true;
2750 bool
2751 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
2753 if (ap->expr->ts.type != BT_INTEGER)
2755 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2756 gfc_current_intrinsic_arg[0]->name,
2757 gfc_current_intrinsic, &ap->expr->where);
2758 return false;
2761 if (!array_check (ap->expr, 0))
2762 return false;
2764 return check_reduction (ap);
2768 bool
2769 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2771 if (!same_type_check (tsource, 0, fsource, 1))
2772 return false;
2774 if (!type_check (mask, 2, BT_LOGICAL))
2775 return false;
2777 if (tsource->ts.type == BT_CHARACTER)
2778 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2780 return true;
2784 bool
2785 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
2787 if (!type_check (i, 0, BT_INTEGER))
2788 return false;
2790 if (!type_check (j, 1, BT_INTEGER))
2791 return false;
2793 if (!type_check (mask, 2, BT_INTEGER))
2794 return false;
2796 if (!same_type_check (i, 0, j, 1))
2797 return false;
2799 if (!same_type_check (i, 0, mask, 2))
2800 return false;
2802 return true;
2806 bool
2807 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2809 if (!variable_check (from, 0, false))
2810 return false;
2811 if (!allocatable_check (from, 0))
2812 return false;
2813 if (gfc_is_coindexed (from))
2815 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
2816 "coindexed", &from->where);
2817 return false;
2820 if (!variable_check (to, 1, false))
2821 return false;
2822 if (!allocatable_check (to, 1))
2823 return false;
2824 if (gfc_is_coindexed (to))
2826 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
2827 "coindexed", &to->where);
2828 return false;
2831 if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
2833 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2834 "polymorphic if FROM is polymorphic",
2835 &to->where);
2836 return false;
2839 if (!same_type_check (to, 1, from, 0))
2840 return false;
2842 if (to->rank != from->rank)
2844 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2845 "must have the same rank %d/%d", &to->where, from->rank,
2846 to->rank);
2847 return false;
2850 /* IR F08/0040; cf. 12-006A. */
2851 if (gfc_get_corank (to) != gfc_get_corank (from))
2853 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2854 "must have the same corank %d/%d", &to->where,
2855 gfc_get_corank (from), gfc_get_corank (to));
2856 return false;
2859 /* CLASS arguments: Make sure the vtab of from is present. */
2860 if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
2862 if (from->ts.type == BT_CLASS || from->ts.type == BT_DERIVED)
2863 gfc_find_derived_vtab (from->ts.u.derived);
2864 else
2865 gfc_find_intrinsic_vtab (&from->ts);
2868 return true;
2872 bool
2873 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2875 if (!type_check (x, 0, BT_REAL))
2876 return false;
2878 if (!type_check (s, 1, BT_REAL))
2879 return false;
2881 if (s->expr_type == EXPR_CONSTANT)
2883 if (mpfr_sgn (s->value.real) == 0)
2885 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2886 &s->where);
2887 return false;
2891 return true;
2895 bool
2896 gfc_check_new_line (gfc_expr *a)
2898 if (!type_check (a, 0, BT_CHARACTER))
2899 return false;
2901 return true;
2905 bool
2906 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
2908 if (!type_check (array, 0, BT_REAL))
2909 return false;
2911 if (!array_check (array, 0))
2912 return false;
2914 if (!dim_rank_check (dim, array, false))
2915 return false;
2917 return true;
2920 bool
2921 gfc_check_null (gfc_expr *mold)
2923 symbol_attribute attr;
2925 if (mold == NULL)
2926 return true;
2928 if (!variable_check (mold, 0, true))
2929 return false;
2931 attr = gfc_variable_attr (mold, NULL);
2933 if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
2935 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2936 "ALLOCATABLE or procedure pointer",
2937 gfc_current_intrinsic_arg[0]->name,
2938 gfc_current_intrinsic, &mold->where);
2939 return false;
2942 if (attr.allocatable
2943 && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
2944 "allocatable MOLD at %L", &mold->where))
2945 return false;
2947 /* F2008, C1242. */
2948 if (gfc_is_coindexed (mold))
2950 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2951 "coindexed", gfc_current_intrinsic_arg[0]->name,
2952 gfc_current_intrinsic, &mold->where);
2953 return false;
2956 return true;
2960 bool
2961 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2963 if (!array_check (array, 0))
2964 return false;
2966 if (!type_check (mask, 1, BT_LOGICAL))
2967 return false;
2969 if (!gfc_check_conformance (array, mask,
2970 "arguments '%s' and '%s' for intrinsic '%s'",
2971 gfc_current_intrinsic_arg[0]->name,
2972 gfc_current_intrinsic_arg[1]->name,
2973 gfc_current_intrinsic))
2974 return false;
2976 if (vector != NULL)
2978 mpz_t array_size, vector_size;
2979 bool have_array_size, have_vector_size;
2981 if (!same_type_check (array, 0, vector, 2))
2982 return false;
2984 if (!rank_check (vector, 2, 1))
2985 return false;
2987 /* VECTOR requires at least as many elements as MASK
2988 has .TRUE. values. */
2989 have_array_size = gfc_array_size(array, &array_size);
2990 have_vector_size = gfc_array_size(vector, &vector_size);
2992 if (have_vector_size
2993 && (mask->expr_type == EXPR_ARRAY
2994 || (mask->expr_type == EXPR_CONSTANT
2995 && have_array_size)))
2997 int mask_true_values = 0;
2999 if (mask->expr_type == EXPR_ARRAY)
3001 gfc_constructor *mask_ctor;
3002 mask_ctor = gfc_constructor_first (mask->value.constructor);
3003 while (mask_ctor)
3005 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
3007 mask_true_values = 0;
3008 break;
3011 if (mask_ctor->expr->value.logical)
3012 mask_true_values++;
3014 mask_ctor = gfc_constructor_next (mask_ctor);
3017 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
3018 mask_true_values = mpz_get_si (array_size);
3020 if (mpz_get_si (vector_size) < mask_true_values)
3022 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3023 "provide at least as many elements as there "
3024 "are .TRUE. values in '%s' (%ld/%d)",
3025 gfc_current_intrinsic_arg[2]->name,
3026 gfc_current_intrinsic, &vector->where,
3027 gfc_current_intrinsic_arg[1]->name,
3028 mpz_get_si (vector_size), mask_true_values);
3029 return false;
3033 if (have_array_size)
3034 mpz_clear (array_size);
3035 if (have_vector_size)
3036 mpz_clear (vector_size);
3039 return true;
3043 bool
3044 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
3046 if (!type_check (mask, 0, BT_LOGICAL))
3047 return false;
3049 if (!array_check (mask, 0))
3050 return false;
3052 if (!dim_rank_check (dim, mask, false))
3053 return false;
3055 return true;
3059 bool
3060 gfc_check_precision (gfc_expr *x)
3062 if (!real_or_complex_check (x, 0))
3063 return false;
3065 return true;
3069 bool
3070 gfc_check_present (gfc_expr *a)
3072 gfc_symbol *sym;
3074 if (!variable_check (a, 0, true))
3075 return false;
3077 sym = a->symtree->n.sym;
3078 if (!sym->attr.dummy)
3080 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3081 "dummy variable", gfc_current_intrinsic_arg[0]->name,
3082 gfc_current_intrinsic, &a->where);
3083 return false;
3086 if (!sym->attr.optional)
3088 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3089 "an OPTIONAL dummy variable",
3090 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3091 &a->where);
3092 return false;
3095 /* 13.14.82 PRESENT(A)
3096 ......
3097 Argument. A shall be the name of an optional dummy argument that is
3098 accessible in the subprogram in which the PRESENT function reference
3099 appears... */
3101 if (a->ref != NULL
3102 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
3103 && (a->ref->u.ar.type == AR_FULL
3104 || (a->ref->u.ar.type == AR_ELEMENT
3105 && a->ref->u.ar.as->rank == 0))))
3107 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3108 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
3109 gfc_current_intrinsic, &a->where, sym->name);
3110 return false;
3113 return true;
3117 bool
3118 gfc_check_radix (gfc_expr *x)
3120 if (!int_or_real_check (x, 0))
3121 return false;
3123 return true;
3127 bool
3128 gfc_check_range (gfc_expr *x)
3130 if (!numeric_check (x, 0))
3131 return false;
3133 return true;
3137 bool
3138 gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
3140 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3141 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3143 bool is_variable = true;
3145 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3146 if (a->expr_type == EXPR_FUNCTION)
3147 is_variable = a->value.function.esym
3148 ? a->value.function.esym->result->attr.pointer
3149 : a->symtree->n.sym->result->attr.pointer;
3151 if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
3152 || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
3153 || !is_variable)
3155 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3156 "object", &a->where);
3157 return false;
3160 return true;
3164 /* real, float, sngl. */
3165 bool
3166 gfc_check_real (gfc_expr *a, gfc_expr *kind)
3168 if (!numeric_check (a, 0))
3169 return false;
3171 if (!kind_check (kind, 1, BT_REAL))
3172 return false;
3174 return true;
3178 bool
3179 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
3181 if (!type_check (path1, 0, BT_CHARACTER))
3182 return false;
3183 if (!kind_value_check (path1, 0, gfc_default_character_kind))
3184 return false;
3186 if (!type_check (path2, 1, BT_CHARACTER))
3187 return false;
3188 if (!kind_value_check (path2, 1, gfc_default_character_kind))
3189 return false;
3191 return true;
3195 bool
3196 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3198 if (!type_check (path1, 0, BT_CHARACTER))
3199 return false;
3200 if (!kind_value_check (path1, 0, gfc_default_character_kind))
3201 return false;
3203 if (!type_check (path2, 1, BT_CHARACTER))
3204 return false;
3205 if (!kind_value_check (path2, 1, gfc_default_character_kind))
3206 return false;
3208 if (status == NULL)
3209 return true;
3211 if (!type_check (status, 2, BT_INTEGER))
3212 return false;
3214 if (!scalar_check (status, 2))
3215 return false;
3217 return true;
3221 bool
3222 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
3224 if (!type_check (x, 0, BT_CHARACTER))
3225 return false;
3227 if (!scalar_check (x, 0))
3228 return false;
3230 if (!type_check (y, 0, BT_INTEGER))
3231 return false;
3233 if (!scalar_check (y, 1))
3234 return false;
3236 return true;
3240 bool
3241 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
3242 gfc_expr *pad, gfc_expr *order)
3244 mpz_t size;
3245 mpz_t nelems;
3246 int shape_size;
3248 if (!array_check (source, 0))
3249 return false;
3251 if (!rank_check (shape, 1, 1))
3252 return false;
3254 if (!type_check (shape, 1, BT_INTEGER))
3255 return false;
3257 if (!gfc_array_size (shape, &size))
3259 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3260 "array of constant size", &shape->where);
3261 return false;
3264 shape_size = mpz_get_ui (size);
3265 mpz_clear (size);
3267 if (shape_size <= 0)
3269 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3270 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3271 &shape->where);
3272 return false;
3274 else if (shape_size > GFC_MAX_DIMENSIONS)
3276 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3277 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
3278 return false;
3280 else if (shape->expr_type == EXPR_ARRAY)
3282 gfc_expr *e;
3283 int i, extent;
3284 for (i = 0; i < shape_size; ++i)
3286 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
3287 if (e->expr_type != EXPR_CONSTANT)
3288 continue;
3290 gfc_extract_int (e, &extent);
3291 if (extent < 0)
3293 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3294 "negative element (%d)",
3295 gfc_current_intrinsic_arg[1]->name,
3296 gfc_current_intrinsic, &e->where, extent);
3297 return false;
3302 if (pad != NULL)
3304 if (!same_type_check (source, 0, pad, 2))
3305 return false;
3307 if (!array_check (pad, 2))
3308 return false;
3311 if (order != NULL)
3313 if (!array_check (order, 3))
3314 return false;
3316 if (!type_check (order, 3, BT_INTEGER))
3317 return false;
3319 if (order->expr_type == EXPR_ARRAY)
3321 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
3322 gfc_expr *e;
3324 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
3325 perm[i] = 0;
3327 gfc_array_size (order, &size);
3328 order_size = mpz_get_ui (size);
3329 mpz_clear (size);
3331 if (order_size != shape_size)
3333 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3334 "has wrong number of elements (%d/%d)",
3335 gfc_current_intrinsic_arg[3]->name,
3336 gfc_current_intrinsic, &order->where,
3337 order_size, shape_size);
3338 return false;
3341 for (i = 1; i <= order_size; ++i)
3343 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
3344 if (e->expr_type != EXPR_CONSTANT)
3345 continue;
3347 gfc_extract_int (e, &dim);
3349 if (dim < 1 || dim > order_size)
3351 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3352 "has out-of-range dimension (%d)",
3353 gfc_current_intrinsic_arg[3]->name,
3354 gfc_current_intrinsic, &e->where, dim);
3355 return false;
3358 if (perm[dim-1] != 0)
3360 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3361 "invalid permutation of dimensions (dimension "
3362 "'%d' duplicated)",
3363 gfc_current_intrinsic_arg[3]->name,
3364 gfc_current_intrinsic, &e->where, dim);
3365 return false;
3368 perm[dim-1] = 1;
3373 if (pad == NULL && shape->expr_type == EXPR_ARRAY
3374 && gfc_is_constant_expr (shape)
3375 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
3376 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
3378 /* Check the match in size between source and destination. */
3379 if (gfc_array_size (source, &nelems))
3381 gfc_constructor *c;
3382 bool test;
3385 mpz_init_set_ui (size, 1);
3386 for (c = gfc_constructor_first (shape->value.constructor);
3387 c; c = gfc_constructor_next (c))
3388 mpz_mul (size, size, c->expr->value.integer);
3390 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
3391 mpz_clear (nelems);
3392 mpz_clear (size);
3394 if (test)
3396 gfc_error ("Without padding, there are not enough elements "
3397 "in the intrinsic RESHAPE source at %L to match "
3398 "the shape", &source->where);
3399 return false;
3404 return true;
3408 bool
3409 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
3411 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
3413 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3414 "cannot be of type %s",
3415 gfc_current_intrinsic_arg[0]->name,
3416 gfc_current_intrinsic,
3417 &a->where, gfc_typename (&a->ts));
3418 return false;
3421 if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
3423 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3424 "must be of an extensible type",
3425 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3426 &a->where);
3427 return false;
3430 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
3432 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3433 "cannot be of type %s",
3434 gfc_current_intrinsic_arg[0]->name,
3435 gfc_current_intrinsic,
3436 &b->where, gfc_typename (&b->ts));
3437 return false;
3440 if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
3442 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3443 "must be of an extensible type",
3444 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3445 &b->where);
3446 return false;
3449 return true;
3453 bool
3454 gfc_check_scale (gfc_expr *x, gfc_expr *i)
3456 if (!type_check (x, 0, BT_REAL))
3457 return false;
3459 if (!type_check (i, 1, BT_INTEGER))
3460 return false;
3462 return true;
3466 bool
3467 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3469 if (!type_check (x, 0, BT_CHARACTER))
3470 return false;
3472 if (!type_check (y, 1, BT_CHARACTER))
3473 return false;
3475 if (z != NULL && !type_check (z, 2, BT_LOGICAL))
3476 return false;
3478 if (!kind_check (kind, 3, BT_INTEGER))
3479 return false;
3480 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
3481 "with KIND argument at %L",
3482 gfc_current_intrinsic, &kind->where))
3483 return false;
3485 if (!same_type_check (x, 0, y, 1))
3486 return false;
3488 return true;
3492 bool
3493 gfc_check_secnds (gfc_expr *r)
3495 if (!type_check (r, 0, BT_REAL))
3496 return false;
3498 if (!kind_value_check (r, 0, 4))
3499 return false;
3501 if (!scalar_check (r, 0))
3502 return false;
3504 return true;
3508 bool
3509 gfc_check_selected_char_kind (gfc_expr *name)
3511 if (!type_check (name, 0, BT_CHARACTER))
3512 return false;
3514 if (!kind_value_check (name, 0, gfc_default_character_kind))
3515 return false;
3517 if (!scalar_check (name, 0))
3518 return false;
3520 return true;
3524 bool
3525 gfc_check_selected_int_kind (gfc_expr *r)
3527 if (!type_check (r, 0, BT_INTEGER))
3528 return false;
3530 if (!scalar_check (r, 0))
3531 return false;
3533 return true;
3537 bool
3538 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
3540 if (p == NULL && r == NULL
3541 && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
3542 " neither 'P' nor 'R' argument at %L",
3543 gfc_current_intrinsic_where))
3544 return false;
3546 if (p)
3548 if (!type_check (p, 0, BT_INTEGER))
3549 return false;
3551 if (!scalar_check (p, 0))
3552 return false;
3555 if (r)
3557 if (!type_check (r, 1, BT_INTEGER))
3558 return false;
3560 if (!scalar_check (r, 1))
3561 return false;
3564 if (radix)
3566 if (!type_check (radix, 1, BT_INTEGER))
3567 return false;
3569 if (!scalar_check (radix, 1))
3570 return false;
3572 if (!gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with "
3573 "RADIX argument at %L", gfc_current_intrinsic,
3574 &radix->where))
3575 return false;
3578 return true;
3582 bool
3583 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
3585 if (!type_check (x, 0, BT_REAL))
3586 return false;
3588 if (!type_check (i, 1, BT_INTEGER))
3589 return false;
3591 return true;
3595 bool
3596 gfc_check_shape (gfc_expr *source, gfc_expr *kind)
3598 gfc_array_ref *ar;
3600 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3601 return true;
3603 ar = gfc_find_array_ref (source);
3605 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
3607 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3608 "an assumed size array", &source->where);
3609 return false;
3612 if (!kind_check (kind, 1, BT_INTEGER))
3613 return false;
3614 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
3615 "with KIND argument at %L",
3616 gfc_current_intrinsic, &kind->where))
3617 return false;
3619 return true;
3623 bool
3624 gfc_check_shift (gfc_expr *i, gfc_expr *shift)
3626 if (!type_check (i, 0, BT_INTEGER))
3627 return false;
3629 if (!type_check (shift, 0, BT_INTEGER))
3630 return false;
3632 if (!nonnegative_check ("SHIFT", shift))
3633 return false;
3635 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
3636 return false;
3638 return true;
3642 bool
3643 gfc_check_sign (gfc_expr *a, gfc_expr *b)
3645 if (!int_or_real_check (a, 0))
3646 return false;
3648 if (!same_type_check (a, 0, b, 1))
3649 return false;
3651 return true;
3655 bool
3656 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3658 if (!array_check (array, 0))
3659 return false;
3661 if (!dim_check (dim, 1, true))
3662 return false;
3664 if (!dim_rank_check (dim, array, 0))
3665 return false;
3667 if (!kind_check (kind, 2, BT_INTEGER))
3668 return false;
3669 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
3670 "with KIND argument at %L",
3671 gfc_current_intrinsic, &kind->where))
3672 return false;
3675 return true;
3679 bool
3680 gfc_check_sizeof (gfc_expr *arg)
3682 if (arg->ts.type == BT_PROCEDURE)
3684 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
3685 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3686 &arg->where);
3687 return false;
3690 if (arg->ts.type == BT_ASSUMED)
3692 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
3693 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3694 &arg->where);
3695 return false;
3698 if (arg->rank && arg->expr_type == EXPR_VARIABLE
3699 && arg->symtree->n.sym->as != NULL
3700 && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
3701 && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
3703 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3704 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
3705 gfc_current_intrinsic, &arg->where);
3706 return false;
3709 return true;
3713 /* Check whether an expression is interoperable. When returning false,
3714 msg is set to a string telling why the expression is not interoperable,
3715 otherwise, it is set to NULL. The msg string can be used in diagnostics.
3716 If c_loc is true, character with len > 1 are allowed (cf. Fortran
3717 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
3718 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
3719 are permitted. */
3721 static bool
3722 is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
3724 *msg = NULL;
3726 if (expr->ts.type == BT_CLASS)
3728 *msg = "Expression is polymorphic";
3729 return false;
3732 if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
3733 && !expr->ts.u.derived->ts.is_iso_c)
3735 *msg = "Expression is a noninteroperable derived type";
3736 return false;
3739 if (expr->ts.type == BT_PROCEDURE)
3741 *msg = "Procedure unexpected as argument";
3742 return false;
3745 if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
3747 int i;
3748 for (i = 0; gfc_logical_kinds[i].kind; i++)
3749 if (gfc_logical_kinds[i].kind == expr->ts.kind)
3750 return true;
3751 *msg = "Extension to use a non-C_Bool-kind LOGICAL";
3752 return false;
3755 if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
3756 && expr->ts.kind != 1)
3758 *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
3759 return false;
3762 if (expr->ts.type == BT_CHARACTER) {
3763 if (expr->ts.deferred)
3765 /* TS 29113 allows deferred-length strings as dummy arguments,
3766 but it is not an interoperable type. */
3767 *msg = "Expression shall not be a deferred-length string";
3768 return false;
3771 if (expr->ts.u.cl && expr->ts.u.cl->length
3772 && !gfc_simplify_expr (expr, 0))
3773 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
3775 if (!c_loc && expr->ts.u.cl
3776 && (!expr->ts.u.cl->length
3777 || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3778 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
3780 *msg = "Type shall have a character length of 1";
3781 return false;
3785 /* Note: The following checks are about interoperatable variables, Fortran
3786 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
3787 is allowed, e.g. assumed-shape arrays with TS 29113. */
3789 if (gfc_is_coarray (expr))
3791 *msg = "Coarrays are not interoperable";
3792 return false;
3795 if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
3797 gfc_array_ref *ar = gfc_find_array_ref (expr);
3798 if (ar->type != AR_FULL)
3800 *msg = "Only whole-arrays are interoperable";
3801 return false;
3803 if (!c_f_ptr && ar->as->type != AS_EXPLICIT
3804 && ar->as->type != AS_ASSUMED_SIZE)
3806 *msg = "Only explicit-size and assumed-size arrays are interoperable";
3807 return false;
3811 return true;
3815 bool
3816 gfc_check_c_sizeof (gfc_expr *arg)
3818 const char *msg;
3820 if (!is_c_interoperable (arg, &msg, false, false))
3822 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3823 "interoperable data entity: %s",
3824 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3825 &arg->where, msg);
3826 return false;
3829 if (arg->ts.type == BT_ASSUMED)
3831 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
3832 "TYPE(*)",
3833 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3834 &arg->where);
3835 return false;
3838 if (arg->rank && arg->expr_type == EXPR_VARIABLE
3839 && arg->symtree->n.sym->as != NULL
3840 && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
3841 && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
3843 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
3844 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
3845 gfc_current_intrinsic, &arg->where);
3846 return false;
3849 return true;
3853 bool
3854 gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
3856 if (c_ptr_1->ts.type != BT_DERIVED
3857 || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
3858 || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
3859 && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
3861 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
3862 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
3863 return false;
3866 if (!scalar_check (c_ptr_1, 0))
3867 return false;
3869 if (c_ptr_2
3870 && (c_ptr_2->ts.type != BT_DERIVED
3871 || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
3872 || (c_ptr_1->ts.u.derived->intmod_sym_id
3873 != c_ptr_2->ts.u.derived->intmod_sym_id)))
3875 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
3876 "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
3877 gfc_typename (&c_ptr_1->ts),
3878 gfc_typename (&c_ptr_2->ts));
3879 return false;
3882 if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
3883 return false;
3885 return true;
3889 bool
3890 gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
3892 symbol_attribute attr;
3893 const char *msg;
3895 if (cptr->ts.type != BT_DERIVED
3896 || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
3897 || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
3899 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
3900 "type TYPE(C_PTR)", &cptr->where);
3901 return false;
3904 if (!scalar_check (cptr, 0))
3905 return false;
3907 attr = gfc_expr_attr (fptr);
3909 if (!attr.pointer)
3911 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
3912 &fptr->where);
3913 return false;
3916 if (fptr->ts.type == BT_CLASS)
3918 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
3919 &fptr->where);
3920 return false;
3923 if (gfc_is_coindexed (fptr))
3925 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
3926 "coindexed", &fptr->where);
3927 return false;
3930 if (fptr->rank == 0 && shape)
3932 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
3933 "FPTR", &fptr->where);
3934 return false;
3936 else if (fptr->rank && !shape)
3938 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
3939 "FPTR at %L", &fptr->where);
3940 return false;
3943 if (shape && !rank_check (shape, 2, 1))
3944 return false;
3946 if (shape && !type_check (shape, 2, BT_INTEGER))
3947 return false;
3949 if (shape)
3951 mpz_t size;
3953 if (gfc_array_size (shape, &size)
3954 && mpz_cmp_ui (size, fptr->rank) != 0)
3956 mpz_clear (size);
3957 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
3958 "size as the RANK of FPTR", &shape->where);
3959 return false;
3961 mpz_clear (size);
3964 if (fptr->ts.type == BT_CLASS)
3966 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
3967 return false;
3970 if (!is_c_interoperable (fptr, &msg, false, true))
3971 return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR "
3972 "at %L to C_F_POINTER: %s", &fptr->where, msg);
3974 return true;
3978 bool
3979 gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
3981 symbol_attribute attr;
3983 if (cptr->ts.type != BT_DERIVED
3984 || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
3985 || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
3987 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
3988 "type TYPE(C_FUNPTR)", &cptr->where);
3989 return false;
3992 if (!scalar_check (cptr, 0))
3993 return false;
3995 attr = gfc_expr_attr (fptr);
3997 if (!attr.proc_pointer)
3999 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
4000 "pointer", &fptr->where);
4001 return false;
4004 if (gfc_is_coindexed (fptr))
4006 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
4007 "coindexed", &fptr->where);
4008 return false;
4011 if (!attr.is_bind_c)
4012 return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
4013 "pointer at %L to C_F_PROCPOINTER", &fptr->where);
4015 return true;
4019 bool
4020 gfc_check_c_funloc (gfc_expr *x)
4022 symbol_attribute attr;
4024 if (gfc_is_coindexed (x))
4026 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
4027 "coindexed", &x->where);
4028 return false;
4031 attr = gfc_expr_attr (x);
4033 if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
4034 && x->symtree->n.sym == x->symtree->n.sym->result)
4036 gfc_namespace *ns = gfc_current_ns;
4038 for (ns = gfc_current_ns; ns; ns = ns->parent)
4039 if (x->symtree->n.sym == ns->proc_name)
4041 gfc_error ("Function result '%s' at %L is invalid as X argument "
4042 "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
4043 return false;
4047 if (attr.flavor != FL_PROCEDURE)
4049 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
4050 "or a procedure pointer", &x->where);
4051 return false;
4054 if (!attr.is_bind_c)
4055 return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
4056 "at %L to C_FUNLOC", &x->where);
4057 return true;
4061 bool
4062 gfc_check_c_loc (gfc_expr *x)
4064 symbol_attribute attr;
4065 const char *msg;
4067 if (gfc_is_coindexed (x))
4069 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
4070 return false;
4073 if (x->ts.type == BT_CLASS)
4075 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
4076 &x->where);
4077 return false;
4080 attr = gfc_expr_attr (x);
4082 if (!attr.pointer
4083 && (x->expr_type != EXPR_VARIABLE || !attr.target
4084 || attr.flavor == FL_PARAMETER))
4086 gfc_error ("Argument X at %L to C_LOC shall have either "
4087 "the POINTER or the TARGET attribute", &x->where);
4088 return false;
4091 if (x->ts.type == BT_CHARACTER
4092 && gfc_var_strlen (x) == 0)
4094 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
4095 "string", &x->where);
4096 return false;
4099 if (!is_c_interoperable (x, &msg, true, false))
4101 if (x->ts.type == BT_CLASS)
4103 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
4104 &x->where);
4105 return false;
4108 if (x->rank
4109 && !gfc_notify_std (GFC_STD_F2008_TS,
4110 "Noninteroperable array at %L as"
4111 " argument to C_LOC: %s", &x->where, msg))
4112 return false;
4114 else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
4116 gfc_array_ref *ar = gfc_find_array_ref (x);
4118 if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
4119 && !attr.allocatable
4120 && !gfc_notify_std (GFC_STD_F2008,
4121 "Array of interoperable type at %L "
4122 "to C_LOC which is nonallocatable and neither "
4123 "assumed size nor explicit size", &x->where))
4124 return false;
4125 else if (ar->type != AR_FULL
4126 && !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
4127 "to C_LOC", &x->where))
4128 return false;
4131 return true;
4135 bool
4136 gfc_check_sleep_sub (gfc_expr *seconds)
4138 if (!type_check (seconds, 0, BT_INTEGER))
4139 return false;
4141 if (!scalar_check (seconds, 0))
4142 return false;
4144 return true;
4147 bool
4148 gfc_check_sngl (gfc_expr *a)
4150 if (!type_check (a, 0, BT_REAL))
4151 return false;
4153 if ((a->ts.kind != gfc_default_double_kind)
4154 && !gfc_notify_std (GFC_STD_GNU, "non double precision "
4155 "REAL argument to %s intrinsic at %L",
4156 gfc_current_intrinsic, &a->where))
4157 return false;
4159 return true;
4162 bool
4163 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
4165 if (source->rank >= GFC_MAX_DIMENSIONS)
4167 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
4168 "than rank %d", gfc_current_intrinsic_arg[0]->name,
4169 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
4171 return false;
4174 if (dim == NULL)
4175 return false;
4177 if (!dim_check (dim, 1, false))
4178 return false;
4180 /* dim_rank_check() does not apply here. */
4181 if (dim
4182 && dim->expr_type == EXPR_CONSTANT
4183 && (mpz_cmp_ui (dim->value.integer, 1) < 0
4184 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
4186 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
4187 "dimension index", gfc_current_intrinsic_arg[1]->name,
4188 gfc_current_intrinsic, &dim->where);
4189 return false;
4192 if (!type_check (ncopies, 2, BT_INTEGER))
4193 return false;
4195 if (!scalar_check (ncopies, 2))
4196 return false;
4198 return true;
4202 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
4203 functions). */
4205 bool
4206 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
4208 if (!type_check (unit, 0, BT_INTEGER))
4209 return false;
4211 if (!scalar_check (unit, 0))
4212 return false;
4214 if (!type_check (c, 1, BT_CHARACTER))
4215 return false;
4216 if (!kind_value_check (c, 1, gfc_default_character_kind))
4217 return false;
4219 if (status == NULL)
4220 return true;
4222 if (!type_check (status, 2, BT_INTEGER)
4223 || !kind_value_check (status, 2, gfc_default_integer_kind)
4224 || !scalar_check (status, 2))
4225 return false;
4227 return true;
4231 bool
4232 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
4234 return gfc_check_fgetputc_sub (unit, c, NULL);
4238 bool
4239 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
4241 if (!type_check (c, 0, BT_CHARACTER))
4242 return false;
4243 if (!kind_value_check (c, 0, gfc_default_character_kind))
4244 return false;
4246 if (status == NULL)
4247 return true;
4249 if (!type_check (status, 1, BT_INTEGER)
4250 || !kind_value_check (status, 1, gfc_default_integer_kind)
4251 || !scalar_check (status, 1))
4252 return false;
4254 return true;
4258 bool
4259 gfc_check_fgetput (gfc_expr *c)
4261 return gfc_check_fgetput_sub (c, NULL);
4265 bool
4266 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
4268 if (!type_check (unit, 0, BT_INTEGER))
4269 return false;
4271 if (!scalar_check (unit, 0))
4272 return false;
4274 if (!type_check (offset, 1, BT_INTEGER))
4275 return false;
4277 if (!scalar_check (offset, 1))
4278 return false;
4280 if (!type_check (whence, 2, BT_INTEGER))
4281 return false;
4283 if (!scalar_check (whence, 2))
4284 return false;
4286 if (status == NULL)
4287 return true;
4289 if (!type_check (status, 3, BT_INTEGER))
4290 return false;
4292 if (!kind_value_check (status, 3, 4))
4293 return false;
4295 if (!scalar_check (status, 3))
4296 return false;
4298 return true;
4303 bool
4304 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
4306 if (!type_check (unit, 0, BT_INTEGER))
4307 return false;
4309 if (!scalar_check (unit, 0))
4310 return false;
4312 if (!type_check (array, 1, BT_INTEGER)
4313 || !kind_value_check (unit, 0, gfc_default_integer_kind))
4314 return false;
4316 if (!array_check (array, 1))
4317 return false;
4319 return true;
4323 bool
4324 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
4326 if (!type_check (unit, 0, BT_INTEGER))
4327 return false;
4329 if (!scalar_check (unit, 0))
4330 return false;
4332 if (!type_check (array, 1, BT_INTEGER)
4333 || !kind_value_check (array, 1, gfc_default_integer_kind))
4334 return false;
4336 if (!array_check (array, 1))
4337 return false;
4339 if (status == NULL)
4340 return true;
4342 if (!type_check (status, 2, BT_INTEGER)
4343 || !kind_value_check (status, 2, gfc_default_integer_kind))
4344 return false;
4346 if (!scalar_check (status, 2))
4347 return false;
4349 return true;
4353 bool
4354 gfc_check_ftell (gfc_expr *unit)
4356 if (!type_check (unit, 0, BT_INTEGER))
4357 return false;
4359 if (!scalar_check (unit, 0))
4360 return false;
4362 return true;
4366 bool
4367 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
4369 if (!type_check (unit, 0, BT_INTEGER))
4370 return false;
4372 if (!scalar_check (unit, 0))
4373 return false;
4375 if (!type_check (offset, 1, BT_INTEGER))
4376 return false;
4378 if (!scalar_check (offset, 1))
4379 return false;
4381 return true;
4385 bool
4386 gfc_check_stat (gfc_expr *name, gfc_expr *array)
4388 if (!type_check (name, 0, BT_CHARACTER))
4389 return false;
4390 if (!kind_value_check (name, 0, gfc_default_character_kind))
4391 return false;
4393 if (!type_check (array, 1, BT_INTEGER)
4394 || !kind_value_check (array, 1, gfc_default_integer_kind))
4395 return false;
4397 if (!array_check (array, 1))
4398 return false;
4400 return true;
4404 bool
4405 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
4407 if (!type_check (name, 0, BT_CHARACTER))
4408 return false;
4409 if (!kind_value_check (name, 0, gfc_default_character_kind))
4410 return false;
4412 if (!type_check (array, 1, BT_INTEGER)
4413 || !kind_value_check (array, 1, gfc_default_integer_kind))
4414 return false;
4416 if (!array_check (array, 1))
4417 return false;
4419 if (status == NULL)
4420 return true;
4422 if (!type_check (status, 2, BT_INTEGER)
4423 || !kind_value_check (array, 1, gfc_default_integer_kind))
4424 return false;
4426 if (!scalar_check (status, 2))
4427 return false;
4429 return true;
4433 bool
4434 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
4436 mpz_t nelems;
4438 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4440 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4441 return false;
4444 if (!coarray_check (coarray, 0))
4445 return false;
4447 if (sub->rank != 1)
4449 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
4450 gfc_current_intrinsic_arg[1]->name, &sub->where);
4451 return false;
4454 if (gfc_array_size (sub, &nelems))
4456 int corank = gfc_get_corank (coarray);
4458 if (mpz_cmp_ui (nelems, corank) != 0)
4460 gfc_error ("The number of array elements of the SUB argument to "
4461 "IMAGE_INDEX at %L shall be %d (corank) not %d",
4462 &sub->where, corank, (int) mpz_get_si (nelems));
4463 mpz_clear (nelems);
4464 return false;
4466 mpz_clear (nelems);
4469 return true;
4473 bool
4474 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
4476 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4478 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4479 return false;
4482 if (dim != NULL && coarray == NULL)
4484 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
4485 "intrinsic at %L", &dim->where);
4486 return false;
4489 if (coarray == NULL)
4490 return true;
4492 if (!coarray_check (coarray, 0))
4493 return false;
4495 if (dim != NULL)
4497 if (!dim_check (dim, 1, false))
4498 return false;
4500 if (!dim_corank_check (dim, coarray))
4501 return false;
4504 return true;
4507 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4508 by gfc_simplify_transfer. Return false if we cannot do so. */
4510 bool
4511 gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
4512 size_t *source_size, size_t *result_size,
4513 size_t *result_length_p)
4515 size_t result_elt_size;
4517 if (source->expr_type == EXPR_FUNCTION)
4518 return false;
4520 if (size && size->expr_type != EXPR_CONSTANT)
4521 return false;
4523 /* Calculate the size of the source. */
4524 *source_size = gfc_target_expr_size (source);
4525 if (*source_size == 0)
4526 return false;
4528 /* Determine the size of the element. */
4529 result_elt_size = gfc_element_size (mold);
4530 if (result_elt_size == 0)
4531 return false;
4533 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4535 int result_length;
4537 if (size)
4538 result_length = (size_t)mpz_get_ui (size->value.integer);
4539 else
4541 result_length = *source_size / result_elt_size;
4542 if (result_length * result_elt_size < *source_size)
4543 result_length += 1;
4546 *result_size = result_length * result_elt_size;
4547 if (result_length_p)
4548 *result_length_p = result_length;
4550 else
4551 *result_size = result_elt_size;
4553 return true;
4557 bool
4558 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4560 size_t source_size;
4561 size_t result_size;
4563 if (mold->ts.type == BT_HOLLERITH)
4565 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4566 &mold->where, gfc_basic_typename (BT_HOLLERITH));
4567 return false;
4570 if (size != NULL)
4572 if (!type_check (size, 2, BT_INTEGER))
4573 return false;
4575 if (!scalar_check (size, 2))
4576 return false;
4578 if (!nonoptional_check (size, 2))
4579 return false;
4582 if (!gfc_option.warn_surprising)
4583 return true;
4585 /* If we can't calculate the sizes, we cannot check any more.
4586 Return true for that case. */
4588 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
4589 &result_size, NULL))
4590 return true;
4592 if (source_size < result_size)
4593 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4594 "source size %ld < result size %ld", &source->where,
4595 (long) source_size, (long) result_size);
4597 return true;
4601 bool
4602 gfc_check_transpose (gfc_expr *matrix)
4604 if (!rank_check (matrix, 0, 2))
4605 return false;
4607 return true;
4611 bool
4612 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4614 if (!array_check (array, 0))
4615 return false;
4617 if (!dim_check (dim, 1, false))
4618 return false;
4620 if (!dim_rank_check (dim, array, 0))
4621 return false;
4623 if (!kind_check (kind, 2, BT_INTEGER))
4624 return false;
4625 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
4626 "with KIND argument at %L",
4627 gfc_current_intrinsic, &kind->where))
4628 return false;
4630 return true;
4634 bool
4635 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
4637 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4639 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4640 return false;
4643 if (!coarray_check (coarray, 0))
4644 return false;
4646 if (dim != NULL)
4648 if (!dim_check (dim, 1, false))
4649 return false;
4651 if (!dim_corank_check (dim, coarray))
4652 return false;
4655 if (!kind_check (kind, 2, BT_INTEGER))
4656 return false;
4658 return true;
4662 bool
4663 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
4665 mpz_t vector_size;
4667 if (!rank_check (vector, 0, 1))
4668 return false;
4670 if (!array_check (mask, 1))
4671 return false;
4673 if (!type_check (mask, 1, BT_LOGICAL))
4674 return false;
4676 if (!same_type_check (vector, 0, field, 2))
4677 return false;
4679 if (mask->expr_type == EXPR_ARRAY
4680 && gfc_array_size (vector, &vector_size))
4682 int mask_true_count = 0;
4683 gfc_constructor *mask_ctor;
4684 mask_ctor = gfc_constructor_first (mask->value.constructor);
4685 while (mask_ctor)
4687 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4689 mask_true_count = 0;
4690 break;
4693 if (mask_ctor->expr->value.logical)
4694 mask_true_count++;
4696 mask_ctor = gfc_constructor_next (mask_ctor);
4699 if (mpz_get_si (vector_size) < mask_true_count)
4701 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4702 "provide at least as many elements as there "
4703 "are .TRUE. values in '%s' (%ld/%d)",
4704 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4705 &vector->where, gfc_current_intrinsic_arg[1]->name,
4706 mpz_get_si (vector_size), mask_true_count);
4707 return false;
4710 mpz_clear (vector_size);
4713 if (mask->rank != field->rank && field->rank != 0)
4715 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4716 "the same rank as '%s' or be a scalar",
4717 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4718 &field->where, gfc_current_intrinsic_arg[1]->name);
4719 return false;
4722 if (mask->rank == field->rank)
4724 int i;
4725 for (i = 0; i < field->rank; i++)
4726 if (! identical_dimen_shape (mask, i, field, i))
4728 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4729 "must have identical shape.",
4730 gfc_current_intrinsic_arg[2]->name,
4731 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4732 &field->where);
4736 return true;
4740 bool
4741 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4743 if (!type_check (x, 0, BT_CHARACTER))
4744 return false;
4746 if (!same_type_check (x, 0, y, 1))
4747 return false;
4749 if (z != NULL && !type_check (z, 2, BT_LOGICAL))
4750 return false;
4752 if (!kind_check (kind, 3, BT_INTEGER))
4753 return false;
4754 if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
4755 "with KIND argument at %L",
4756 gfc_current_intrinsic, &kind->where))
4757 return false;
4759 return true;
4763 bool
4764 gfc_check_trim (gfc_expr *x)
4766 if (!type_check (x, 0, BT_CHARACTER))
4767 return false;
4769 if (!scalar_check (x, 0))
4770 return false;
4772 return true;
4776 bool
4777 gfc_check_ttynam (gfc_expr *unit)
4779 if (!scalar_check (unit, 0))
4780 return false;
4782 if (!type_check (unit, 0, BT_INTEGER))
4783 return false;
4785 return true;
4789 /* Common check function for the half a dozen intrinsics that have a
4790 single real argument. */
4792 bool
4793 gfc_check_x (gfc_expr *x)
4795 if (!type_check (x, 0, BT_REAL))
4796 return false;
4798 return true;
4802 /************* Check functions for intrinsic subroutines *************/
4804 bool
4805 gfc_check_cpu_time (gfc_expr *time)
4807 if (!scalar_check (time, 0))
4808 return false;
4810 if (!type_check (time, 0, BT_REAL))
4811 return false;
4813 if (!variable_check (time, 0, false))
4814 return false;
4816 return true;
4820 bool
4821 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
4822 gfc_expr *zone, gfc_expr *values)
4824 if (date != NULL)
4826 if (!type_check (date, 0, BT_CHARACTER))
4827 return false;
4828 if (!kind_value_check (date, 0, gfc_default_character_kind))
4829 return false;
4830 if (!scalar_check (date, 0))
4831 return false;
4832 if (!variable_check (date, 0, false))
4833 return false;
4836 if (time != NULL)
4838 if (!type_check (time, 1, BT_CHARACTER))
4839 return false;
4840 if (!kind_value_check (time, 1, gfc_default_character_kind))
4841 return false;
4842 if (!scalar_check (time, 1))
4843 return false;
4844 if (!variable_check (time, 1, false))
4845 return false;
4848 if (zone != NULL)
4850 if (!type_check (zone, 2, BT_CHARACTER))
4851 return false;
4852 if (!kind_value_check (zone, 2, gfc_default_character_kind))
4853 return false;
4854 if (!scalar_check (zone, 2))
4855 return false;
4856 if (!variable_check (zone, 2, false))
4857 return false;
4860 if (values != NULL)
4862 if (!type_check (values, 3, BT_INTEGER))
4863 return false;
4864 if (!array_check (values, 3))
4865 return false;
4866 if (!rank_check (values, 3, 1))
4867 return false;
4868 if (!variable_check (values, 3, false))
4869 return false;
4872 return true;
4876 bool
4877 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
4878 gfc_expr *to, gfc_expr *topos)
4880 if (!type_check (from, 0, BT_INTEGER))
4881 return false;
4883 if (!type_check (frompos, 1, BT_INTEGER))
4884 return false;
4886 if (!type_check (len, 2, BT_INTEGER))
4887 return false;
4889 if (!same_type_check (from, 0, to, 3))
4890 return false;
4892 if (!variable_check (to, 3, false))
4893 return false;
4895 if (!type_check (topos, 4, BT_INTEGER))
4896 return false;
4898 if (!nonnegative_check ("frompos", frompos))
4899 return false;
4901 if (!nonnegative_check ("topos", topos))
4902 return false;
4904 if (!nonnegative_check ("len", len))
4905 return false;
4907 if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
4908 return false;
4910 if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
4911 return false;
4913 return true;
4917 bool
4918 gfc_check_random_number (gfc_expr *harvest)
4920 if (!type_check (harvest, 0, BT_REAL))
4921 return false;
4923 if (!variable_check (harvest, 0, false))
4924 return false;
4926 return true;
4930 bool
4931 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
4933 unsigned int nargs = 0, kiss_size;
4934 locus *where = NULL;
4935 mpz_t put_size, get_size;
4936 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4938 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
4940 /* Keep the number of bytes in sync with kiss_size in
4941 libgfortran/intrinsics/random.c. */
4942 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
4944 if (size != NULL)
4946 if (size->expr_type != EXPR_VARIABLE
4947 || !size->symtree->n.sym->attr.optional)
4948 nargs++;
4950 if (!scalar_check (size, 0))
4951 return false;
4953 if (!type_check (size, 0, BT_INTEGER))
4954 return false;
4956 if (!variable_check (size, 0, false))
4957 return false;
4959 if (!kind_value_check (size, 0, gfc_default_integer_kind))
4960 return false;
4963 if (put != NULL)
4965 if (put->expr_type != EXPR_VARIABLE
4966 || !put->symtree->n.sym->attr.optional)
4968 nargs++;
4969 where = &put->where;
4972 if (!array_check (put, 1))
4973 return false;
4975 if (!rank_check (put, 1, 1))
4976 return false;
4978 if (!type_check (put, 1, BT_INTEGER))
4979 return false;
4981 if (!kind_value_check (put, 1, gfc_default_integer_kind))
4982 return false;
4984 if (gfc_array_size (put, &put_size)
4985 && mpz_get_ui (put_size) < kiss_size)
4986 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4987 "too small (%i/%i)",
4988 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4989 where, (int) mpz_get_ui (put_size), kiss_size);
4992 if (get != NULL)
4994 if (get->expr_type != EXPR_VARIABLE
4995 || !get->symtree->n.sym->attr.optional)
4997 nargs++;
4998 where = &get->where;
5001 if (!array_check (get, 2))
5002 return false;
5004 if (!rank_check (get, 2, 1))
5005 return false;
5007 if (!type_check (get, 2, BT_INTEGER))
5008 return false;
5010 if (!variable_check (get, 2, false))
5011 return false;
5013 if (!kind_value_check (get, 2, gfc_default_integer_kind))
5014 return false;
5016 if (gfc_array_size (get, &get_size)
5017 && mpz_get_ui (get_size) < kiss_size)
5018 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
5019 "too small (%i/%i)",
5020 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
5021 where, (int) mpz_get_ui (get_size), kiss_size);
5024 /* RANDOM_SEED may not have more than one non-optional argument. */
5025 if (nargs > 1)
5026 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
5028 return true;
5032 bool
5033 gfc_check_second_sub (gfc_expr *time)
5035 if (!scalar_check (time, 0))
5036 return false;
5038 if (!type_check (time, 0, BT_REAL))
5039 return false;
5041 if (!kind_value_check (time, 0, 4))
5042 return false;
5044 return true;
5048 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
5049 count, count_rate, and count_max are all optional arguments */
5051 bool
5052 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
5053 gfc_expr *count_max)
5055 if (count != NULL)
5057 if (!scalar_check (count, 0))
5058 return false;
5060 if (!type_check (count, 0, BT_INTEGER))
5061 return false;
5063 if (!variable_check (count, 0, false))
5064 return false;
5067 if (count_rate != NULL)
5069 if (!scalar_check (count_rate, 1))
5070 return false;
5072 if (!type_check (count_rate, 1, BT_INTEGER))
5073 return false;
5075 if (!variable_check (count_rate, 1, false))
5076 return false;
5078 if (count != NULL
5079 && !same_type_check (count, 0, count_rate, 1))
5080 return false;
5084 if (count_max != NULL)
5086 if (!scalar_check (count_max, 2))
5087 return false;
5089 if (!type_check (count_max, 2, BT_INTEGER))
5090 return false;
5092 if (!variable_check (count_max, 2, false))
5093 return false;
5095 if (count != NULL
5096 && !same_type_check (count, 0, count_max, 2))
5097 return false;
5099 if (count_rate != NULL
5100 && !same_type_check (count_rate, 1, count_max, 2))
5101 return false;
5104 return true;
5108 bool
5109 gfc_check_irand (gfc_expr *x)
5111 if (x == NULL)
5112 return true;
5114 if (!scalar_check (x, 0))
5115 return false;
5117 if (!type_check (x, 0, BT_INTEGER))
5118 return false;
5120 if (!kind_value_check (x, 0, 4))
5121 return false;
5123 return true;
5127 bool
5128 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
5130 if (!scalar_check (seconds, 0))
5131 return false;
5132 if (!type_check (seconds, 0, BT_INTEGER))
5133 return false;
5135 if (!int_or_proc_check (handler, 1))
5136 return false;
5137 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
5138 return false;
5140 if (status == NULL)
5141 return true;
5143 if (!scalar_check (status, 2))
5144 return false;
5145 if (!type_check (status, 2, BT_INTEGER))
5146 return false;
5147 if (!kind_value_check (status, 2, gfc_default_integer_kind))
5148 return false;
5150 return true;
5154 bool
5155 gfc_check_rand (gfc_expr *x)
5157 if (x == NULL)
5158 return true;
5160 if (!scalar_check (x, 0))
5161 return false;
5163 if (!type_check (x, 0, BT_INTEGER))
5164 return false;
5166 if (!kind_value_check (x, 0, 4))
5167 return false;
5169 return true;
5173 bool
5174 gfc_check_srand (gfc_expr *x)
5176 if (!scalar_check (x, 0))
5177 return false;
5179 if (!type_check (x, 0, BT_INTEGER))
5180 return false;
5182 if (!kind_value_check (x, 0, 4))
5183 return false;
5185 return true;
5189 bool
5190 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
5192 if (!scalar_check (time, 0))
5193 return false;
5194 if (!type_check (time, 0, BT_INTEGER))
5195 return false;
5197 if (!type_check (result, 1, BT_CHARACTER))
5198 return false;
5199 if (!kind_value_check (result, 1, gfc_default_character_kind))
5200 return false;
5202 return true;
5206 bool
5207 gfc_check_dtime_etime (gfc_expr *x)
5209 if (!array_check (x, 0))
5210 return false;
5212 if (!rank_check (x, 0, 1))
5213 return false;
5215 if (!variable_check (x, 0, false))
5216 return false;
5218 if (!type_check (x, 0, BT_REAL))
5219 return false;
5221 if (!kind_value_check (x, 0, 4))
5222 return false;
5224 return true;
5228 bool
5229 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
5231 if (!array_check (values, 0))
5232 return false;
5234 if (!rank_check (values, 0, 1))
5235 return false;
5237 if (!variable_check (values, 0, false))
5238 return false;
5240 if (!type_check (values, 0, BT_REAL))
5241 return false;
5243 if (!kind_value_check (values, 0, 4))
5244 return false;
5246 if (!scalar_check (time, 1))
5247 return false;
5249 if (!type_check (time, 1, BT_REAL))
5250 return false;
5252 if (!kind_value_check (time, 1, 4))
5253 return false;
5255 return true;
5259 bool
5260 gfc_check_fdate_sub (gfc_expr *date)
5262 if (!type_check (date, 0, BT_CHARACTER))
5263 return false;
5264 if (!kind_value_check (date, 0, gfc_default_character_kind))
5265 return false;
5267 return true;
5271 bool
5272 gfc_check_gerror (gfc_expr *msg)
5274 if (!type_check (msg, 0, BT_CHARACTER))
5275 return false;
5276 if (!kind_value_check (msg, 0, gfc_default_character_kind))
5277 return false;
5279 return true;
5283 bool
5284 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
5286 if (!type_check (cwd, 0, BT_CHARACTER))
5287 return false;
5288 if (!kind_value_check (cwd, 0, gfc_default_character_kind))
5289 return false;
5291 if (status == NULL)
5292 return true;
5294 if (!scalar_check (status, 1))
5295 return false;
5297 if (!type_check (status, 1, BT_INTEGER))
5298 return false;
5300 return true;
5304 bool
5305 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
5307 if (!type_check (pos, 0, BT_INTEGER))
5308 return false;
5310 if (pos->ts.kind > gfc_default_integer_kind)
5312 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
5313 "not wider than the default kind (%d)",
5314 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5315 &pos->where, gfc_default_integer_kind);
5316 return false;
5319 if (!type_check (value, 1, BT_CHARACTER))
5320 return false;
5321 if (!kind_value_check (value, 1, gfc_default_character_kind))
5322 return false;
5324 return true;
5328 bool
5329 gfc_check_getlog (gfc_expr *msg)
5331 if (!type_check (msg, 0, BT_CHARACTER))
5332 return false;
5333 if (!kind_value_check (msg, 0, gfc_default_character_kind))
5334 return false;
5336 return true;
5340 bool
5341 gfc_check_exit (gfc_expr *status)
5343 if (status == NULL)
5344 return true;
5346 if (!type_check (status, 0, BT_INTEGER))
5347 return false;
5349 if (!scalar_check (status, 0))
5350 return false;
5352 return true;
5356 bool
5357 gfc_check_flush (gfc_expr *unit)
5359 if (unit == NULL)
5360 return true;
5362 if (!type_check (unit, 0, BT_INTEGER))
5363 return false;
5365 if (!scalar_check (unit, 0))
5366 return false;
5368 return true;
5372 bool
5373 gfc_check_free (gfc_expr *i)
5375 if (!type_check (i, 0, BT_INTEGER))
5376 return false;
5378 if (!scalar_check (i, 0))
5379 return false;
5381 return true;
5385 bool
5386 gfc_check_hostnm (gfc_expr *name)
5388 if (!type_check (name, 0, BT_CHARACTER))
5389 return false;
5390 if (!kind_value_check (name, 0, gfc_default_character_kind))
5391 return false;
5393 return true;
5397 bool
5398 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
5400 if (!type_check (name, 0, BT_CHARACTER))
5401 return false;
5402 if (!kind_value_check (name, 0, gfc_default_character_kind))
5403 return false;
5405 if (status == NULL)
5406 return true;
5408 if (!scalar_check (status, 1))
5409 return false;
5411 if (!type_check (status, 1, BT_INTEGER))
5412 return false;
5414 return true;
5418 bool
5419 gfc_check_itime_idate (gfc_expr *values)
5421 if (!array_check (values, 0))
5422 return false;
5424 if (!rank_check (values, 0, 1))
5425 return false;
5427 if (!variable_check (values, 0, false))
5428 return false;
5430 if (!type_check (values, 0, BT_INTEGER))
5431 return false;
5433 if (!kind_value_check (values, 0, gfc_default_integer_kind))
5434 return false;
5436 return true;
5440 bool
5441 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
5443 if (!type_check (time, 0, BT_INTEGER))
5444 return false;
5446 if (!kind_value_check (time, 0, gfc_default_integer_kind))
5447 return false;
5449 if (!scalar_check (time, 0))
5450 return false;
5452 if (!array_check (values, 1))
5453 return false;
5455 if (!rank_check (values, 1, 1))
5456 return false;
5458 if (!variable_check (values, 1, false))
5459 return false;
5461 if (!type_check (values, 1, BT_INTEGER))
5462 return false;
5464 if (!kind_value_check (values, 1, gfc_default_integer_kind))
5465 return false;
5467 return true;
5471 bool
5472 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
5474 if (!scalar_check (unit, 0))
5475 return false;
5477 if (!type_check (unit, 0, BT_INTEGER))
5478 return false;
5480 if (!type_check (name, 1, BT_CHARACTER))
5481 return false;
5482 if (!kind_value_check (name, 1, gfc_default_character_kind))
5483 return false;
5485 return true;
5489 bool
5490 gfc_check_isatty (gfc_expr *unit)
5492 if (unit == NULL)
5493 return false;
5495 if (!type_check (unit, 0, BT_INTEGER))
5496 return false;
5498 if (!scalar_check (unit, 0))
5499 return false;
5501 return true;
5505 bool
5506 gfc_check_isnan (gfc_expr *x)
5508 if (!type_check (x, 0, BT_REAL))
5509 return false;
5511 return true;
5515 bool
5516 gfc_check_perror (gfc_expr *string)
5518 if (!type_check (string, 0, BT_CHARACTER))
5519 return false;
5520 if (!kind_value_check (string, 0, gfc_default_character_kind))
5521 return false;
5523 return true;
5527 bool
5528 gfc_check_umask (gfc_expr *mask)
5530 if (!type_check (mask, 0, BT_INTEGER))
5531 return false;
5533 if (!scalar_check (mask, 0))
5534 return false;
5536 return true;
5540 bool
5541 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
5543 if (!type_check (mask, 0, BT_INTEGER))
5544 return false;
5546 if (!scalar_check (mask, 0))
5547 return false;
5549 if (old == NULL)
5550 return true;
5552 if (!scalar_check (old, 1))
5553 return false;
5555 if (!type_check (old, 1, BT_INTEGER))
5556 return false;
5558 return true;
5562 bool
5563 gfc_check_unlink (gfc_expr *name)
5565 if (!type_check (name, 0, BT_CHARACTER))
5566 return false;
5567 if (!kind_value_check (name, 0, gfc_default_character_kind))
5568 return false;
5570 return true;
5574 bool
5575 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
5577 if (!type_check (name, 0, BT_CHARACTER))
5578 return false;
5579 if (!kind_value_check (name, 0, gfc_default_character_kind))
5580 return false;
5582 if (status == NULL)
5583 return true;
5585 if (!scalar_check (status, 1))
5586 return false;
5588 if (!type_check (status, 1, BT_INTEGER))
5589 return false;
5591 return true;
5595 bool
5596 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
5598 if (!scalar_check (number, 0))
5599 return false;
5600 if (!type_check (number, 0, BT_INTEGER))
5601 return false;
5603 if (!int_or_proc_check (handler, 1))
5604 return false;
5605 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
5606 return false;
5608 return true;
5612 bool
5613 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
5615 if (!scalar_check (number, 0))
5616 return false;
5617 if (!type_check (number, 0, BT_INTEGER))
5618 return false;
5620 if (!int_or_proc_check (handler, 1))
5621 return false;
5622 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
5623 return false;
5625 if (status == NULL)
5626 return true;
5628 if (!type_check (status, 2, BT_INTEGER))
5629 return false;
5630 if (!scalar_check (status, 2))
5631 return false;
5633 return true;
5637 bool
5638 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
5640 if (!type_check (cmd, 0, BT_CHARACTER))
5641 return false;
5642 if (!kind_value_check (cmd, 0, gfc_default_character_kind))
5643 return false;
5645 if (!scalar_check (status, 1))
5646 return false;
5648 if (!type_check (status, 1, BT_INTEGER))
5649 return false;
5651 if (!kind_value_check (status, 1, gfc_default_integer_kind))
5652 return false;
5654 return true;
5658 /* This is used for the GNU intrinsics AND, OR and XOR. */
5659 bool
5660 gfc_check_and (gfc_expr *i, gfc_expr *j)
5662 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
5664 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5665 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
5666 gfc_current_intrinsic, &i->where);
5667 return false;
5670 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
5672 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5673 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
5674 gfc_current_intrinsic, &j->where);
5675 return false;
5678 if (i->ts.type != j->ts.type)
5680 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5681 "have the same type", gfc_current_intrinsic_arg[0]->name,
5682 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5683 &j->where);
5684 return false;
5687 if (!scalar_check (i, 0))
5688 return false;
5690 if (!scalar_check (j, 1))
5691 return false;
5693 return true;
5697 bool
5698 gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
5700 if (a->ts.type == BT_ASSUMED)
5702 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
5703 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5704 &a->where);
5705 return false;
5708 if (a->ts.type == BT_PROCEDURE)
5710 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
5711 "procedure", gfc_current_intrinsic_arg[0]->name,
5712 gfc_current_intrinsic, &a->where);
5713 return false;
5716 if (kind == NULL)
5717 return true;
5719 if (!type_check (kind, 1, BT_INTEGER))
5720 return false;
5722 if (!scalar_check (kind, 1))
5723 return false;
5725 if (kind->expr_type != EXPR_CONSTANT)
5727 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5728 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5729 &kind->where);
5730 return false;
5733 return true;