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