]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/check.c
projects / thirdparty / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3)
[thirdparty/gcc.git] / gcc / fortran / check.c
1 /* Check functions
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
3 2011, 2012
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught & Katherine Holcomb
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
22
23
24 /* These functions check to see if an argument list is compatible with
25 a particular intrinsic function or subroutine. Presence of
26 required arguments has already been established, the argument list
27 has been sorted into the right order and has NULL arguments in the
28 correct places for missing optional arguments. */
29
30 #include "config.h"
31 #include "system.h"
32 #include "coretypes.h"
33 #include "flags.h"
34 #include "gfortran.h"
35 #include "intrinsic.h"
36 #include "constructor.h"
37 #include "target-memory.h"
38
39
40 /* Make sure an expression is a scalar. */
41
42 static gfc_try
43 scalar_check (gfc_expr *e, int n)
44 {
45 if (e->rank == 0)
46 return SUCCESS;
47
48 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
49 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
50 &e->where);
51
52 return FAILURE;
53 }
54
55
56 /* Check the type of an expression. */
57
58 static gfc_try
59 type_check (gfc_expr *e, int n, bt type)
60 {
61 if (e->ts.type == type)
62 return SUCCESS;
63
64 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
65 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
66 &e->where, gfc_basic_typename (type));
67
68 return FAILURE;
69 }
70
71
72 /* Check that the expression is a numeric type. */
73
74 static gfc_try
75 numeric_check (gfc_expr *e, int n)
76 {
77 if (gfc_numeric_ts (&e->ts))
78 return SUCCESS;
79
80 /* If the expression has not got a type, check if its namespace can
81 offer a default type. */
82 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
83 && e->symtree->n.sym->ts.type == BT_UNKNOWN
84 && gfc_set_default_type (e->symtree->n.sym, 0,
85 e->symtree->n.sym->ns) == SUCCESS
86 && gfc_numeric_ts (&e->symtree->n.sym->ts))
87 {
88 e->ts = e->symtree->n.sym->ts;
89 return SUCCESS;
90 }
91
92 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
93 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
94 &e->where);
95
96 return FAILURE;
97 }
98
99
100 /* Check that an expression is integer or real. */
101
102 static gfc_try
103 int_or_real_check (gfc_expr *e, int n)
104 {
105 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
106 {
107 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
108 "or REAL", gfc_current_intrinsic_arg[n]->name,
109 gfc_current_intrinsic, &e->where);
110 return FAILURE;
111 }
112
113 return SUCCESS;
114 }
115
116
117 /* Check that an expression is real or complex. */
118
119 static gfc_try
120 real_or_complex_check (gfc_expr *e, int n)
121 {
122 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
123 {
124 gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
125 "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
126 gfc_current_intrinsic, &e->where);
127 return FAILURE;
128 }
129
130 return SUCCESS;
131 }
132
133
134 /* Check that an expression is INTEGER or PROCEDURE. */
135
136 static gfc_try
137 int_or_proc_check (gfc_expr *e, int n)
138 {
139 if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
140 {
141 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
142 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
143 gfc_current_intrinsic, &e->where);
144 return FAILURE;
145 }
146
147 return SUCCESS;
148 }
149
150
151 /* Check that the expression is an optional constant integer
152 and that it specifies a valid kind for that type. */
153
154 static gfc_try
155 kind_check (gfc_expr *k, int n, bt type)
156 {
157 int kind;
158
159 if (k == NULL)
160 return SUCCESS;
161
162 if (type_check (k, n, BT_INTEGER) == FAILURE)
163 return FAILURE;
164
165 if (scalar_check (k, n) == FAILURE)
166 return FAILURE;
167
168 if (gfc_check_init_expr (k) != SUCCESS)
169 {
170 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
171 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
172 &k->where);
173 return FAILURE;
174 }
175
176 if (gfc_extract_int (k, &kind) != NULL
177 || gfc_validate_kind (type, kind, true) < 0)
178 {
179 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
180 &k->where);
181 return FAILURE;
182 }
183
184 return SUCCESS;
185 }
186
187
188 /* Make sure the expression is a double precision real. */
189
190 static gfc_try
191 double_check (gfc_expr *d, int n)
192 {
193 if (type_check (d, n, BT_REAL) == FAILURE)
194 return FAILURE;
195
196 if (d->ts.kind != gfc_default_double_kind)
197 {
198 gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
199 "precision", gfc_current_intrinsic_arg[n]->name,
200 gfc_current_intrinsic, &d->where);
201 return FAILURE;
202 }
203
204 return SUCCESS;
205 }
206
207
208 static gfc_try
209 coarray_check (gfc_expr *e, int n)
210 {
211 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
212 && CLASS_DATA (e)->attr.codimension
213 && CLASS_DATA (e)->as->corank)
214 {
215 gfc_add_class_array_ref (e);
216 return SUCCESS;
217 }
218
219 if (!gfc_is_coarray (e))
220 {
221 gfc_error ("Expected coarray variable as '%s' argument to the %s "
222 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
223 gfc_current_intrinsic, &e->where);
224 return FAILURE;
225 }
226
227 return SUCCESS;
228 }
229
230
231 /* Make sure the expression is a logical array. */
232
233 static gfc_try
234 logical_array_check (gfc_expr *array, int n)
235 {
236 if (array->ts.type != BT_LOGICAL || array->rank == 0)
237 {
238 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
239 "array", gfc_current_intrinsic_arg[n]->name,
240 gfc_current_intrinsic, &array->where);
241 return FAILURE;
242 }
243
244 return SUCCESS;
245 }
246
247
248 /* Make sure an expression is an array. */
249
250 static gfc_try
251 array_check (gfc_expr *e, int n)
252 {
253 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
254 && CLASS_DATA (e)->attr.dimension
255 && CLASS_DATA (e)->as->rank)
256 {
257 gfc_add_class_array_ref (e);
258 return SUCCESS;
259 }
260
261 if (e->rank != 0)
262 return SUCCESS;
263
264 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
265 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
266 &e->where);
267
268 return FAILURE;
269 }
270
271
272 /* If expr is a constant, then check to ensure that it is greater than
273 of equal to zero. */
274
275 static gfc_try
276 nonnegative_check (const char *arg, gfc_expr *expr)
277 {
278 int i;
279
280 if (expr->expr_type == EXPR_CONSTANT)
281 {
282 gfc_extract_int (expr, &i);
283 if (i < 0)
284 {
285 gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
286 return FAILURE;
287 }
288 }
289
290 return SUCCESS;
291 }
292
293
294 /* If expr2 is constant, then check that the value is less than
295 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
296
297 static gfc_try
298 less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
299 gfc_expr *expr2, bool or_equal)
300 {
301 int i2, i3;
302
303 if (expr2->expr_type == EXPR_CONSTANT)
304 {
305 gfc_extract_int (expr2, &i2);
306 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
307
308 /* For ISHFT[C], check that |shift| <= bit_size(i). */
309 if (arg2 == NULL)
310 {
311 if (i2 < 0)
312 i2 = -i2;
313
314 if (i2 > gfc_integer_kinds[i3].bit_size)
315 {
316 gfc_error ("The absolute value of SHIFT at %L must be less "
317 "than or equal to BIT_SIZE('%s')",
318 &expr2->where, arg1);
319 return FAILURE;
320 }
321 }
322
323 if (or_equal)
324 {
325 if (i2 > gfc_integer_kinds[i3].bit_size)
326 {
327 gfc_error ("'%s' at %L must be less than "
328 "or equal to BIT_SIZE('%s')",
329 arg2, &expr2->where, arg1);
330 return FAILURE;
331 }
332 }
333 else
334 {
335 if (i2 >= gfc_integer_kinds[i3].bit_size)
336 {
337 gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
338 arg2, &expr2->where, arg1);
339 return FAILURE;
340 }
341 }
342 }
343
344 return SUCCESS;
345 }
346
347
348 /* If expr is constant, then check that the value is less than or equal
349 to the bit_size of the kind k. */
350
351 static gfc_try
352 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
353 {
354 int i, val;
355
356 if (expr->expr_type != EXPR_CONSTANT)
357 return SUCCESS;
358
359 i = gfc_validate_kind (BT_INTEGER, k, false);
360 gfc_extract_int (expr, &val);
361
362 if (val > gfc_integer_kinds[i].bit_size)
363 {
364 gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
365 "INTEGER(KIND=%d)", arg, &expr->where, k);
366 return FAILURE;
367 }
368
369 return SUCCESS;
370 }
371
372
373 /* If expr2 and expr3 are constants, then check that the value is less than
374 or equal to bit_size(expr1). */
375
376 static gfc_try
377 less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
378 gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
379 {
380 int i2, i3;
381
382 if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
383 {
384 gfc_extract_int (expr2, &i2);
385 gfc_extract_int (expr3, &i3);
386 i2 += i3;
387 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
388 if (i2 > gfc_integer_kinds[i3].bit_size)
389 {
390 gfc_error ("'%s + %s' at %L must be less than or equal "
391 "to BIT_SIZE('%s')",
392 arg2, arg3, &expr2->where, arg1);
393 return FAILURE;
394 }
395 }
396
397 return SUCCESS;
398 }
399
400 /* Make sure two expressions have the same type. */
401
402 static gfc_try
403 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
404 {
405 if (gfc_compare_types (&e->ts, &f->ts))
406 return SUCCESS;
407
408 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
409 "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
410 gfc_current_intrinsic, &f->where,
411 gfc_current_intrinsic_arg[n]->name);
412
413 return FAILURE;
414 }
415
416
417 /* Make sure that an expression has a certain (nonzero) rank. */
418
419 static gfc_try
420 rank_check (gfc_expr *e, int n, int rank)
421 {
422 if (e->rank == rank)
423 return SUCCESS;
424
425 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
426 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
427 &e->where, rank);
428
429 return FAILURE;
430 }
431
432
433 /* Make sure a variable expression is not an optional dummy argument. */
434
435 static gfc_try
436 nonoptional_check (gfc_expr *e, int n)
437 {
438 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
439 {
440 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
441 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
442 &e->where);
443 }
444
445 /* TODO: Recursive check on nonoptional variables? */
446
447 return SUCCESS;
448 }
449
450
451 /* Check for ALLOCATABLE attribute. */
452
453 static gfc_try
454 allocatable_check (gfc_expr *e, int n)
455 {
456 symbol_attribute attr;
457
458 attr = gfc_variable_attr (e, NULL);
459 if (!attr.allocatable)
460 {
461 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
462 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
463 &e->where);
464 return FAILURE;
465 }
466
467 return SUCCESS;
468 }
469
470
471 /* Check that an expression has a particular kind. */
472
473 static gfc_try
474 kind_value_check (gfc_expr *e, int n, int k)
475 {
476 if (e->ts.kind == k)
477 return SUCCESS;
478
479 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
480 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
481 &e->where, k);
482
483 return FAILURE;
484 }
485
486
487 /* Make sure an expression is a variable. */
488
489 static gfc_try
490 variable_check (gfc_expr *e, int n, bool allow_proc)
491 {
492 if (e->expr_type == EXPR_VARIABLE
493 && e->symtree->n.sym->attr.intent == INTENT_IN
494 && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
495 || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
496 {
497 gfc_ref *ref;
498 bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
499 && CLASS_DATA (e->symtree->n.sym)
500 ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
501 : e->symtree->n.sym->attr.pointer;
502
503 for (ref = e->ref; ref; ref = ref->next)
504 {
505 if (pointer && ref->type == REF_COMPONENT)
506 break;
507 if (ref->type == REF_COMPONENT
508 && ((ref->u.c.component->ts.type == BT_CLASS
509 && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
510 || (ref->u.c.component->ts.type != BT_CLASS
511 && ref->u.c.component->attr.pointer)))
512 break;
513 }
514
515 if (!ref)
516 {
517 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
518 "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
519 gfc_current_intrinsic, &e->where);
520 return FAILURE;
521 }
522 }
523
524 if (e->expr_type == EXPR_VARIABLE
525 && e->symtree->n.sym->attr.flavor != FL_PARAMETER
526 && (allow_proc || !e->symtree->n.sym->attr.function))
527 return SUCCESS;
528
529 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
530 && e->symtree->n.sym == e->symtree->n.sym->result)
531 {
532 gfc_namespace *ns;
533 for (ns = gfc_current_ns; ns; ns = ns->parent)
534 if (ns->proc_name == e->symtree->n.sym)
535 return SUCCESS;
536 }
537
538 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
539 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
540
541 return FAILURE;
542 }
543
544
545 /* Check the common DIM parameter for correctness. */
546
547 static gfc_try
548 dim_check (gfc_expr *dim, int n, bool optional)
549 {
550 if (dim == NULL)
551 return SUCCESS;
552
553 if (type_check (dim, n, BT_INTEGER) == FAILURE)
554 return FAILURE;
555
556 if (scalar_check (dim, n) == FAILURE)
557 return FAILURE;
558
559 if (!optional && nonoptional_check (dim, n) == FAILURE)
560 return FAILURE;
561
562 return SUCCESS;
563 }
564
565
566 /* If a coarray DIM parameter is a constant, make sure that it is greater than
567 zero and less than or equal to the corank of the given array. */
568
569 static gfc_try
570 dim_corank_check (gfc_expr *dim, gfc_expr *array)
571 {
572 int corank;
573
574 gcc_assert (array->expr_type == EXPR_VARIABLE);
575
576 if (dim->expr_type != EXPR_CONSTANT)
577 return SUCCESS;
578
579 if (array->ts.type == BT_CLASS)
580 return SUCCESS;
581
582 corank = gfc_get_corank (array);
583
584 if (mpz_cmp_ui (dim->value.integer, 1) < 0
585 || mpz_cmp_ui (dim->value.integer, corank) > 0)
586 {
587 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
588 "codimension index", gfc_current_intrinsic, &dim->where);
589
590 return FAILURE;
591 }
592
593 return SUCCESS;
594 }
595
596
597 /* If a DIM parameter is a constant, make sure that it is greater than
598 zero and less than or equal to the rank of the given array. If
599 allow_assumed is zero then dim must be less than the rank of the array
600 for assumed size arrays. */
601
602 static gfc_try
603 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
604 {
605 gfc_array_ref *ar;
606 int rank;
607
608 if (dim == NULL)
609 return SUCCESS;
610
611 if (dim->expr_type != EXPR_CONSTANT)
612 return SUCCESS;
613
614 if (array->ts.type == BT_CLASS)
615 return SUCCESS;
616
617 if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
618 && array->value.function.isym->id == GFC_ISYM_SPREAD)
619 rank = array->rank + 1;
620 else
621 rank = array->rank;
622
623 /* Assumed-rank array. */
624 if (rank == -1)
625 rank = GFC_MAX_DIMENSIONS;
626
627 if (array->expr_type == EXPR_VARIABLE)
628 {
629 ar = gfc_find_array_ref (array);
630 if (ar->as->type == AS_ASSUMED_SIZE
631 && !allow_assumed
632 && ar->type != AR_ELEMENT
633 && ar->type != AR_SECTION)
634 rank--;
635 }
636
637 if (mpz_cmp_ui (dim->value.integer, 1) < 0
638 || mpz_cmp_ui (dim->value.integer, rank) > 0)
639 {
640 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
641 "dimension index", gfc_current_intrinsic, &dim->where);
642
643 return FAILURE;
644 }
645
646 return SUCCESS;
647 }
648
649
650 /* Compare the size of a along dimension ai with the size of b along
651 dimension bi, returning 0 if they are known not to be identical,
652 and 1 if they are identical, or if this cannot be determined. */
653
654 static int
655 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
656 {
657 mpz_t a_size, b_size;
658 int ret;
659
660 gcc_assert (a->rank > ai);
661 gcc_assert (b->rank > bi);
662
663 ret = 1;
664
665 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
666 {
667 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
668 {
669 if (mpz_cmp (a_size, b_size) != 0)
670 ret = 0;
671
672 mpz_clear (b_size);
673 }
674 mpz_clear (a_size);
675 }
676 return ret;
677 }
678
679 /* Calculate the length of a character variable, including substrings.
680 Strip away parentheses if necessary. Return -1 if no length could
681 be determined. */
682
683 static long
684 gfc_var_strlen (const gfc_expr *a)
685 {
686 gfc_ref *ra;
687
688 while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
689 a = a->value.op.op1;
690
691 for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
692 ;
693
694 if (ra)
695 {
696 long start_a, end_a;
697
698 if (ra->u.ss.start->expr_type == EXPR_CONSTANT
699 && ra->u.ss.end->expr_type == EXPR_CONSTANT)
700 {
701 start_a = mpz_get_si (ra->u.ss.start->value.integer);
702 end_a = mpz_get_si (ra->u.ss.end->value.integer);
703 return end_a - start_a + 1;
704 }
705 else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
706 return 1;
707 else
708 return -1;
709 }
710
711 if (a->ts.u.cl && a->ts.u.cl->length
712 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
713 return mpz_get_si (a->ts.u.cl->length->value.integer);
714 else if (a->expr_type == EXPR_CONSTANT
715 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
716 return a->value.character.length;
717 else
718 return -1;
719
720 }
721
722 /* Check whether two character expressions have the same length;
723 returns SUCCESS if they have or if the length cannot be determined,
724 otherwise return FAILURE and raise a gfc_error. */
725
726 gfc_try
727 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
728 {
729 long len_a, len_b;
730
731 len_a = gfc_var_strlen(a);
732 len_b = gfc_var_strlen(b);
733
734 if (len_a == -1 || len_b == -1 || len_a == len_b)
735 return SUCCESS;
736 else
737 {
738 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
739 len_a, len_b, name, &a->where);
740 return FAILURE;
741 }
742 }
743
744
745 /***** Check functions *****/
746
747 /* Check subroutine suitable for intrinsics taking a real argument and
748 a kind argument for the result. */
749
750 static gfc_try
751 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
752 {
753 if (type_check (a, 0, BT_REAL) == FAILURE)
754 return FAILURE;
755 if (kind_check (kind, 1, type) == FAILURE)
756 return FAILURE;
757
758 return SUCCESS;
759 }
760
761
762 /* Check subroutine suitable for ceiling, floor and nint. */
763
764 gfc_try
765 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
766 {
767 return check_a_kind (a, kind, BT_INTEGER);
768 }
769
770
771 /* Check subroutine suitable for aint, anint. */
772
773 gfc_try
774 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
775 {
776 return check_a_kind (a, kind, BT_REAL);
777 }
778
779
780 gfc_try
781 gfc_check_abs (gfc_expr *a)
782 {
783 if (numeric_check (a, 0) == FAILURE)
784 return FAILURE;
785
786 return SUCCESS;
787 }
788
789
790 gfc_try
791 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
792 {
793 if (type_check (a, 0, BT_INTEGER) == FAILURE)
794 return FAILURE;
795 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
796 return FAILURE;
797
798 return SUCCESS;
799 }
800
801
802 gfc_try
803 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
804 {
805 if (type_check (name, 0, BT_CHARACTER) == FAILURE
806 || scalar_check (name, 0) == FAILURE)
807 return FAILURE;
808 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
809 return FAILURE;
810
811 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
812 || scalar_check (mode, 1) == FAILURE)
813 return FAILURE;
814 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
815 return FAILURE;
816
817 return SUCCESS;
818 }
819
820
821 gfc_try
822 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
823 {
824 if (logical_array_check (mask, 0) == FAILURE)
825 return FAILURE;
826
827 if (dim_check (dim, 1, false) == FAILURE)
828 return FAILURE;
829
830 if (dim_rank_check (dim, mask, 0) == FAILURE)
831 return FAILURE;
832
833 return SUCCESS;
834 }
835
836
837 gfc_try
838 gfc_check_allocated (gfc_expr *array)
839 {
840 if (variable_check (array, 0, false) == FAILURE)
841 return FAILURE;
842 if (allocatable_check (array, 0) == FAILURE)
843 return FAILURE;
844
845 return SUCCESS;
846 }
847
848
849 /* Common check function where the first argument must be real or
850 integer and the second argument must be the same as the first. */
851
852 gfc_try
853 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
854 {
855 if (int_or_real_check (a, 0) == FAILURE)
856 return FAILURE;
857
858 if (a->ts.type != p->ts.type)
859 {
860 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
861 "have the same type", gfc_current_intrinsic_arg[0]->name,
862 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
863 &p->where);
864 return FAILURE;
865 }
866
867 if (a->ts.kind != p->ts.kind)
868 {
869 if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
870 &p->where) == FAILURE)
871 return FAILURE;
872 }
873
874 return SUCCESS;
875 }
876
877
878 gfc_try
879 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
880 {
881 if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
882 return FAILURE;
883
884 return SUCCESS;
885 }
886
887
888 gfc_try
889 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
890 {
891 symbol_attribute attr1, attr2;
892 int i;
893 gfc_try t;
894 locus *where;
895
896 where = &pointer->where;
897
898 if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
899 attr1 = gfc_expr_attr (pointer);
900 else if (pointer->expr_type == EXPR_NULL)
901 goto null_arg;
902 else
903 gcc_assert (0); /* Pointer must be a variable or a function. */
904
905 if (!attr1.pointer && !attr1.proc_pointer)
906 {
907 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
908 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
909 &pointer->where);
910 return FAILURE;
911 }
912
913 /* F2008, C1242. */
914 if (attr1.pointer && gfc_is_coindexed (pointer))
915 {
916 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
917 "coindexed", gfc_current_intrinsic_arg[0]->name,
918 gfc_current_intrinsic, &pointer->where);
919 return FAILURE;
920 }
921
922 /* Target argument is optional. */
923 if (target == NULL)
924 return SUCCESS;
925
926 where = &target->where;
927 if (target->expr_type == EXPR_NULL)
928 goto null_arg;
929
930 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
931 attr2 = gfc_expr_attr (target);
932 else
933 {
934 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
935 "or target VARIABLE or FUNCTION",
936 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
937 &target->where);
938 return FAILURE;
939 }
940
941 if (attr1.pointer && !attr2.pointer && !attr2.target)
942 {
943 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
944 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
945 gfc_current_intrinsic, &target->where);
946 return FAILURE;
947 }
948
949 /* F2008, C1242. */
950 if (attr1.pointer && gfc_is_coindexed (target))
951 {
952 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
953 "coindexed", gfc_current_intrinsic_arg[1]->name,
954 gfc_current_intrinsic, &target->where);
955 return FAILURE;
956 }
957
958 t = SUCCESS;
959 if (same_type_check (pointer, 0, target, 1) == FAILURE)
960 t = FAILURE;
961 if (rank_check (target, 0, pointer->rank) == FAILURE)
962 t = FAILURE;
963 if (target->rank > 0)
964 {
965 for (i = 0; i < target->rank; i++)
966 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
967 {
968 gfc_error ("Array section with a vector subscript at %L shall not "
969 "be the target of a pointer",
970 &target->where);
971 t = FAILURE;
972 break;
973 }
974 }
975 return t;
976
977 null_arg:
978
979 gfc_error ("NULL pointer at %L is not permitted as actual argument "
980 "of '%s' intrinsic function", where, gfc_current_intrinsic);
981 return FAILURE;
982
983 }
984
985
986 gfc_try
987 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
988 {
989 /* gfc_notify_std would be a waste of time as the return value
990 is seemingly used only for the generic resolution. The error
991 will be: Too many arguments. */
992 if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
993 return FAILURE;
994
995 return gfc_check_atan2 (y, x);
996 }
997
998
999 gfc_try
1000 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
1001 {
1002 if (type_check (y, 0, BT_REAL) == FAILURE)
1003 return FAILURE;
1004 if (same_type_check (y, 0, x, 1) == FAILURE)
1005 return FAILURE;
1006
1007 return SUCCESS;
1008 }
1009
1010
1011 static gfc_try
1012 gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
1013 {
1014 if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
1015 && !(atom->ts.type == BT_LOGICAL
1016 && atom->ts.kind == gfc_atomic_logical_kind))
1017 {
1018 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1019 "integer of ATOMIC_INT_KIND or a logical of "
1020 "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
1021 return FAILURE;
1022 }
1023
1024 if (!gfc_expr_attr (atom).codimension)
1025 {
1026 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1027 "coarray or coindexed", &atom->where, gfc_current_intrinsic);
1028 return FAILURE;
1029 }
1030
1031 if (atom->ts.type != value->ts.type)
1032 {
1033 gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
1034 "have the same type at %L", gfc_current_intrinsic,
1035 &value->where);
1036 return FAILURE;
1037 }
1038
1039 return SUCCESS;
1040 }
1041
1042
1043 gfc_try
1044 gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
1045 {
1046 if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
1047 return FAILURE;
1048
1049 if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
1050 {
1051 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1052 "definable", gfc_current_intrinsic, &atom->where);
1053 return FAILURE;
1054 }
1055
1056 return gfc_check_atomic (atom, value);
1057 }
1058
1059
1060 gfc_try
1061 gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
1062 {
1063 if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
1064 return FAILURE;
1065
1066 if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
1067 {
1068 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1069 "definable", gfc_current_intrinsic, &value->where);
1070 return FAILURE;
1071 }
1072
1073 return gfc_check_atomic (atom, value);
1074 }
1075
1076
1077 /* BESJN and BESYN functions. */
1078
1079 gfc_try
1080 gfc_check_besn (gfc_expr *n, gfc_expr *x)
1081 {
1082 if (type_check (n, 0, BT_INTEGER) == FAILURE)
1083 return FAILURE;
1084 if (n->expr_type == EXPR_CONSTANT)
1085 {
1086 int i;
1087 gfc_extract_int (n, &i);
1088 if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Negative argument "
1089 "N at %L", &n->where) == FAILURE)
1090 return FAILURE;
1091 }
1092
1093 if (type_check (x, 1, BT_REAL) == FAILURE)
1094 return FAILURE;
1095
1096 return SUCCESS;
1097 }
1098
1099
1100 /* Transformational version of the Bessel JN and YN functions. */
1101
1102 gfc_try
1103 gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1104 {
1105 if (type_check (n1, 0, BT_INTEGER) == FAILURE)
1106 return FAILURE;
1107 if (scalar_check (n1, 0) == FAILURE)
1108 return FAILURE;
1109 if (nonnegative_check("N1", n1) == FAILURE)
1110 return FAILURE;
1111
1112 if (type_check (n2, 1, BT_INTEGER) == FAILURE)
1113 return FAILURE;
1114 if (scalar_check (n2, 1) == FAILURE)
1115 return FAILURE;
1116 if (nonnegative_check("N2", n2) == FAILURE)
1117 return FAILURE;
1118
1119 if (type_check (x, 2, BT_REAL) == FAILURE)
1120 return FAILURE;
1121 if (scalar_check (x, 2) == FAILURE)
1122 return FAILURE;
1123
1124 return SUCCESS;
1125 }
1126
1127
1128 gfc_try
1129 gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1130 {
1131 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1132 return FAILURE;
1133
1134 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1135 return FAILURE;
1136
1137 return SUCCESS;
1138 }
1139
1140
1141 gfc_try
1142 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
1143 {
1144 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1145 return FAILURE;
1146
1147 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1148 return FAILURE;
1149
1150 if (nonnegative_check ("pos", pos) == FAILURE)
1151 return FAILURE;
1152
1153 if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
1154 return FAILURE;
1155
1156 return SUCCESS;
1157 }
1158
1159
1160 gfc_try
1161 gfc_check_char (gfc_expr *i, gfc_expr *kind)
1162 {
1163 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1164 return FAILURE;
1165 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
1166 return FAILURE;
1167
1168 return SUCCESS;
1169 }
1170
1171
1172 gfc_try
1173 gfc_check_chdir (gfc_expr *dir)
1174 {
1175 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1176 return FAILURE;
1177 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1178 return FAILURE;
1179
1180 return SUCCESS;
1181 }
1182
1183
1184 gfc_try
1185 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
1186 {
1187 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1188 return FAILURE;
1189 if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1190 return FAILURE;
1191
1192 if (status == NULL)
1193 return SUCCESS;
1194
1195 if (type_check (status, 1, BT_INTEGER) == FAILURE)
1196 return FAILURE;
1197 if (scalar_check (status, 1) == FAILURE)
1198 return FAILURE;
1199
1200 return SUCCESS;
1201 }
1202
1203
1204 gfc_try
1205 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
1206 {
1207 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1208 return FAILURE;
1209 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1210 return FAILURE;
1211
1212 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1213 return FAILURE;
1214 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1215 return FAILURE;
1216
1217 return SUCCESS;
1218 }
1219
1220
1221 gfc_try
1222 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
1223 {
1224 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1225 return FAILURE;
1226 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1227 return FAILURE;
1228
1229 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1230 return FAILURE;
1231 if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1232 return FAILURE;
1233
1234 if (status == NULL)
1235 return SUCCESS;
1236
1237 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1238 return FAILURE;
1239
1240 if (scalar_check (status, 2) == FAILURE)
1241 return FAILURE;
1242
1243 return SUCCESS;
1244 }
1245
1246
1247 gfc_try
1248 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
1249 {
1250 if (numeric_check (x, 0) == FAILURE)
1251 return FAILURE;
1252
1253 if (y != NULL)
1254 {
1255 if (numeric_check (y, 1) == FAILURE)
1256 return FAILURE;
1257
1258 if (x->ts.type == BT_COMPLEX)
1259 {
1260 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1261 "present if 'x' is COMPLEX",
1262 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1263 &y->where);
1264 return FAILURE;
1265 }
1266
1267 if (y->ts.type == BT_COMPLEX)
1268 {
1269 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1270 "of either REAL or INTEGER",
1271 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1272 &y->where);
1273 return FAILURE;
1274 }
1275
1276 }
1277
1278 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
1279 return FAILURE;
1280
1281 return SUCCESS;
1282 }
1283
1284
1285 gfc_try
1286 gfc_check_complex (gfc_expr *x, gfc_expr *y)
1287 {
1288 if (int_or_real_check (x, 0) == FAILURE)
1289 return FAILURE;
1290 if (scalar_check (x, 0) == FAILURE)
1291 return FAILURE;
1292
1293 if (int_or_real_check (y, 1) == FAILURE)
1294 return FAILURE;
1295 if (scalar_check (y, 1) == FAILURE)
1296 return FAILURE;
1297
1298 return SUCCESS;
1299 }
1300
1301
1302 gfc_try
1303 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1304 {
1305 if (logical_array_check (mask, 0) == FAILURE)
1306 return FAILURE;
1307 if (dim_check (dim, 1, false) == FAILURE)
1308 return FAILURE;
1309 if (dim_rank_check (dim, mask, 0) == FAILURE)
1310 return FAILURE;
1311 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1312 return FAILURE;
1313 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
1314 "with KIND argument at %L",
1315 gfc_current_intrinsic, &kind->where) == FAILURE)
1316 return FAILURE;
1317
1318 return SUCCESS;
1319 }
1320
1321
1322 gfc_try
1323 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
1324 {
1325 if (array_check (array, 0) == FAILURE)
1326 return FAILURE;
1327
1328 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1329 return FAILURE;
1330
1331 if (dim_check (dim, 2, true) == FAILURE)
1332 return FAILURE;
1333
1334 if (dim_rank_check (dim, array, false) == FAILURE)
1335 return FAILURE;
1336
1337 if (array->rank == 1 || shift->rank == 0)
1338 {
1339 if (scalar_check (shift, 1) == FAILURE)
1340 return FAILURE;
1341 }
1342 else if (shift->rank == array->rank - 1)
1343 {
1344 int d;
1345 if (!dim)
1346 d = 1;
1347 else if (dim->expr_type == EXPR_CONSTANT)
1348 gfc_extract_int (dim, &d);
1349 else
1350 d = -1;
1351
1352 if (d > 0)
1353 {
1354 int i, j;
1355 for (i = 0, j = 0; i < array->rank; i++)
1356 if (i != d - 1)
1357 {
1358 if (!identical_dimen_shape (array, i, shift, j))
1359 {
1360 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1361 "invalid shape in dimension %d (%ld/%ld)",
1362 gfc_current_intrinsic_arg[1]->name,
1363 gfc_current_intrinsic, &shift->where, i + 1,
1364 mpz_get_si (array->shape[i]),
1365 mpz_get_si (shift->shape[j]));
1366 return FAILURE;
1367 }
1368
1369 j += 1;
1370 }
1371 }
1372 }
1373 else
1374 {
1375 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1376 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1377 gfc_current_intrinsic, &shift->where, array->rank - 1);
1378 return FAILURE;
1379 }
1380
1381 return SUCCESS;
1382 }
1383
1384
1385 gfc_try
1386 gfc_check_ctime (gfc_expr *time)
1387 {
1388 if (scalar_check (time, 0) == FAILURE)
1389 return FAILURE;
1390
1391 if (type_check (time, 0, BT_INTEGER) == FAILURE)
1392 return FAILURE;
1393
1394 return SUCCESS;
1395 }
1396
1397
1398 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
1399 {
1400 if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
1401 return FAILURE;
1402
1403 return SUCCESS;
1404 }
1405
1406 gfc_try
1407 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
1408 {
1409 if (numeric_check (x, 0) == FAILURE)
1410 return FAILURE;
1411
1412 if (y != NULL)
1413 {
1414 if (numeric_check (y, 1) == FAILURE)
1415 return FAILURE;
1416
1417 if (x->ts.type == BT_COMPLEX)
1418 {
1419 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1420 "present if 'x' is COMPLEX",
1421 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1422 &y->where);
1423 return FAILURE;
1424 }
1425
1426 if (y->ts.type == BT_COMPLEX)
1427 {
1428 gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1429 "of either REAL or INTEGER",
1430 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1431 &y->where);
1432 return FAILURE;
1433 }
1434 }
1435
1436 return SUCCESS;
1437 }
1438
1439
1440 gfc_try
1441 gfc_check_dble (gfc_expr *x)
1442 {
1443 if (numeric_check (x, 0) == FAILURE)
1444 return FAILURE;
1445
1446 return SUCCESS;
1447 }
1448
1449
1450 gfc_try
1451 gfc_check_digits (gfc_expr *x)
1452 {
1453 if (int_or_real_check (x, 0) == FAILURE)
1454 return FAILURE;
1455
1456 return SUCCESS;
1457 }
1458
1459
1460 gfc_try
1461 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1462 {
1463 switch (vector_a->ts.type)
1464 {
1465 case BT_LOGICAL:
1466 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1467 return FAILURE;
1468 break;
1469
1470 case BT_INTEGER:
1471 case BT_REAL:
1472 case BT_COMPLEX:
1473 if (numeric_check (vector_b, 1) == FAILURE)
1474 return FAILURE;
1475 break;
1476
1477 default:
1478 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1479 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
1480 gfc_current_intrinsic, &vector_a->where);
1481 return FAILURE;
1482 }
1483
1484 if (rank_check (vector_a, 0, 1) == FAILURE)
1485 return FAILURE;
1486
1487 if (rank_check (vector_b, 1, 1) == FAILURE)
1488 return FAILURE;
1489
1490 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1491 {
1492 gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1493 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
1494 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
1495 return FAILURE;
1496 }
1497
1498 return SUCCESS;
1499 }
1500
1501
1502 gfc_try
1503 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1504 {
1505 if (type_check (x, 0, BT_REAL) == FAILURE
1506 || type_check (y, 1, BT_REAL) == FAILURE)
1507 return FAILURE;
1508
1509 if (x->ts.kind != gfc_default_real_kind)
1510 {
1511 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1512 "real", gfc_current_intrinsic_arg[0]->name,
1513 gfc_current_intrinsic, &x->where);
1514 return FAILURE;
1515 }
1516
1517 if (y->ts.kind != gfc_default_real_kind)
1518 {
1519 gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1520 "real", gfc_current_intrinsic_arg[1]->name,
1521 gfc_current_intrinsic, &y->where);
1522 return FAILURE;
1523 }
1524
1525 return SUCCESS;
1526 }
1527
1528
1529 gfc_try
1530 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
1531 {
1532 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1533 return FAILURE;
1534
1535 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1536 return FAILURE;
1537
1538 if (i->is_boz && j->is_boz)
1539 {
1540 gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1541 "constants", &i->where, &j->where);
1542 return FAILURE;
1543 }
1544
1545 if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE)
1546 return FAILURE;
1547
1548 if (type_check (shift, 2, BT_INTEGER) == FAILURE)
1549 return FAILURE;
1550
1551 if (nonnegative_check ("SHIFT", shift) == FAILURE)
1552 return FAILURE;
1553
1554 if (i->is_boz)
1555 {
1556 if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE)
1557 return FAILURE;
1558 i->ts.kind = j->ts.kind;
1559 }
1560 else
1561 {
1562 if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
1563 return FAILURE;
1564 j->ts.kind = i->ts.kind;
1565 }
1566
1567 return SUCCESS;
1568 }
1569
1570
1571 gfc_try
1572 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1573 gfc_expr *dim)
1574 {
1575 if (array_check (array, 0) == FAILURE)
1576 return FAILURE;
1577
1578 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1579 return FAILURE;
1580
1581 if (dim_check (dim, 3, true) == FAILURE)
1582 return FAILURE;
1583
1584 if (dim_rank_check (dim, array, false) == FAILURE)
1585 return FAILURE;
1586
1587 if (array->rank == 1 || shift->rank == 0)
1588 {
1589 if (scalar_check (shift, 1) == FAILURE)
1590 return FAILURE;
1591 }
1592 else if (shift->rank == array->rank - 1)
1593 {
1594 int d;
1595 if (!dim)
1596 d = 1;
1597 else if (dim->expr_type == EXPR_CONSTANT)
1598 gfc_extract_int (dim, &d);
1599 else
1600 d = -1;
1601
1602 if (d > 0)
1603 {
1604 int i, j;
1605 for (i = 0, j = 0; i < array->rank; i++)
1606 if (i != d - 1)
1607 {
1608 if (!identical_dimen_shape (array, i, shift, j))
1609 {
1610 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1611 "invalid shape in dimension %d (%ld/%ld)",
1612 gfc_current_intrinsic_arg[1]->name,
1613 gfc_current_intrinsic, &shift->where, i + 1,
1614 mpz_get_si (array->shape[i]),
1615 mpz_get_si (shift->shape[j]));
1616 return FAILURE;
1617 }
1618
1619 j += 1;
1620 }
1621 }
1622 }
1623 else
1624 {
1625 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1626 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1627 gfc_current_intrinsic, &shift->where, array->rank - 1);
1628 return FAILURE;
1629 }
1630
1631 if (boundary != NULL)
1632 {
1633 if (same_type_check (array, 0, boundary, 2) == FAILURE)
1634 return FAILURE;
1635
1636 if (array->rank == 1 || boundary->rank == 0)
1637 {
1638 if (scalar_check (boundary, 2) == FAILURE)
1639 return FAILURE;
1640 }
1641 else if (boundary->rank == array->rank - 1)
1642 {
1643 if (gfc_check_conformance (shift, boundary,
1644 "arguments '%s' and '%s' for "
1645 "intrinsic %s",
1646 gfc_current_intrinsic_arg[1]->name,
1647 gfc_current_intrinsic_arg[2]->name,
1648 gfc_current_intrinsic ) == FAILURE)
1649 return FAILURE;
1650 }
1651 else
1652 {
1653 gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1654 "rank %d or be a scalar",
1655 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1656 &shift->where, array->rank - 1);
1657 return FAILURE;
1658 }
1659 }
1660
1661 return SUCCESS;
1662 }
1663
1664 gfc_try
1665 gfc_check_float (gfc_expr *a)
1666 {
1667 if (type_check (a, 0, BT_INTEGER) == FAILURE)
1668 return FAILURE;
1669
1670 if ((a->ts.kind != gfc_default_integer_kind)
1671 && gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
1672 "kind argument to %s intrinsic at %L",
1673 gfc_current_intrinsic, &a->where) == FAILURE )
1674 return FAILURE;
1675
1676 return SUCCESS;
1677 }
1678
1679 /* A single complex argument. */
1680
1681 gfc_try
1682 gfc_check_fn_c (gfc_expr *a)
1683 {
1684 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1685 return FAILURE;
1686
1687 return SUCCESS;
1688 }
1689
1690 /* A single real argument. */
1691
1692 gfc_try
1693 gfc_check_fn_r (gfc_expr *a)
1694 {
1695 if (type_check (a, 0, BT_REAL) == FAILURE)
1696 return FAILURE;
1697
1698 return SUCCESS;
1699 }
1700
1701 /* A single double argument. */
1702
1703 gfc_try
1704 gfc_check_fn_d (gfc_expr *a)
1705 {
1706 if (double_check (a, 0) == FAILURE)
1707 return FAILURE;
1708
1709 return SUCCESS;
1710 }
1711
1712 /* A single real or complex argument. */
1713
1714 gfc_try
1715 gfc_check_fn_rc (gfc_expr *a)
1716 {
1717 if (real_or_complex_check (a, 0) == FAILURE)
1718 return FAILURE;
1719
1720 return SUCCESS;
1721 }
1722
1723
1724 gfc_try
1725 gfc_check_fn_rc2008 (gfc_expr *a)
1726 {
1727 if (real_or_complex_check (a, 0) == FAILURE)
1728 return FAILURE;
1729
1730 if (a->ts.type == BT_COMPLEX
1731 && gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' "
1732 "argument of '%s' intrinsic at %L",
1733 gfc_current_intrinsic_arg[0]->name,
1734 gfc_current_intrinsic, &a->where) == FAILURE)
1735 return FAILURE;
1736
1737 return SUCCESS;
1738 }
1739
1740
1741 gfc_try
1742 gfc_check_fnum (gfc_expr *unit)
1743 {
1744 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1745 return FAILURE;
1746
1747 if (scalar_check (unit, 0) == FAILURE)
1748 return FAILURE;
1749
1750 return SUCCESS;
1751 }
1752
1753
1754 gfc_try
1755 gfc_check_huge (gfc_expr *x)
1756 {
1757 if (int_or_real_check (x, 0) == FAILURE)
1758 return FAILURE;
1759
1760 return SUCCESS;
1761 }
1762
1763
1764 gfc_try
1765 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1766 {
1767 if (type_check (x, 0, BT_REAL) == FAILURE)
1768 return FAILURE;
1769 if (same_type_check (x, 0, y, 1) == FAILURE)
1770 return FAILURE;
1771
1772 return SUCCESS;
1773 }
1774
1775
1776 /* Check that the single argument is an integer. */
1777
1778 gfc_try
1779 gfc_check_i (gfc_expr *i)
1780 {
1781 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1782 return FAILURE;
1783
1784 return SUCCESS;
1785 }
1786
1787
1788 gfc_try
1789 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1790 {
1791 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1792 return FAILURE;
1793
1794 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1795 return FAILURE;
1796
1797 if (i->ts.kind != j->ts.kind)
1798 {
1799 if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
1800 &i->where) == FAILURE)
1801 return FAILURE;
1802 }
1803
1804 return SUCCESS;
1805 }
1806
1807
1808 gfc_try
1809 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1810 {
1811 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1812 return FAILURE;
1813
1814 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1815 return FAILURE;
1816
1817 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1818 return FAILURE;
1819
1820 if (nonnegative_check ("pos", pos) == FAILURE)
1821 return FAILURE;
1822
1823 if (nonnegative_check ("len", len) == FAILURE)
1824 return FAILURE;
1825
1826 if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
1827 return FAILURE;
1828
1829 return SUCCESS;
1830 }
1831
1832
1833 gfc_try
1834 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1835 {
1836 int i;
1837
1838 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1839 return FAILURE;
1840
1841 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1842 return FAILURE;
1843
1844 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
1845 "with KIND argument at %L",
1846 gfc_current_intrinsic, &kind->where) == FAILURE)
1847 return FAILURE;
1848
1849 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1850 {
1851 gfc_expr *start;
1852 gfc_expr *end;
1853 gfc_ref *ref;
1854
1855 /* Substring references don't have the charlength set. */
1856 ref = c->ref;
1857 while (ref && ref->type != REF_SUBSTRING)
1858 ref = ref->next;
1859
1860 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1861
1862 if (!ref)
1863 {
1864 /* Check that the argument is length one. Non-constant lengths
1865 can't be checked here, so assume they are ok. */
1866 if (c->ts.u.cl && c->ts.u.cl->length)
1867 {
1868 /* If we already have a length for this expression then use it. */
1869 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1870 return SUCCESS;
1871 i = mpz_get_si (c->ts.u.cl->length->value.integer);
1872 }
1873 else
1874 return SUCCESS;
1875 }
1876 else
1877 {
1878 start = ref->u.ss.start;
1879 end = ref->u.ss.end;
1880
1881 gcc_assert (start);
1882 if (end == NULL || end->expr_type != EXPR_CONSTANT
1883 || start->expr_type != EXPR_CONSTANT)
1884 return SUCCESS;
1885
1886 i = mpz_get_si (end->value.integer) + 1
1887 - mpz_get_si (start->value.integer);
1888 }
1889 }
1890 else
1891 return SUCCESS;
1892
1893 if (i != 1)
1894 {
1895 gfc_error ("Argument of %s at %L must be of length one",
1896 gfc_current_intrinsic, &c->where);
1897 return FAILURE;
1898 }
1899
1900 return SUCCESS;
1901 }
1902
1903
1904 gfc_try
1905 gfc_check_idnint (gfc_expr *a)
1906 {
1907 if (double_check (a, 0) == FAILURE)
1908 return FAILURE;
1909
1910 return SUCCESS;
1911 }
1912
1913
1914 gfc_try
1915 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1916 {
1917 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1918 return FAILURE;
1919
1920 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1921 return FAILURE;
1922
1923 if (i->ts.kind != j->ts.kind)
1924 {
1925 if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
1926 &i->where) == FAILURE)
1927 return FAILURE;
1928 }
1929
1930 return SUCCESS;
1931 }
1932
1933
1934 gfc_try
1935 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1936 gfc_expr *kind)
1937 {
1938 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1939 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1940 return FAILURE;
1941
1942 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1943 return FAILURE;
1944
1945 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1946 return FAILURE;
1947 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
1948 "with KIND argument at %L",
1949 gfc_current_intrinsic, &kind->where) == FAILURE)
1950 return FAILURE;
1951
1952 if (string->ts.kind != substring->ts.kind)
1953 {
1954 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1955 "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
1956 gfc_current_intrinsic, &substring->where,
1957 gfc_current_intrinsic_arg[0]->name);
1958 return FAILURE;
1959 }
1960
1961 return SUCCESS;
1962 }
1963
1964
1965 gfc_try
1966 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1967 {
1968 if (numeric_check (x, 0) == FAILURE)
1969 return FAILURE;
1970
1971 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1972 return FAILURE;
1973
1974 return SUCCESS;
1975 }
1976
1977
1978 gfc_try
1979 gfc_check_intconv (gfc_expr *x)
1980 {
1981 if (numeric_check (x, 0) == FAILURE)
1982 return FAILURE;
1983
1984 return SUCCESS;
1985 }
1986
1987
1988 gfc_try
1989 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1990 {
1991 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1992 return FAILURE;
1993
1994 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1995 return FAILURE;
1996
1997 if (i->ts.kind != j->ts.kind)
1998 {
1999 if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
2000 &i->where) == FAILURE)
2001 return FAILURE;
2002 }
2003
2004 return SUCCESS;
2005 }
2006
2007
2008 gfc_try
2009 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
2010 {
2011 if (type_check (i, 0, BT_INTEGER) == FAILURE
2012 || type_check (shift, 1, BT_INTEGER) == FAILURE)
2013 return FAILURE;
2014
2015 if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
2016 return FAILURE;
2017
2018 return SUCCESS;
2019 }
2020
2021
2022 gfc_try
2023 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
2024 {
2025 if (type_check (i, 0, BT_INTEGER) == FAILURE
2026 || type_check (shift, 1, BT_INTEGER) == FAILURE)
2027 return FAILURE;
2028
2029 if (size != NULL)
2030 {
2031 int i2, i3;
2032
2033 if (type_check (size, 2, BT_INTEGER) == FAILURE)
2034 return FAILURE;
2035
2036 if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE)
2037 return FAILURE;
2038
2039 if (size->expr_type == EXPR_CONSTANT)
2040 {
2041 gfc_extract_int (size, &i3);
2042 if (i3 <= 0)
2043 {
2044 gfc_error ("SIZE at %L must be positive", &size->where);
2045 return FAILURE;
2046 }
2047
2048 if (shift->expr_type == EXPR_CONSTANT)
2049 {
2050 gfc_extract_int (shift, &i2);
2051 if (i2 < 0)
2052 i2 = -i2;
2053
2054 if (i2 > i3)
2055 {
2056 gfc_error ("The absolute value of SHIFT at %L must be less "
2057 "than or equal to SIZE at %L", &shift->where,
2058 &size->where);
2059 return FAILURE;
2060 }
2061 }
2062 }
2063 }
2064 else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
2065 return FAILURE;
2066
2067 return SUCCESS;
2068 }
2069
2070
2071 gfc_try
2072 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
2073 {
2074 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2075 return FAILURE;
2076
2077 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2078 return FAILURE;
2079
2080 return SUCCESS;
2081 }
2082
2083
2084 gfc_try
2085 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
2086 {
2087 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2088 return FAILURE;
2089
2090 if (scalar_check (pid, 0) == FAILURE)
2091 return FAILURE;
2092
2093 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2094 return FAILURE;
2095
2096 if (scalar_check (sig, 1) == FAILURE)
2097 return FAILURE;
2098
2099 if (status == NULL)
2100 return SUCCESS;
2101
2102 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2103 return FAILURE;
2104
2105 if (scalar_check (status, 2) == FAILURE)
2106 return FAILURE;
2107
2108 return SUCCESS;
2109 }
2110
2111
2112 gfc_try
2113 gfc_check_kind (gfc_expr *x)
2114 {
2115 if (x->ts.type == BT_DERIVED)
2116 {
2117 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2118 "non-derived type", gfc_current_intrinsic_arg[0]->name,
2119 gfc_current_intrinsic, &x->where);
2120 return FAILURE;
2121 }
2122
2123 return SUCCESS;
2124 }
2125
2126
2127 gfc_try
2128 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2129 {
2130 if (array_check (array, 0) == FAILURE)
2131 return FAILURE;
2132
2133 if (dim_check (dim, 1, false) == FAILURE)
2134 return FAILURE;
2135
2136 if (dim_rank_check (dim, array, 1) == FAILURE)
2137 return FAILURE;
2138
2139 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2140 return FAILURE;
2141 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
2142 "with KIND argument at %L",
2143 gfc_current_intrinsic, &kind->where) == FAILURE)
2144 return FAILURE;
2145
2146 return SUCCESS;
2147 }
2148
2149
2150 gfc_try
2151 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
2152 {
2153 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2154 {
2155 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2156 return FAILURE;
2157 }
2158
2159 if (coarray_check (coarray, 0) == FAILURE)
2160 return FAILURE;
2161
2162 if (dim != NULL)
2163 {
2164 if (dim_check (dim, 1, false) == FAILURE)
2165 return FAILURE;
2166
2167 if (dim_corank_check (dim, coarray) == FAILURE)
2168 return FAILURE;
2169 }
2170
2171 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2172 return FAILURE;
2173
2174 return SUCCESS;
2175 }
2176
2177
2178 gfc_try
2179 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
2180 {
2181 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
2182 return FAILURE;
2183
2184 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2185 return FAILURE;
2186 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
2187 "with KIND argument at %L",
2188 gfc_current_intrinsic, &kind->where) == FAILURE)
2189 return FAILURE;
2190
2191 return SUCCESS;
2192 }
2193
2194
2195 gfc_try
2196 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
2197 {
2198 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2199 return FAILURE;
2200 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
2201 return FAILURE;
2202
2203 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
2204 return FAILURE;
2205 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
2206 return FAILURE;
2207
2208 return SUCCESS;
2209 }
2210
2211
2212 gfc_try
2213 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
2214 {
2215 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2216 return FAILURE;
2217 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2218 return FAILURE;
2219
2220 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2221 return FAILURE;
2222 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2223 return FAILURE;
2224
2225 return SUCCESS;
2226 }
2227
2228
2229 gfc_try
2230 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2231 {
2232 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2233 return FAILURE;
2234 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2235 return FAILURE;
2236
2237 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2238 return FAILURE;
2239 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
2240 return FAILURE;
2241
2242 if (status == NULL)
2243 return SUCCESS;
2244
2245 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2246 return FAILURE;
2247
2248 if (scalar_check (status, 2) == FAILURE)
2249 return FAILURE;
2250
2251 return SUCCESS;
2252 }
2253
2254
2255 gfc_try
2256 gfc_check_loc (gfc_expr *expr)
2257 {
2258 return variable_check (expr, 0, true);
2259 }
2260
2261
2262 gfc_try
2263 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
2264 {
2265 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2266 return FAILURE;
2267 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2268 return FAILURE;
2269
2270 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2271 return FAILURE;
2272 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2273 return FAILURE;
2274
2275 return SUCCESS;
2276 }
2277
2278
2279 gfc_try
2280 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2281 {
2282 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2283 return FAILURE;
2284 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2285 return FAILURE;
2286
2287 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2288 return FAILURE;
2289 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2290 return FAILURE;
2291
2292 if (status == NULL)
2293 return SUCCESS;
2294
2295 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2296 return FAILURE;
2297
2298 if (scalar_check (status, 2) == FAILURE)
2299 return FAILURE;
2300
2301 return SUCCESS;
2302 }
2303
2304
2305 gfc_try
2306 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
2307 {
2308 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
2309 return FAILURE;
2310 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
2311 return FAILURE;
2312
2313 return SUCCESS;
2314 }
2315
2316
2317 /* Min/max family. */
2318
2319 static gfc_try
2320 min_max_args (gfc_actual_arglist *arg)
2321 {
2322 if (arg == NULL || arg->next == NULL)
2323 {
2324 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2325 gfc_current_intrinsic, gfc_current_intrinsic_where);
2326 return FAILURE;
2327 }
2328
2329 return SUCCESS;
2330 }
2331
2332
2333 static gfc_try
2334 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
2335 {
2336 gfc_actual_arglist *arg, *tmp;
2337
2338 gfc_expr *x;
2339 int m, n;
2340
2341 if (min_max_args (arglist) == FAILURE)
2342 return FAILURE;
2343
2344 for (arg = arglist, n=1; arg; arg = arg->next, n++)
2345 {
2346 x = arg->expr;
2347 if (x->ts.type != type || x->ts.kind != kind)
2348 {
2349 if (x->ts.type == type)
2350 {
2351 if (gfc_notify_std (GFC_STD_GNU, "Different type "
2352 "kinds at %L", &x->where) == FAILURE)
2353 return FAILURE;
2354 }
2355 else
2356 {
2357 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2358 "%s(%d)", n, gfc_current_intrinsic, &x->where,
2359 gfc_basic_typename (type), kind);
2360 return FAILURE;
2361 }
2362 }
2363
2364 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
2365 if (gfc_check_conformance (tmp->expr, x,
2366 "arguments 'a%d' and 'a%d' for "
2367 "intrinsic '%s'", m, n,
2368 gfc_current_intrinsic) == FAILURE)
2369 return FAILURE;
2370 }
2371
2372 return SUCCESS;
2373 }
2374
2375
2376 gfc_try
2377 gfc_check_min_max (gfc_actual_arglist *arg)
2378 {
2379 gfc_expr *x;
2380
2381 if (min_max_args (arg) == FAILURE)
2382 return FAILURE;
2383
2384 x = arg->expr;
2385
2386 if (x->ts.type == BT_CHARACTER)
2387 {
2388 if (gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
2389 "with CHARACTER argument at %L",
2390 gfc_current_intrinsic, &x->where) == FAILURE)
2391 return FAILURE;
2392 }
2393 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
2394 {
2395 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2396 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
2397 return FAILURE;
2398 }
2399
2400 return check_rest (x->ts.type, x->ts.kind, arg);
2401 }
2402
2403
2404 gfc_try
2405 gfc_check_min_max_integer (gfc_actual_arglist *arg)
2406 {
2407 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
2408 }
2409
2410
2411 gfc_try
2412 gfc_check_min_max_real (gfc_actual_arglist *arg)
2413 {
2414 return check_rest (BT_REAL, gfc_default_real_kind, arg);
2415 }
2416
2417
2418 gfc_try
2419 gfc_check_min_max_double (gfc_actual_arglist *arg)
2420 {
2421 return check_rest (BT_REAL, gfc_default_double_kind, arg);
2422 }
2423
2424
2425 /* End of min/max family. */
2426
2427 gfc_try
2428 gfc_check_malloc (gfc_expr *size)
2429 {
2430 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2431 return FAILURE;
2432
2433 if (scalar_check (size, 0) == FAILURE)
2434 return FAILURE;
2435
2436 return SUCCESS;
2437 }
2438
2439
2440 gfc_try
2441 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
2442 {
2443 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
2444 {
2445 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2446 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2447 gfc_current_intrinsic, &matrix_a->where);
2448 return FAILURE;
2449 }
2450
2451 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2452 {
2453 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2454 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
2455 gfc_current_intrinsic, &matrix_b->where);
2456 return FAILURE;
2457 }
2458
2459 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2460 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2461 {
2462 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2463 gfc_current_intrinsic, &matrix_a->where,
2464 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2465 return FAILURE;
2466 }
2467
2468 switch (matrix_a->rank)
2469 {
2470 case 1:
2471 if (rank_check (matrix_b, 1, 2) == FAILURE)
2472 return FAILURE;
2473 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2474 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2475 {
2476 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2477 "and '%s' at %L for intrinsic matmul",
2478 gfc_current_intrinsic_arg[0]->name,
2479 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2480 return FAILURE;
2481 }
2482 break;
2483
2484 case 2:
2485 if (matrix_b->rank != 2)
2486 {
2487 if (rank_check (matrix_b, 1, 1) == FAILURE)
2488 return FAILURE;
2489 }
2490 /* matrix_b has rank 1 or 2 here. Common check for the cases
2491 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2492 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2493 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2494 {
2495 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2496 "dimension 1 for argument '%s' at %L for intrinsic "
2497 "matmul", gfc_current_intrinsic_arg[0]->name,
2498 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2499 return FAILURE;
2500 }
2501 break;
2502
2503 default:
2504 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2505 "1 or 2", gfc_current_intrinsic_arg[0]->name,
2506 gfc_current_intrinsic, &matrix_a->where);
2507 return FAILURE;
2508 }
2509
2510 return SUCCESS;
2511 }
2512
2513
2514 /* Whoever came up with this interface was probably on something.
2515 The possibilities for the occupation of the second and third
2516 parameters are:
2517
2518 Arg #2 Arg #3
2519 NULL NULL
2520 DIM NULL
2521 MASK NULL
2522 NULL MASK minloc(array, mask=m)
2523 DIM MASK
2524
2525 I.e. in the case of minloc(array,mask), mask will be in the second
2526 position of the argument list and we'll have to fix that up. */
2527
2528 gfc_try
2529 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2530 {
2531 gfc_expr *a, *m, *d;
2532
2533 a = ap->expr;
2534 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
2535 return FAILURE;
2536
2537 d = ap->next->expr;
2538 m = ap->next->next->expr;
2539
2540 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2541 && ap->next->name == NULL)
2542 {
2543 m = d;
2544 d = NULL;
2545 ap->next->expr = NULL;
2546 ap->next->next->expr = m;
2547 }
2548
2549 if (dim_check (d, 1, false) == FAILURE)
2550 return FAILURE;
2551
2552 if (dim_rank_check (d, a, 0) == FAILURE)
2553 return FAILURE;
2554
2555 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2556 return FAILURE;
2557
2558 if (m != NULL
2559 && gfc_check_conformance (a, m,
2560 "arguments '%s' and '%s' for intrinsic %s",
2561 gfc_current_intrinsic_arg[0]->name,
2562 gfc_current_intrinsic_arg[2]->name,
2563 gfc_current_intrinsic ) == FAILURE)
2564 return FAILURE;
2565
2566 return SUCCESS;
2567 }
2568
2569
2570 /* Similar to minloc/maxloc, the argument list might need to be
2571 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2572 difference is that MINLOC/MAXLOC take an additional KIND argument.
2573 The possibilities are:
2574
2575 Arg #2 Arg #3
2576 NULL NULL
2577 DIM NULL
2578 MASK NULL
2579 NULL MASK minval(array, mask=m)
2580 DIM MASK
2581
2582 I.e. in the case of minval(array,mask), mask will be in the second
2583 position of the argument list and we'll have to fix that up. */
2584
2585 static gfc_try
2586 check_reduction (gfc_actual_arglist *ap)
2587 {
2588 gfc_expr *a, *m, *d;
2589
2590 a = ap->expr;
2591 d = ap->next->expr;
2592 m = ap->next->next->expr;
2593
2594 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2595 && ap->next->name == NULL)
2596 {
2597 m = d;
2598 d = NULL;
2599 ap->next->expr = NULL;
2600 ap->next->next->expr = m;
2601 }
2602
2603 if (dim_check (d, 1, false) == FAILURE)
2604 return FAILURE;
2605
2606 if (dim_rank_check (d, a, 0) == FAILURE)
2607 return FAILURE;
2608
2609 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2610 return FAILURE;
2611
2612 if (m != NULL
2613 && gfc_check_conformance (a, m,
2614 "arguments '%s' and '%s' for intrinsic %s",
2615 gfc_current_intrinsic_arg[0]->name,
2616 gfc_current_intrinsic_arg[2]->name,
2617 gfc_current_intrinsic) == FAILURE)
2618 return FAILURE;
2619
2620 return SUCCESS;
2621 }
2622
2623
2624 gfc_try
2625 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2626 {
2627 if (int_or_real_check (ap->expr, 0) == FAILURE
2628 || array_check (ap->expr, 0) == FAILURE)
2629 return FAILURE;
2630
2631 return check_reduction (ap);
2632 }
2633
2634
2635 gfc_try
2636 gfc_check_product_sum (gfc_actual_arglist *ap)
2637 {
2638 if (numeric_check (ap->expr, 0) == FAILURE
2639 || array_check (ap->expr, 0) == FAILURE)
2640 return FAILURE;
2641
2642 return check_reduction (ap);
2643 }
2644
2645
2646 /* For IANY, IALL and IPARITY. */
2647
2648 gfc_try
2649 gfc_check_mask (gfc_expr *i, gfc_expr *kind)
2650 {
2651 int k;
2652
2653 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2654 return FAILURE;
2655
2656 if (nonnegative_check ("I", i) == FAILURE)
2657 return FAILURE;
2658
2659 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2660 return FAILURE;
2661
2662 if (kind)
2663 gfc_extract_int (kind, &k);
2664 else
2665 k = gfc_default_integer_kind;
2666
2667 if (less_than_bitsizekind ("I", i, k) == FAILURE)
2668 return FAILURE;
2669
2670 return SUCCESS;
2671 }
2672
2673
2674 gfc_try
2675 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
2676 {
2677 if (ap->expr->ts.type != BT_INTEGER)
2678 {
2679 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2680 gfc_current_intrinsic_arg[0]->name,
2681 gfc_current_intrinsic, &ap->expr->where);
2682 return FAILURE;
2683 }
2684
2685 if (array_check (ap->expr, 0) == FAILURE)
2686 return FAILURE;
2687
2688 return check_reduction (ap);
2689 }
2690
2691
2692 gfc_try
2693 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2694 {
2695 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2696 return FAILURE;
2697
2698 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2699 return FAILURE;
2700
2701 if (tsource->ts.type == BT_CHARACTER)
2702 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2703
2704 return SUCCESS;
2705 }
2706
2707
2708 gfc_try
2709 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
2710 {
2711 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2712 return FAILURE;
2713
2714 if (type_check (j, 1, BT_INTEGER) == FAILURE)
2715 return FAILURE;
2716
2717 if (type_check (mask, 2, BT_INTEGER) == FAILURE)
2718 return FAILURE;
2719
2720 if (same_type_check (i, 0, j, 1) == FAILURE)
2721 return FAILURE;
2722
2723 if (same_type_check (i, 0, mask, 2) == FAILURE)
2724 return FAILURE;
2725
2726 return SUCCESS;
2727 }
2728
2729
2730 gfc_try
2731 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2732 {
2733 if (variable_check (from, 0, false) == FAILURE)
2734 return FAILURE;
2735 if (allocatable_check (from, 0) == FAILURE)
2736 return FAILURE;
2737 if (gfc_is_coindexed (from))
2738 {
2739 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
2740 "coindexed", &from->where);
2741 return FAILURE;
2742 }
2743
2744 if (variable_check (to, 1, false) == FAILURE)
2745 return FAILURE;
2746 if (allocatable_check (to, 1) == FAILURE)
2747 return FAILURE;
2748 if (gfc_is_coindexed (to))
2749 {
2750 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
2751 "coindexed", &to->where);
2752 return FAILURE;
2753 }
2754
2755 if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
2756 {
2757 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2758 "polymorphic if FROM is polymorphic",
2759 &to->where);
2760 return FAILURE;
2761 }
2762
2763 if (same_type_check (to, 1, from, 0) == FAILURE)
2764 return FAILURE;
2765
2766 if (to->rank != from->rank)
2767 {
2768 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2769 "must have the same rank %d/%d", &to->where, from->rank,
2770 to->rank);
2771 return FAILURE;
2772 }
2773
2774 /* IR F08/0040; cf. 12-006A. */
2775 if (gfc_get_corank (to) != gfc_get_corank (from))
2776 {
2777 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2778 "must have the same corank %d/%d", &to->where,
2779 gfc_get_corank (from), gfc_get_corank (to));
2780 return FAILURE;
2781 }
2782
2783 if (to->ts.kind != from->ts.kind)
2784 {
2785 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L"
2786 " must be of the same kind %d/%d", &to->where, from->ts.kind,
2787 to->ts.kind);
2788 return FAILURE;
2789 }
2790
2791 /* CLASS arguments: Make sure the vtab of from is present. */
2792 if (to->ts.type == BT_CLASS)
2793 gfc_find_derived_vtab (from->ts.u.derived);
2794
2795 return SUCCESS;
2796 }
2797
2798
2799 gfc_try
2800 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2801 {
2802 if (type_check (x, 0, BT_REAL) == FAILURE)
2803 return FAILURE;
2804
2805 if (type_check (s, 1, BT_REAL) == FAILURE)
2806 return FAILURE;
2807
2808 if (s->expr_type == EXPR_CONSTANT)
2809 {
2810 if (mpfr_sgn (s->value.real) == 0)
2811 {
2812 gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2813 &s->where);
2814 return FAILURE;
2815 }
2816 }
2817
2818 return SUCCESS;
2819 }
2820
2821
2822 gfc_try
2823 gfc_check_new_line (gfc_expr *a)
2824 {
2825 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2826 return FAILURE;
2827
2828 return SUCCESS;
2829 }
2830
2831
2832 gfc_try
2833 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
2834 {
2835 if (type_check (array, 0, BT_REAL) == FAILURE)
2836 return FAILURE;
2837
2838 if (array_check (array, 0) == FAILURE)
2839 return FAILURE;
2840
2841 if (dim_rank_check (dim, array, false) == FAILURE)
2842 return FAILURE;
2843
2844 return SUCCESS;
2845 }
2846
2847 gfc_try
2848 gfc_check_null (gfc_expr *mold)
2849 {
2850 symbol_attribute attr;
2851
2852 if (mold == NULL)
2853 return SUCCESS;
2854
2855 if (variable_check (mold, 0, true) == FAILURE)
2856 return FAILURE;
2857
2858 attr = gfc_variable_attr (mold, NULL);
2859
2860 if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
2861 {
2862 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2863 "ALLOCATABLE or procedure pointer",
2864 gfc_current_intrinsic_arg[0]->name,
2865 gfc_current_intrinsic, &mold->where);
2866 return FAILURE;
2867 }
2868
2869 if (attr.allocatable
2870 && gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
2871 "allocatable MOLD at %L", &mold->where) == FAILURE)
2872 return FAILURE;
2873
2874 /* F2008, C1242. */
2875 if (gfc_is_coindexed (mold))
2876 {
2877 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2878 "coindexed", gfc_current_intrinsic_arg[0]->name,
2879 gfc_current_intrinsic, &mold->where);
2880 return FAILURE;
2881 }
2882
2883 return SUCCESS;
2884 }
2885
2886
2887 gfc_try
2888 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2889 {
2890 if (array_check (array, 0) == FAILURE)
2891 return FAILURE;
2892
2893 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2894 return FAILURE;
2895
2896 if (gfc_check_conformance (array, mask,
2897 "arguments '%s' and '%s' for intrinsic '%s'",
2898 gfc_current_intrinsic_arg[0]->name,
2899 gfc_current_intrinsic_arg[1]->name,
2900 gfc_current_intrinsic) == FAILURE)
2901 return FAILURE;
2902
2903 if (vector != NULL)
2904 {
2905 mpz_t array_size, vector_size;
2906 bool have_array_size, have_vector_size;
2907
2908 if (same_type_check (array, 0, vector, 2) == FAILURE)
2909 return FAILURE;
2910
2911 if (rank_check (vector, 2, 1) == FAILURE)
2912 return FAILURE;
2913
2914 /* VECTOR requires at least as many elements as MASK
2915 has .TRUE. values. */
2916 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2917 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2918
2919 if (have_vector_size
2920 && (mask->expr_type == EXPR_ARRAY
2921 || (mask->expr_type == EXPR_CONSTANT
2922 && have_array_size)))
2923 {
2924 int mask_true_values = 0;
2925
2926 if (mask->expr_type == EXPR_ARRAY)
2927 {
2928 gfc_constructor *mask_ctor;
2929 mask_ctor = gfc_constructor_first (mask->value.constructor);
2930 while (mask_ctor)
2931 {
2932 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2933 {
2934 mask_true_values = 0;
2935 break;
2936 }
2937
2938 if (mask_ctor->expr->value.logical)
2939 mask_true_values++;
2940
2941 mask_ctor = gfc_constructor_next (mask_ctor);
2942 }
2943 }
2944 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2945 mask_true_values = mpz_get_si (array_size);
2946
2947 if (mpz_get_si (vector_size) < mask_true_values)
2948 {
2949 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2950 "provide at least as many elements as there "
2951 "are .TRUE. values in '%s' (%ld/%d)",
2952 gfc_current_intrinsic_arg[2]->name,
2953 gfc_current_intrinsic, &vector->where,
2954 gfc_current_intrinsic_arg[1]->name,
2955 mpz_get_si (vector_size), mask_true_values);
2956 return FAILURE;
2957 }
2958 }
2959
2960 if (have_array_size)
2961 mpz_clear (array_size);
2962 if (have_vector_size)
2963 mpz_clear (vector_size);
2964 }
2965
2966 return SUCCESS;
2967 }
2968
2969
2970 gfc_try
2971 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
2972 {
2973 if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
2974 return FAILURE;
2975
2976 if (array_check (mask, 0) == FAILURE)
2977 return FAILURE;
2978
2979 if (dim_rank_check (dim, mask, false) == FAILURE)
2980 return FAILURE;
2981
2982 return SUCCESS;
2983 }
2984
2985
2986 gfc_try
2987 gfc_check_precision (gfc_expr *x)
2988 {
2989 if (real_or_complex_check (x, 0) == FAILURE)
2990 return FAILURE;
2991
2992 return SUCCESS;
2993 }
2994
2995
2996 gfc_try
2997 gfc_check_present (gfc_expr *a)
2998 {
2999 gfc_symbol *sym;
3000
3001 if (variable_check (a, 0, true) == FAILURE)
3002 return FAILURE;
3003
3004 sym = a->symtree->n.sym;
3005 if (!sym->attr.dummy)
3006 {
3007 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3008 "dummy variable", gfc_current_intrinsic_arg[0]->name,
3009 gfc_current_intrinsic, &a->where);
3010 return FAILURE;
3011 }
3012
3013 if (!sym->attr.optional)
3014 {
3015 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3016 "an OPTIONAL dummy variable",
3017 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3018 &a->where);
3019 return FAILURE;
3020 }
3021
3022 /* 13.14.82 PRESENT(A)
3023 ......
3024 Argument. A shall be the name of an optional dummy argument that is
3025 accessible in the subprogram in which the PRESENT function reference
3026 appears... */
3027
3028 if (a->ref != NULL
3029 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
3030 && (a->ref->u.ar.type == AR_FULL
3031 || (a->ref->u.ar.type == AR_ELEMENT
3032 && a->ref->u.ar.as->rank == 0))))
3033 {
3034 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3035 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
3036 gfc_current_intrinsic, &a->where, sym->name);
3037 return FAILURE;
3038 }
3039
3040 return SUCCESS;
3041 }
3042
3043
3044 gfc_try
3045 gfc_check_radix (gfc_expr *x)
3046 {
3047 if (int_or_real_check (x, 0) == FAILURE)
3048 return FAILURE;
3049
3050 return SUCCESS;
3051 }
3052
3053
3054 gfc_try
3055 gfc_check_range (gfc_expr *x)
3056 {
3057 if (numeric_check (x, 0) == FAILURE)
3058 return FAILURE;
3059
3060 return SUCCESS;
3061 }
3062
3063
3064 gfc_try
3065 gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
3066 {
3067 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3068 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
3069
3070 bool is_variable = true;
3071
3072 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3073 if (a->expr_type == EXPR_FUNCTION)
3074 is_variable = a->value.function.esym
3075 ? a->value.function.esym->result->attr.pointer
3076 : a->symtree->n.sym->result->attr.pointer;
3077
3078 if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
3079 || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
3080 || !is_variable)
3081 {
3082 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3083 "object", &a->where);
3084 return FAILURE;
3085 }
3086
3087 return SUCCESS;
3088 }
3089
3090
3091 /* real, float, sngl. */
3092 gfc_try
3093 gfc_check_real (gfc_expr *a, gfc_expr *kind)
3094 {
3095 if (numeric_check (a, 0) == FAILURE)
3096 return FAILURE;
3097
3098 if (kind_check (kind, 1, BT_REAL) == FAILURE)
3099 return FAILURE;
3100
3101 return SUCCESS;
3102 }
3103
3104
3105 gfc_try
3106 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
3107 {
3108 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3109 return FAILURE;
3110 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3111 return FAILURE;
3112
3113 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3114 return FAILURE;
3115 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3116 return FAILURE;
3117
3118 return SUCCESS;
3119 }
3120
3121
3122 gfc_try
3123 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3124 {
3125 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3126 return FAILURE;
3127 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3128 return FAILURE;
3129
3130 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3131 return FAILURE;
3132 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3133 return FAILURE;
3134
3135 if (status == NULL)
3136 return SUCCESS;
3137
3138 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3139 return FAILURE;
3140
3141 if (scalar_check (status, 2) == FAILURE)
3142 return FAILURE;
3143
3144 return SUCCESS;
3145 }
3146
3147
3148 gfc_try
3149 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
3150 {
3151 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3152 return FAILURE;
3153
3154 if (scalar_check (x, 0) == FAILURE)
3155 return FAILURE;
3156
3157 if (type_check (y, 0, BT_INTEGER) == FAILURE)
3158 return FAILURE;
3159
3160 if (scalar_check (y, 1) == FAILURE)
3161 return FAILURE;
3162
3163 return SUCCESS;
3164 }
3165
3166
3167 gfc_try
3168 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
3169 gfc_expr *pad, gfc_expr *order)
3170 {
3171 mpz_t size;
3172 mpz_t nelems;
3173 int shape_size;
3174
3175 if (array_check (source, 0) == FAILURE)
3176 return FAILURE;
3177
3178 if (rank_check (shape, 1, 1) == FAILURE)
3179 return FAILURE;
3180
3181 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
3182 return FAILURE;
3183
3184 if (gfc_array_size (shape, &size) != SUCCESS)
3185 {
3186 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3187 "array of constant size", &shape->where);
3188 return FAILURE;
3189 }
3190
3191 shape_size = mpz_get_ui (size);
3192 mpz_clear (size);
3193
3194 if (shape_size <= 0)
3195 {
3196 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3197 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3198 &shape->where);
3199 return FAILURE;
3200 }
3201 else if (shape_size > GFC_MAX_DIMENSIONS)
3202 {
3203 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3204 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
3205 return FAILURE;
3206 }
3207 else if (shape->expr_type == EXPR_ARRAY)
3208 {
3209 gfc_expr *e;
3210 int i, extent;
3211 for (i = 0; i < shape_size; ++i)
3212 {
3213 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
3214 if (e->expr_type != EXPR_CONSTANT)
3215 continue;
3216
3217 gfc_extract_int (e, &extent);
3218 if (extent < 0)
3219 {
3220 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3221 "negative element (%d)",
3222 gfc_current_intrinsic_arg[1]->name,
3223 gfc_current_intrinsic, &e->where, extent);
3224 return FAILURE;
3225 }
3226 }
3227 }
3228
3229 if (pad != NULL)
3230 {
3231 if (same_type_check (source, 0, pad, 2) == FAILURE)
3232 return FAILURE;
3233
3234 if (array_check (pad, 2) == FAILURE)
3235 return FAILURE;
3236 }
3237
3238 if (order != NULL)
3239 {
3240 if (array_check (order, 3) == FAILURE)
3241 return FAILURE;
3242
3243 if (type_check (order, 3, BT_INTEGER) == FAILURE)
3244 return FAILURE;
3245
3246 if (order->expr_type == EXPR_ARRAY)
3247 {
3248 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
3249 gfc_expr *e;
3250
3251 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
3252 perm[i] = 0;
3253
3254 gfc_array_size (order, &size);
3255 order_size = mpz_get_ui (size);
3256 mpz_clear (size);
3257
3258 if (order_size != shape_size)
3259 {
3260 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3261 "has wrong number of elements (%d/%d)",
3262 gfc_current_intrinsic_arg[3]->name,
3263 gfc_current_intrinsic, &order->where,
3264 order_size, shape_size);
3265 return FAILURE;
3266 }
3267
3268 for (i = 1; i <= order_size; ++i)
3269 {
3270 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
3271 if (e->expr_type != EXPR_CONSTANT)
3272 continue;
3273
3274 gfc_extract_int (e, &dim);
3275
3276 if (dim < 1 || dim > order_size)
3277 {
3278 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3279 "has out-of-range dimension (%d)",
3280 gfc_current_intrinsic_arg[3]->name,
3281 gfc_current_intrinsic, &e->where, dim);
3282 return FAILURE;
3283 }
3284
3285 if (perm[dim-1] != 0)
3286 {
3287 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3288 "invalid permutation of dimensions (dimension "
3289 "'%d' duplicated)",
3290 gfc_current_intrinsic_arg[3]->name,
3291 gfc_current_intrinsic, &e->where, dim);
3292 return FAILURE;
3293 }
3294
3295 perm[dim-1] = 1;
3296 }
3297 }
3298 }
3299
3300 if (pad == NULL && shape->expr_type == EXPR_ARRAY
3301 && gfc_is_constant_expr (shape)
3302 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
3303 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
3304 {
3305 /* Check the match in size between source and destination. */
3306 if (gfc_array_size (source, &nelems) == SUCCESS)
3307 {
3308 gfc_constructor *c;
3309 bool test;
3310
3311
3312 mpz_init_set_ui (size, 1);
3313 for (c = gfc_constructor_first (shape->value.constructor);
3314 c; c = gfc_constructor_next (c))
3315 mpz_mul (size, size, c->expr->value.integer);
3316
3317 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
3318 mpz_clear (nelems);
3319 mpz_clear (size);
3320
3321 if (test)
3322 {
3323 gfc_error ("Without padding, there are not enough elements "
3324 "in the intrinsic RESHAPE source at %L to match "
3325 "the shape", &source->where);
3326 return FAILURE;
3327 }
3328 }
3329 }
3330
3331 return SUCCESS;
3332 }
3333
3334
3335 gfc_try
3336 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
3337 {
3338
3339 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
3340 {
3341 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3342 "must be of a derived type",
3343 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3344 &a->where);
3345 return FAILURE;
3346 }
3347
3348 if (!gfc_type_is_extensible (a->ts.u.derived))
3349 {
3350 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3351 "must be of an extensible type",
3352 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3353 &a->where);
3354 return FAILURE;
3355 }
3356
3357 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
3358 {
3359 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3360 "must be of a derived type",
3361 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3362 &b->where);
3363 return FAILURE;
3364 }
3365
3366 if (!gfc_type_is_extensible (b->ts.u.derived))
3367 {
3368 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3369 "must be of an extensible type",
3370 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3371 &b->where);
3372 return FAILURE;
3373 }
3374
3375 return SUCCESS;
3376 }
3377
3378
3379 gfc_try
3380 gfc_check_scale (gfc_expr *x, gfc_expr *i)
3381 {
3382 if (type_check (x, 0, BT_REAL) == FAILURE)
3383 return FAILURE;
3384
3385 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3386 return FAILURE;
3387
3388 return SUCCESS;
3389 }
3390
3391
3392 gfc_try
3393 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3394 {
3395 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3396 return FAILURE;
3397
3398 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
3399 return FAILURE;
3400
3401 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3402 return FAILURE;
3403
3404 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3405 return FAILURE;
3406 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
3407 "with KIND argument at %L",
3408 gfc_current_intrinsic, &kind->where) == FAILURE)
3409 return FAILURE;
3410
3411 if (same_type_check (x, 0, y, 1) == FAILURE)
3412 return FAILURE;
3413
3414 return SUCCESS;
3415 }
3416
3417
3418 gfc_try
3419 gfc_check_secnds (gfc_expr *r)
3420 {
3421 if (type_check (r, 0, BT_REAL) == FAILURE)
3422 return FAILURE;
3423
3424 if (kind_value_check (r, 0, 4) == FAILURE)
3425 return FAILURE;
3426
3427 if (scalar_check (r, 0) == FAILURE)
3428 return FAILURE;
3429
3430 return SUCCESS;
3431 }
3432
3433
3434 gfc_try
3435 gfc_check_selected_char_kind (gfc_expr *name)
3436 {
3437 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3438 return FAILURE;
3439
3440 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3441 return FAILURE;
3442
3443 if (scalar_check (name, 0) == FAILURE)
3444 return FAILURE;
3445
3446 return SUCCESS;
3447 }
3448
3449
3450 gfc_try
3451 gfc_check_selected_int_kind (gfc_expr *r)
3452 {
3453 if (type_check (r, 0, BT_INTEGER) == FAILURE)
3454 return FAILURE;
3455
3456 if (scalar_check (r, 0) == FAILURE)
3457 return FAILURE;
3458
3459 return SUCCESS;
3460 }
3461
3462
3463 gfc_try
3464 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
3465 {
3466 if (p == NULL && r == NULL
3467 && gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
3468 " neither 'P' nor 'R' argument at %L",
3469 gfc_current_intrinsic_where) == FAILURE)
3470 return FAILURE;
3471
3472 if (p)
3473 {
3474 if (type_check (p, 0, BT_INTEGER) == FAILURE)
3475 return FAILURE;
3476
3477 if (scalar_check (p, 0) == FAILURE)
3478 return FAILURE;
3479 }
3480
3481 if (r)
3482 {
3483 if (type_check (r, 1, BT_INTEGER) == FAILURE)
3484 return FAILURE;
3485
3486 if (scalar_check (r, 1) == FAILURE)
3487 return FAILURE;
3488 }
3489
3490 if (radix)
3491 {
3492 if (type_check (radix, 1, BT_INTEGER) == FAILURE)
3493 return FAILURE;
3494
3495 if (scalar_check (radix, 1) == FAILURE)
3496 return FAILURE;
3497
3498 if (gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with "
3499 "RADIX argument at %L", gfc_current_intrinsic,
3500 &radix->where) == FAILURE)
3501 return FAILURE;
3502 }
3503
3504 return SUCCESS;
3505 }
3506
3507
3508 gfc_try
3509 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
3510 {
3511 if (type_check (x, 0, BT_REAL) == FAILURE)
3512 return FAILURE;
3513
3514 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3515 return FAILURE;
3516
3517 return SUCCESS;
3518 }
3519
3520
3521 gfc_try
3522 gfc_check_shape (gfc_expr *source, gfc_expr *kind)
3523 {
3524 gfc_array_ref *ar;
3525
3526 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3527 return SUCCESS;
3528
3529 ar = gfc_find_array_ref (source);
3530
3531 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
3532 {
3533 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3534 "an assumed size array", &source->where);
3535 return FAILURE;
3536 }
3537
3538 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
3539 return FAILURE;
3540 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
3541 "with KIND argument at %L",
3542 gfc_current_intrinsic, &kind->where) == FAILURE)
3543 return FAILURE;
3544
3545 return SUCCESS;
3546 }
3547
3548
3549 gfc_try
3550 gfc_check_shift (gfc_expr *i, gfc_expr *shift)
3551 {
3552 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3553 return FAILURE;
3554
3555 if (type_check (shift, 0, BT_INTEGER) == FAILURE)
3556 return FAILURE;
3557
3558 if (nonnegative_check ("SHIFT", shift) == FAILURE)
3559 return FAILURE;
3560
3561 if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
3562 return FAILURE;
3563
3564 return SUCCESS;
3565 }
3566
3567
3568 gfc_try
3569 gfc_check_sign (gfc_expr *a, gfc_expr *b)
3570 {
3571 if (int_or_real_check (a, 0) == FAILURE)
3572 return FAILURE;
3573
3574 if (same_type_check (a, 0, b, 1) == FAILURE)
3575 return FAILURE;
3576
3577 return SUCCESS;
3578 }
3579
3580
3581 gfc_try
3582 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3583 {
3584 if (array_check (array, 0) == FAILURE)
3585 return FAILURE;
3586
3587 if (dim_check (dim, 1, true) == FAILURE)
3588 return FAILURE;
3589
3590 if (dim_rank_check (dim, array, 0) == FAILURE)
3591 return FAILURE;
3592
3593 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3594 return FAILURE;
3595 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
3596 "with KIND argument at %L",
3597 gfc_current_intrinsic, &kind->where) == FAILURE)
3598 return FAILURE;
3599
3600
3601 return SUCCESS;
3602 }
3603
3604
3605 gfc_try
3606 gfc_check_sizeof (gfc_expr *arg)
3607 {
3608 if (arg->ts.type == BT_PROCEDURE)
3609 {
3610 gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
3611 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3612 &arg->where);
3613 return FAILURE;
3614 }
3615 return SUCCESS;
3616 }
3617
3618
3619 gfc_try
3620 gfc_check_c_sizeof (gfc_expr *arg)
3621 {
3622 if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
3623 {
3624 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3625 "interoperable data entity",
3626 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3627 &arg->where);
3628 return FAILURE;
3629 }
3630 return SUCCESS;
3631 }
3632
3633
3634 gfc_try
3635 gfc_check_sleep_sub (gfc_expr *seconds)
3636 {
3637 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3638 return FAILURE;
3639
3640 if (scalar_check (seconds, 0) == FAILURE)
3641 return FAILURE;
3642
3643 return SUCCESS;
3644 }
3645
3646 gfc_try
3647 gfc_check_sngl (gfc_expr *a)
3648 {
3649 if (type_check (a, 0, BT_REAL) == FAILURE)
3650 return FAILURE;
3651
3652 if ((a->ts.kind != gfc_default_double_kind)
3653 && gfc_notify_std (GFC_STD_GNU, "non double precision "
3654 "REAL argument to %s intrinsic at %L",
3655 gfc_current_intrinsic, &a->where) == FAILURE)
3656 return FAILURE;
3657
3658 return SUCCESS;
3659 }
3660
3661 gfc_try
3662 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
3663 {
3664 if (source->rank >= GFC_MAX_DIMENSIONS)
3665 {
3666 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3667 "than rank %d", gfc_current_intrinsic_arg[0]->name,
3668 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
3669
3670 return FAILURE;
3671 }
3672
3673 if (dim == NULL)
3674 return FAILURE;
3675
3676 if (dim_check (dim, 1, false) == FAILURE)
3677 return FAILURE;
3678
3679 /* dim_rank_check() does not apply here. */
3680 if (dim
3681 && dim->expr_type == EXPR_CONSTANT
3682 && (mpz_cmp_ui (dim->value.integer, 1) < 0
3683 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
3684 {
3685 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3686 "dimension index", gfc_current_intrinsic_arg[1]->name,
3687 gfc_current_intrinsic, &dim->where);
3688 return FAILURE;
3689 }
3690
3691 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
3692 return FAILURE;
3693
3694 if (scalar_check (ncopies, 2) == FAILURE)
3695 return FAILURE;
3696
3697 return SUCCESS;
3698 }
3699
3700
3701 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3702 functions). */
3703
3704 gfc_try
3705 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3706 {
3707 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3708 return FAILURE;
3709
3710 if (scalar_check (unit, 0) == FAILURE)
3711 return FAILURE;
3712
3713 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3714 return FAILURE;
3715 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3716 return FAILURE;
3717
3718 if (status == NULL)
3719 return SUCCESS;
3720
3721 if (type_check (status, 2, BT_INTEGER) == FAILURE
3722 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3723 || scalar_check (status, 2) == FAILURE)
3724 return FAILURE;
3725
3726 return SUCCESS;
3727 }
3728
3729
3730 gfc_try
3731 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3732 {
3733 return gfc_check_fgetputc_sub (unit, c, NULL);
3734 }
3735
3736
3737 gfc_try
3738 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3739 {
3740 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3741 return FAILURE;
3742 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3743 return FAILURE;
3744
3745 if (status == NULL)
3746 return SUCCESS;
3747
3748 if (type_check (status, 1, BT_INTEGER) == FAILURE
3749 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3750 || scalar_check (status, 1) == FAILURE)
3751 return FAILURE;
3752
3753 return SUCCESS;
3754 }
3755
3756
3757 gfc_try
3758 gfc_check_fgetput (gfc_expr *c)
3759 {
3760 return gfc_check_fgetput_sub (c, NULL);
3761 }
3762
3763
3764 gfc_try
3765 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3766 {
3767 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3768 return FAILURE;
3769
3770 if (scalar_check (unit, 0) == FAILURE)
3771 return FAILURE;
3772
3773 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3774 return FAILURE;
3775
3776 if (scalar_check (offset, 1) == FAILURE)
3777 return FAILURE;
3778
3779 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3780 return FAILURE;
3781
3782 if (scalar_check (whence, 2) == FAILURE)
3783 return FAILURE;
3784
3785 if (status == NULL)
3786 return SUCCESS;
3787
3788 if (type_check (status, 3, BT_INTEGER) == FAILURE)
3789 return FAILURE;
3790
3791 if (kind_value_check (status, 3, 4) == FAILURE)
3792 return FAILURE;
3793
3794 if (scalar_check (status, 3) == FAILURE)
3795 return FAILURE;
3796
3797 return SUCCESS;
3798 }
3799
3800
3801
3802 gfc_try
3803 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
3804 {
3805 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3806 return FAILURE;
3807
3808 if (scalar_check (unit, 0) == FAILURE)
3809 return FAILURE;
3810
3811 if (type_check (array, 1, BT_INTEGER) == FAILURE
3812 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
3813 return FAILURE;
3814
3815 if (array_check (array, 1) == FAILURE)
3816 return FAILURE;
3817
3818 return SUCCESS;
3819 }
3820
3821
3822 gfc_try
3823 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3824 {
3825 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3826 return FAILURE;
3827
3828 if (scalar_check (unit, 0) == FAILURE)
3829 return FAILURE;
3830
3831 if (type_check (array, 1, BT_INTEGER) == FAILURE
3832 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3833 return FAILURE;
3834
3835 if (array_check (array, 1) == FAILURE)
3836 return FAILURE;
3837
3838 if (status == NULL)
3839 return SUCCESS;
3840
3841 if (type_check (status, 2, BT_INTEGER) == FAILURE
3842 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3843 return FAILURE;
3844
3845 if (scalar_check (status, 2) == FAILURE)
3846 return FAILURE;
3847
3848 return SUCCESS;
3849 }
3850
3851
3852 gfc_try
3853 gfc_check_ftell (gfc_expr *unit)
3854 {
3855 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3856 return FAILURE;
3857
3858 if (scalar_check (unit, 0) == FAILURE)
3859 return FAILURE;
3860
3861 return SUCCESS;
3862 }
3863
3864
3865 gfc_try
3866 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3867 {
3868 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3869 return FAILURE;
3870
3871 if (scalar_check (unit, 0) == FAILURE)
3872 return FAILURE;
3873
3874 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3875 return FAILURE;
3876
3877 if (scalar_check (offset, 1) == FAILURE)
3878 return FAILURE;
3879
3880 return SUCCESS;
3881 }
3882
3883
3884 gfc_try
3885 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3886 {
3887 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3888 return FAILURE;
3889 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3890 return FAILURE;
3891
3892 if (type_check (array, 1, BT_INTEGER) == FAILURE
3893 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3894 return FAILURE;
3895
3896 if (array_check (array, 1) == FAILURE)
3897 return FAILURE;
3898
3899 return SUCCESS;
3900 }
3901
3902
3903 gfc_try
3904 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3905 {
3906 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3907 return FAILURE;
3908 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3909 return FAILURE;
3910
3911 if (type_check (array, 1, BT_INTEGER) == FAILURE
3912 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3913 return FAILURE;
3914
3915 if (array_check (array, 1) == FAILURE)
3916 return FAILURE;
3917
3918 if (status == NULL)
3919 return SUCCESS;
3920
3921 if (type_check (status, 2, BT_INTEGER) == FAILURE
3922 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3923 return FAILURE;
3924
3925 if (scalar_check (status, 2) == FAILURE)
3926 return FAILURE;
3927
3928 return SUCCESS;
3929 }
3930
3931
3932 gfc_try
3933 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3934 {
3935 mpz_t nelems;
3936
3937 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3938 {
3939 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3940 return FAILURE;
3941 }
3942
3943 if (coarray_check (coarray, 0) == FAILURE)
3944 return FAILURE;
3945
3946 if (sub->rank != 1)
3947 {
3948 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3949 gfc_current_intrinsic_arg[1]->name, &sub->where);
3950 return FAILURE;
3951 }
3952
3953 if (gfc_array_size (sub, &nelems) == SUCCESS)
3954 {
3955 int corank = gfc_get_corank (coarray);
3956
3957 if (mpz_cmp_ui (nelems, corank) != 0)
3958 {
3959 gfc_error ("The number of array elements of the SUB argument to "
3960 "IMAGE_INDEX at %L shall be %d (corank) not %d",
3961 &sub->where, corank, (int) mpz_get_si (nelems));
3962 mpz_clear (nelems);
3963 return FAILURE;
3964 }
3965 mpz_clear (nelems);
3966 }
3967
3968 return SUCCESS;
3969 }
3970
3971
3972 gfc_try
3973 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3974 {
3975 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3976 {
3977 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3978 return FAILURE;
3979 }
3980
3981 if (dim != NULL && coarray == NULL)
3982 {
3983 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3984 "intrinsic at %L", &dim->where);
3985 return FAILURE;
3986 }
3987
3988 if (coarray == NULL)
3989 return SUCCESS;
3990
3991 if (coarray_check (coarray, 0) == FAILURE)
3992 return FAILURE;
3993
3994 if (dim != NULL)
3995 {
3996 if (dim_check (dim, 1, false) == FAILURE)
3997 return FAILURE;
3998
3999 if (dim_corank_check (dim, coarray) == FAILURE)
4000 return FAILURE;
4001 }
4002
4003 return SUCCESS;
4004 }
4005
4006 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4007 by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
4008
4009 gfc_try
4010 gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
4011 size_t *source_size, size_t *result_size,
4012 size_t *result_length_p)
4013 {
4014 size_t result_elt_size;
4015 mpz_t tmp;
4016 gfc_expr *mold_element;
4017
4018 if (source->expr_type == EXPR_FUNCTION)
4019 return FAILURE;
4020
4021 if (size && size->expr_type != EXPR_CONSTANT)
4022 return FAILURE;
4023
4024 /* Calculate the size of the source. */
4025 if (source->expr_type == EXPR_ARRAY
4026 && gfc_array_size (source, &tmp) == FAILURE)
4027 return FAILURE;
4028
4029 *source_size = gfc_target_expr_size (source);
4030 if (*source_size == 0)
4031 return FAILURE;
4032
4033 mold_element = mold->expr_type == EXPR_ARRAY
4034 ? gfc_constructor_first (mold->value.constructor)->expr
4035 : mold;
4036
4037 /* Determine the size of the element. */
4038 result_elt_size = gfc_target_expr_size (mold_element);
4039 if (result_elt_size == 0)
4040 return FAILURE;
4041
4042 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4043 {
4044 int result_length;
4045
4046 if (size)
4047 result_length = (size_t)mpz_get_ui (size->value.integer);
4048 else
4049 {
4050 result_length = *source_size / result_elt_size;
4051 if (result_length * result_elt_size < *source_size)
4052 result_length += 1;
4053 }
4054
4055 *result_size = result_length * result_elt_size;
4056 if (result_length_p)
4057 *result_length_p = result_length;
4058 }
4059 else
4060 *result_size = result_elt_size;
4061
4062 return SUCCESS;
4063 }
4064
4065
4066 gfc_try
4067 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4068 {
4069 size_t source_size;
4070 size_t result_size;
4071
4072 if (mold->ts.type == BT_HOLLERITH)
4073 {
4074 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4075 &mold->where, gfc_basic_typename (BT_HOLLERITH));
4076 return FAILURE;
4077 }
4078
4079 if (size != NULL)
4080 {
4081 if (type_check (size, 2, BT_INTEGER) == FAILURE)
4082 return FAILURE;
4083
4084 if (scalar_check (size, 2) == FAILURE)
4085 return FAILURE;
4086
4087 if (nonoptional_check (size, 2) == FAILURE)
4088 return FAILURE;
4089 }
4090
4091 if (!gfc_option.warn_surprising)
4092 return SUCCESS;
4093
4094 /* If we can't calculate the sizes, we cannot check any more.
4095 Return SUCCESS for that case. */
4096
4097 if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
4098 &result_size, NULL) == FAILURE)
4099 return SUCCESS;
4100
4101 if (source_size < result_size)
4102 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4103 "source size %ld < result size %ld", &source->where,
4104 (long) source_size, (long) result_size);
4105
4106 return SUCCESS;
4107 }
4108
4109
4110 gfc_try
4111 gfc_check_transpose (gfc_expr *matrix)
4112 {
4113 if (rank_check (matrix, 0, 2) == FAILURE)
4114 return FAILURE;
4115
4116 return SUCCESS;
4117 }
4118
4119
4120 gfc_try
4121 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4122 {
4123 if (array_check (array, 0) == FAILURE)
4124 return FAILURE;
4125
4126 if (dim_check (dim, 1, false) == FAILURE)
4127 return FAILURE;
4128
4129 if (dim_rank_check (dim, array, 0) == FAILURE)
4130 return FAILURE;
4131
4132 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4133 return FAILURE;
4134 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
4135 "with KIND argument at %L",
4136 gfc_current_intrinsic, &kind->where) == FAILURE)
4137 return FAILURE;
4138
4139 return SUCCESS;
4140 }
4141
4142
4143 gfc_try
4144 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
4145 {
4146 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4147 {
4148 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4149 return FAILURE;
4150 }
4151
4152 if (coarray_check (coarray, 0) == FAILURE)
4153 return FAILURE;
4154
4155 if (dim != NULL)
4156 {
4157 if (dim_check (dim, 1, false) == FAILURE)
4158 return FAILURE;
4159
4160 if (dim_corank_check (dim, coarray) == FAILURE)
4161 return FAILURE;
4162 }
4163
4164 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4165 return FAILURE;
4166
4167 return SUCCESS;
4168 }
4169
4170
4171 gfc_try
4172 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
4173 {
4174 mpz_t vector_size;
4175
4176 if (rank_check (vector, 0, 1) == FAILURE)
4177 return FAILURE;
4178
4179 if (array_check (mask, 1) == FAILURE)
4180 return FAILURE;
4181
4182 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
4183 return FAILURE;
4184
4185 if (same_type_check (vector, 0, field, 2) == FAILURE)
4186 return FAILURE;
4187
4188 if (mask->expr_type == EXPR_ARRAY
4189 && gfc_array_size (vector, &vector_size) == SUCCESS)
4190 {
4191 int mask_true_count = 0;
4192 gfc_constructor *mask_ctor;
4193 mask_ctor = gfc_constructor_first (mask->value.constructor);
4194 while (mask_ctor)
4195 {
4196 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4197 {
4198 mask_true_count = 0;
4199 break;
4200 }
4201
4202 if (mask_ctor->expr->value.logical)
4203 mask_true_count++;
4204
4205 mask_ctor = gfc_constructor_next (mask_ctor);
4206 }
4207
4208 if (mpz_get_si (vector_size) < mask_true_count)
4209 {
4210 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4211 "provide at least as many elements as there "
4212 "are .TRUE. values in '%s' (%ld/%d)",
4213 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4214 &vector->where, gfc_current_intrinsic_arg[1]->name,
4215 mpz_get_si (vector_size), mask_true_count);
4216 return FAILURE;
4217 }
4218
4219 mpz_clear (vector_size);
4220 }
4221
4222 if (mask->rank != field->rank && field->rank != 0)
4223 {
4224 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4225 "the same rank as '%s' or be a scalar",
4226 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4227 &field->where, gfc_current_intrinsic_arg[1]->name);
4228 return FAILURE;
4229 }
4230
4231 if (mask->rank == field->rank)
4232 {
4233 int i;
4234 for (i = 0; i < field->rank; i++)
4235 if (! identical_dimen_shape (mask, i, field, i))
4236 {
4237 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4238 "must have identical shape.",
4239 gfc_current_intrinsic_arg[2]->name,
4240 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4241 &field->where);
4242 }
4243 }
4244
4245 return SUCCESS;
4246 }
4247
4248
4249 gfc_try
4250 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4251 {
4252 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4253 return FAILURE;
4254
4255 if (same_type_check (x, 0, y, 1) == FAILURE)
4256 return FAILURE;
4257
4258 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
4259 return FAILURE;
4260
4261 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
4262 return FAILURE;
4263 if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
4264 "with KIND argument at %L",
4265 gfc_current_intrinsic, &kind->where) == FAILURE)
4266 return FAILURE;
4267
4268 return SUCCESS;
4269 }
4270
4271
4272 gfc_try
4273 gfc_check_trim (gfc_expr *x)
4274 {
4275 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4276 return FAILURE;
4277
4278 if (scalar_check (x, 0) == FAILURE)
4279 return FAILURE;
4280
4281 return SUCCESS;
4282 }
4283
4284
4285 gfc_try
4286 gfc_check_ttynam (gfc_expr *unit)
4287 {
4288 if (scalar_check (unit, 0) == FAILURE)
4289 return FAILURE;
4290
4291 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4292 return FAILURE;
4293
4294 return SUCCESS;
4295 }
4296
4297
4298 /* Common check function for the half a dozen intrinsics that have a
4299 single real argument. */
4300
4301 gfc_try
4302 gfc_check_x (gfc_expr *x)
4303 {
4304 if (type_check (x, 0, BT_REAL) == FAILURE)
4305 return FAILURE;
4306
4307 return SUCCESS;
4308 }
4309
4310
4311 /************* Check functions for intrinsic subroutines *************/
4312
4313 gfc_try
4314 gfc_check_cpu_time (gfc_expr *time)
4315 {
4316 if (scalar_check (time, 0) == FAILURE)
4317 return FAILURE;
4318
4319 if (type_check (time, 0, BT_REAL) == FAILURE)
4320 return FAILURE;
4321
4322 if (variable_check (time, 0, false) == FAILURE)
4323 return FAILURE;
4324
4325 return SUCCESS;
4326 }
4327
4328
4329 gfc_try
4330 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
4331 gfc_expr *zone, gfc_expr *values)
4332 {
4333 if (date != NULL)
4334 {
4335 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4336 return FAILURE;
4337 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4338 return FAILURE;
4339 if (scalar_check (date, 0) == FAILURE)
4340 return FAILURE;
4341 if (variable_check (date, 0, false) == FAILURE)
4342 return FAILURE;
4343 }
4344
4345 if (time != NULL)
4346 {
4347 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
4348 return FAILURE;
4349 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
4350 return FAILURE;
4351 if (scalar_check (time, 1) == FAILURE)
4352 return FAILURE;
4353 if (variable_check (time, 1, false) == FAILURE)
4354 return FAILURE;
4355 }
4356
4357 if (zone != NULL)
4358 {
4359 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
4360 return FAILURE;
4361 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
4362 return FAILURE;
4363 if (scalar_check (zone, 2) == FAILURE)
4364 return FAILURE;
4365 if (variable_check (zone, 2, false) == FAILURE)
4366 return FAILURE;
4367 }
4368
4369 if (values != NULL)
4370 {
4371 if (type_check (values, 3, BT_INTEGER) == FAILURE)
4372 return FAILURE;
4373 if (array_check (values, 3) == FAILURE)
4374 return FAILURE;
4375 if (rank_check (values, 3, 1) == FAILURE)
4376 return FAILURE;
4377 if (variable_check (values, 3, false) == FAILURE)
4378 return FAILURE;
4379 }
4380
4381 return SUCCESS;
4382 }
4383
4384
4385 gfc_try
4386 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
4387 gfc_expr *to, gfc_expr *topos)
4388 {
4389 if (type_check (from, 0, BT_INTEGER) == FAILURE)
4390 return FAILURE;
4391
4392 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
4393 return FAILURE;
4394
4395 if (type_check (len, 2, BT_INTEGER) == FAILURE)
4396 return FAILURE;
4397
4398 if (same_type_check (from, 0, to, 3) == FAILURE)
4399 return FAILURE;
4400
4401 if (variable_check (to, 3, false) == FAILURE)
4402 return FAILURE;
4403
4404 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
4405 return FAILURE;
4406
4407 if (nonnegative_check ("frompos", frompos) == FAILURE)
4408 return FAILURE;
4409
4410 if (nonnegative_check ("topos", topos) == FAILURE)
4411 return FAILURE;
4412
4413 if (nonnegative_check ("len", len) == FAILURE)
4414 return FAILURE;
4415
4416 if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
4417 == FAILURE)
4418 return FAILURE;
4419
4420 if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
4421 return FAILURE;
4422
4423 return SUCCESS;
4424 }
4425
4426
4427 gfc_try
4428 gfc_check_random_number (gfc_expr *harvest)
4429 {
4430 if (type_check (harvest, 0, BT_REAL) == FAILURE)
4431 return FAILURE;
4432
4433 if (variable_check (harvest, 0, false) == FAILURE)
4434 return FAILURE;
4435
4436 return SUCCESS;
4437 }
4438
4439
4440 gfc_try
4441 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
4442 {
4443 unsigned int nargs = 0, kiss_size;
4444 locus *where = NULL;
4445 mpz_t put_size, get_size;
4446 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4447
4448 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
4449
4450 /* Keep the number of bytes in sync with kiss_size in
4451 libgfortran/intrinsics/random.c. */
4452 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
4453
4454 if (size != NULL)
4455 {
4456 if (size->expr_type != EXPR_VARIABLE
4457 || !size->symtree->n.sym->attr.optional)
4458 nargs++;
4459
4460 if (scalar_check (size, 0) == FAILURE)
4461 return FAILURE;
4462
4463 if (type_check (size, 0, BT_INTEGER) == FAILURE)
4464 return FAILURE;
4465
4466 if (variable_check (size, 0, false) == FAILURE)
4467 return FAILURE;
4468
4469 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
4470 return FAILURE;
4471 }
4472
4473 if (put != NULL)
4474 {
4475 if (put->expr_type != EXPR_VARIABLE
4476 || !put->symtree->n.sym->attr.optional)
4477 {
4478 nargs++;
4479 where = &put->where;
4480 }
4481
4482 if (array_check (put, 1) == FAILURE)
4483 return FAILURE;
4484
4485 if (rank_check (put, 1, 1) == FAILURE)
4486 return FAILURE;
4487
4488 if (type_check (put, 1, BT_INTEGER) == FAILURE)
4489 return FAILURE;
4490
4491 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
4492 return FAILURE;
4493
4494 if (gfc_array_size (put, &put_size) == SUCCESS
4495 && mpz_get_ui (put_size) < kiss_size)
4496 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4497 "too small (%i/%i)",
4498 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4499 where, (int) mpz_get_ui (put_size), kiss_size);
4500 }
4501
4502 if (get != NULL)
4503 {
4504 if (get->expr_type != EXPR_VARIABLE
4505 || !get->symtree->n.sym->attr.optional)
4506 {
4507 nargs++;
4508 where = &get->where;
4509 }
4510
4511 if (array_check (get, 2) == FAILURE)
4512 return FAILURE;
4513
4514 if (rank_check (get, 2, 1) == FAILURE)
4515 return FAILURE;
4516
4517 if (type_check (get, 2, BT_INTEGER) == FAILURE)
4518 return FAILURE;
4519
4520 if (variable_check (get, 2, false) == FAILURE)
4521 return FAILURE;
4522
4523 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
4524 return FAILURE;
4525
4526 if (gfc_array_size (get, &get_size) == SUCCESS
4527 && mpz_get_ui (get_size) < kiss_size)
4528 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4529 "too small (%i/%i)",
4530 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4531 where, (int) mpz_get_ui (get_size), kiss_size);
4532 }
4533
4534 /* RANDOM_SEED may not have more than one non-optional argument. */
4535 if (nargs > 1)
4536 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
4537
4538 return SUCCESS;
4539 }
4540
4541
4542 gfc_try
4543 gfc_check_second_sub (gfc_expr *time)
4544 {
4545 if (scalar_check (time, 0) == FAILURE)
4546 return FAILURE;
4547
4548 if (type_check (time, 0, BT_REAL) == FAILURE)
4549 return FAILURE;
4550
4551 if (kind_value_check(time, 0, 4) == FAILURE)
4552 return FAILURE;
4553
4554 return SUCCESS;
4555 }
4556
4557
4558 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
4559 count, count_rate, and count_max are all optional arguments */
4560
4561 gfc_try
4562 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
4563 gfc_expr *count_max)
4564 {
4565 if (count != NULL)
4566 {
4567 if (scalar_check (count, 0) == FAILURE)
4568 return FAILURE;
4569
4570 if (type_check (count, 0, BT_INTEGER) == FAILURE)
4571 return FAILURE;
4572
4573 if (variable_check (count, 0, false) == FAILURE)
4574 return FAILURE;
4575 }
4576
4577 if (count_rate != NULL)
4578 {
4579 if (scalar_check (count_rate, 1) == FAILURE)
4580 return FAILURE;
4581
4582 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
4583 return FAILURE;
4584
4585 if (variable_check (count_rate, 1, false) == FAILURE)
4586 return FAILURE;
4587
4588 if (count != NULL
4589 && same_type_check (count, 0, count_rate, 1) == FAILURE)
4590 return FAILURE;
4591
4592 }
4593
4594 if (count_max != NULL)
4595 {
4596 if (scalar_check (count_max, 2) == FAILURE)
4597 return FAILURE;
4598
4599 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
4600 return FAILURE;
4601
4602 if (variable_check (count_max, 2, false) == FAILURE)
4603 return FAILURE;
4604
4605 if (count != NULL
4606 && same_type_check (count, 0, count_max, 2) == FAILURE)
4607 return FAILURE;
4608
4609 if (count_rate != NULL
4610 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
4611 return FAILURE;
4612 }
4613
4614 return SUCCESS;
4615 }
4616
4617
4618 gfc_try
4619 gfc_check_irand (gfc_expr *x)
4620 {
4621 if (x == NULL)
4622 return SUCCESS;
4623
4624 if (scalar_check (x, 0) == FAILURE)
4625 return FAILURE;
4626
4627 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4628 return FAILURE;
4629
4630 if (kind_value_check(x, 0, 4) == FAILURE)
4631 return FAILURE;
4632
4633 return SUCCESS;
4634 }
4635
4636
4637 gfc_try
4638 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
4639 {
4640 if (scalar_check (seconds, 0) == FAILURE)
4641 return FAILURE;
4642 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
4643 return FAILURE;
4644
4645 if (int_or_proc_check (handler, 1) == FAILURE)
4646 return FAILURE;
4647 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4648 return FAILURE;
4649
4650 if (status == NULL)
4651 return SUCCESS;
4652
4653 if (scalar_check (status, 2) == FAILURE)
4654 return FAILURE;
4655 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4656 return FAILURE;
4657 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
4658 return FAILURE;
4659
4660 return SUCCESS;
4661 }
4662
4663
4664 gfc_try
4665 gfc_check_rand (gfc_expr *x)
4666 {
4667 if (x == NULL)
4668 return SUCCESS;
4669
4670 if (scalar_check (x, 0) == FAILURE)
4671 return FAILURE;
4672
4673 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4674 return FAILURE;
4675
4676 if (kind_value_check(x, 0, 4) == FAILURE)
4677 return FAILURE;
4678
4679 return SUCCESS;
4680 }
4681
4682
4683 gfc_try
4684 gfc_check_srand (gfc_expr *x)
4685 {
4686 if (scalar_check (x, 0) == FAILURE)
4687 return FAILURE;
4688
4689 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4690 return FAILURE;
4691
4692 if (kind_value_check(x, 0, 4) == FAILURE)
4693 return FAILURE;
4694
4695 return SUCCESS;
4696 }
4697
4698
4699 gfc_try
4700 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
4701 {
4702 if (scalar_check (time, 0) == FAILURE)
4703 return FAILURE;
4704 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4705 return FAILURE;
4706
4707 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
4708 return FAILURE;
4709 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
4710 return FAILURE;
4711
4712 return SUCCESS;
4713 }
4714
4715
4716 gfc_try
4717 gfc_check_dtime_etime (gfc_expr *x)
4718 {
4719 if (array_check (x, 0) == FAILURE)
4720 return FAILURE;
4721
4722 if (rank_check (x, 0, 1) == FAILURE)
4723 return FAILURE;
4724
4725 if (variable_check (x, 0, false) == FAILURE)
4726 return FAILURE;
4727
4728 if (type_check (x, 0, BT_REAL) == FAILURE)
4729 return FAILURE;
4730
4731 if (kind_value_check(x, 0, 4) == FAILURE)
4732 return FAILURE;
4733
4734 return SUCCESS;
4735 }
4736
4737
4738 gfc_try
4739 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
4740 {
4741 if (array_check (values, 0) == FAILURE)
4742 return FAILURE;
4743
4744 if (rank_check (values, 0, 1) == FAILURE)
4745 return FAILURE;
4746
4747 if (variable_check (values, 0, false) == FAILURE)
4748 return FAILURE;
4749
4750 if (type_check (values, 0, BT_REAL) == FAILURE)
4751 return FAILURE;
4752
4753 if (kind_value_check(values, 0, 4) == FAILURE)
4754 return FAILURE;
4755
4756 if (scalar_check (time, 1) == FAILURE)
4757 return FAILURE;
4758
4759 if (type_check (time, 1, BT_REAL) == FAILURE)
4760 return FAILURE;
4761
4762 if (kind_value_check(time, 1, 4) == FAILURE)
4763 return FAILURE;
4764
4765 return SUCCESS;
4766 }
4767
4768
4769 gfc_try
4770 gfc_check_fdate_sub (gfc_expr *date)
4771 {
4772 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4773 return FAILURE;
4774 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4775 return FAILURE;
4776
4777 return SUCCESS;
4778 }
4779
4780
4781 gfc_try
4782 gfc_check_gerror (gfc_expr *msg)
4783 {
4784 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4785 return FAILURE;
4786 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4787 return FAILURE;
4788
4789 return SUCCESS;
4790 }
4791
4792
4793 gfc_try
4794 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4795 {
4796 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4797 return FAILURE;
4798 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4799 return FAILURE;
4800
4801 if (status == NULL)
4802 return SUCCESS;
4803
4804 if (scalar_check (status, 1) == FAILURE)
4805 return FAILURE;
4806
4807 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4808 return FAILURE;
4809
4810 return SUCCESS;
4811 }
4812
4813
4814 gfc_try
4815 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4816 {
4817 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4818 return FAILURE;
4819
4820 if (pos->ts.kind > gfc_default_integer_kind)
4821 {
4822 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4823 "not wider than the default kind (%d)",
4824 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4825 &pos->where, gfc_default_integer_kind);
4826 return FAILURE;
4827 }
4828
4829 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4830 return FAILURE;
4831 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4832 return FAILURE;
4833
4834 return SUCCESS;
4835 }
4836
4837
4838 gfc_try
4839 gfc_check_getlog (gfc_expr *msg)
4840 {
4841 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4842 return FAILURE;
4843 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4844 return FAILURE;
4845
4846 return SUCCESS;
4847 }
4848
4849
4850 gfc_try
4851 gfc_check_exit (gfc_expr *status)
4852 {
4853 if (status == NULL)
4854 return SUCCESS;
4855
4856 if (type_check (status, 0, BT_INTEGER) == FAILURE)
4857 return FAILURE;
4858
4859 if (scalar_check (status, 0) == FAILURE)
4860 return FAILURE;
4861
4862 return SUCCESS;
4863 }
4864
4865
4866 gfc_try
4867 gfc_check_flush (gfc_expr *unit)
4868 {
4869 if (unit == NULL)
4870 return SUCCESS;
4871
4872 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4873 return FAILURE;
4874
4875 if (scalar_check (unit, 0) == FAILURE)
4876 return FAILURE;
4877
4878 return SUCCESS;
4879 }
4880
4881
4882 gfc_try
4883 gfc_check_free (gfc_expr *i)
4884 {
4885 if (type_check (i, 0, BT_INTEGER) == FAILURE)
4886 return FAILURE;
4887
4888 if (scalar_check (i, 0) == FAILURE)
4889 return FAILURE;
4890
4891 return SUCCESS;
4892 }
4893
4894
4895 gfc_try
4896 gfc_check_hostnm (gfc_expr *name)
4897 {
4898 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4899 return FAILURE;
4900 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4901 return FAILURE;
4902
4903 return SUCCESS;
4904 }
4905
4906
4907 gfc_try
4908 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4909 {
4910 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4911 return FAILURE;
4912 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4913 return FAILURE;
4914
4915 if (status == NULL)
4916 return SUCCESS;
4917
4918 if (scalar_check (status, 1) == FAILURE)
4919 return FAILURE;
4920
4921 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4922 return FAILURE;
4923
4924 return SUCCESS;
4925 }
4926
4927
4928 gfc_try
4929 gfc_check_itime_idate (gfc_expr *values)
4930 {
4931 if (array_check (values, 0) == FAILURE)
4932 return FAILURE;
4933
4934 if (rank_check (values, 0, 1) == FAILURE)
4935 return FAILURE;
4936
4937 if (variable_check (values, 0, false) == FAILURE)
4938 return FAILURE;
4939
4940 if (type_check (values, 0, BT_INTEGER) == FAILURE)
4941 return FAILURE;
4942
4943 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4944 return FAILURE;
4945
4946 return SUCCESS;
4947 }
4948
4949
4950 gfc_try
4951 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4952 {
4953 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4954 return FAILURE;
4955
4956 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4957 return FAILURE;
4958
4959 if (scalar_check (time, 0) == FAILURE)
4960 return FAILURE;
4961
4962 if (array_check (values, 1) == FAILURE)
4963 return FAILURE;
4964
4965 if (rank_check (values, 1, 1) == FAILURE)
4966 return FAILURE;
4967
4968 if (variable_check (values, 1, false) == FAILURE)
4969 return FAILURE;
4970
4971 if (type_check (values, 1, BT_INTEGER) == FAILURE)
4972 return FAILURE;
4973
4974 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4975 return FAILURE;
4976
4977 return SUCCESS;
4978 }
4979
4980
4981 gfc_try
4982 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4983 {
4984 if (scalar_check (unit, 0) == FAILURE)
4985 return FAILURE;
4986
4987 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4988 return FAILURE;
4989
4990 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4991 return FAILURE;
4992 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4993 return FAILURE;
4994
4995 return SUCCESS;
4996 }
4997
4998
4999 gfc_try
5000 gfc_check_isatty (gfc_expr *unit)
5001 {
5002 if (unit == NULL)
5003 return FAILURE;
5004
5005 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
5006 return FAILURE;
5007
5008 if (scalar_check (unit, 0) == FAILURE)
5009 return FAILURE;
5010
5011 return SUCCESS;
5012 }
5013
5014
5015 gfc_try
5016 gfc_check_isnan (gfc_expr *x)
5017 {
5018 if (type_check (x, 0, BT_REAL) == FAILURE)
5019 return FAILURE;
5020
5021 return SUCCESS;
5022 }
5023
5024
5025 gfc_try
5026 gfc_check_perror (gfc_expr *string)
5027 {
5028 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
5029 return FAILURE;
5030 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
5031 return FAILURE;
5032
5033 return SUCCESS;
5034 }
5035
5036
5037 gfc_try
5038 gfc_check_umask (gfc_expr *mask)
5039 {
5040 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5041 return FAILURE;
5042
5043 if (scalar_check (mask, 0) == FAILURE)
5044 return FAILURE;
5045
5046 return SUCCESS;
5047 }
5048
5049
5050 gfc_try
5051 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
5052 {
5053 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5054 return FAILURE;
5055
5056 if (scalar_check (mask, 0) == FAILURE)
5057 return FAILURE;
5058
5059 if (old == NULL)
5060 return SUCCESS;
5061
5062 if (scalar_check (old, 1) == FAILURE)
5063 return FAILURE;
5064
5065 if (type_check (old, 1, BT_INTEGER) == FAILURE)
5066 return FAILURE;
5067
5068 return SUCCESS;
5069 }
5070
5071
5072 gfc_try
5073 gfc_check_unlink (gfc_expr *name)
5074 {
5075 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5076 return FAILURE;
5077 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5078 return FAILURE;
5079
5080 return SUCCESS;
5081 }
5082
5083
5084 gfc_try
5085 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
5086 {
5087 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5088 return FAILURE;
5089 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5090 return FAILURE;
5091
5092 if (status == NULL)
5093 return SUCCESS;
5094
5095 if (scalar_check (status, 1) == FAILURE)
5096 return FAILURE;
5097
5098 if (type_check (status, 1, BT_INTEGER) == FAILURE)
5099 return FAILURE;
5100
5101 return SUCCESS;
5102 }
5103
5104
5105 gfc_try
5106 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
5107 {
5108 if (scalar_check (number, 0) == FAILURE)
5109 return FAILURE;
5110 if (type_check (number, 0, BT_INTEGER) == FAILURE)
5111 return FAILURE;
5112
5113 if (int_or_proc_check (handler, 1) == FAILURE)
5114 return FAILURE;
5115 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5116 return FAILURE;
5117
5118 return SUCCESS;
5119 }
5120
5121
5122 gfc_try
5123 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
5124 {
5125 if (scalar_check (number, 0) == FAILURE)
5126 return FAILURE;
5127 if (type_check (number, 0, BT_INTEGER) == FAILURE)
5128 return FAILURE;
5129
5130 if (int_or_proc_check (handler, 1) == FAILURE)
5131 return FAILURE;
5132 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5133 return FAILURE;
5134
5135 if (status == NULL)
5136 return SUCCESS;
5137
5138 if (type_check (status, 2, BT_INTEGER) == FAILURE)
5139 return FAILURE;
5140 if (scalar_check (status, 2) == FAILURE)
5141 return FAILURE;
5142
5143 return SUCCESS;
5144 }
5145
5146
5147 gfc_try
5148 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
5149 {
5150 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
5151 return FAILURE;
5152 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
5153 return FAILURE;
5154
5155 if (scalar_check (status, 1) == FAILURE)
5156 return FAILURE;
5157
5158 if (type_check (status, 1, BT_INTEGER) == FAILURE)
5159 return FAILURE;
5160
5161 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
5162 return FAILURE;
5163
5164 return SUCCESS;
5165 }
5166
5167
5168 /* This is used for the GNU intrinsics AND, OR and XOR. */
5169 gfc_try
5170 gfc_check_and (gfc_expr *i, gfc_expr *j)
5171 {
5172 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
5173 {
5174 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5175 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
5176 gfc_current_intrinsic, &i->where);
5177 return FAILURE;
5178 }
5179
5180 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
5181 {
5182 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5183 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
5184 gfc_current_intrinsic, &j->where);
5185 return FAILURE;
5186 }
5187
5188 if (i->ts.type != j->ts.type)
5189 {
5190 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5191 "have the same type", gfc_current_intrinsic_arg[0]->name,
5192 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5193 &j->where);
5194 return FAILURE;
5195 }
5196
5197 if (scalar_check (i, 0) == FAILURE)
5198 return FAILURE;
5199
5200 if (scalar_check (j, 1) == FAILURE)
5201 return FAILURE;
5202
5203 return SUCCESS;
5204 }
5205
5206
5207 gfc_try
5208 gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
5209 {
5210 if (kind == NULL)
5211 return SUCCESS;
5212
5213 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
5214 return FAILURE;
5215
5216 if (scalar_check (kind, 1) == FAILURE)
5217 return FAILURE;
5218
5219 if (kind->expr_type != EXPR_CONSTANT)
5220 {
5221 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5222 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5223 &kind->where);
5224 return FAILURE;
5225 }
5226
5227 return SUCCESS;
5228 }
Mirror of https://gcc.gnu.org/git/gcc.git