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