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