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