?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
intrinsic.texi: Minor cleanup, reflowing overlong paragraphs, and correcting whitespace.
[official-gcc.git] / gcc / fortran / check.c
blob0c5fc130b5ae0dd7ecb0d1db53169f07a86de551
1 /* Check functions
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
20 02110-1301, USA. */
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
35
36 /* Check the type of an expression. */
37
38 static try
39 type_check (gfc_expr * e, int n, bt type)
40 {
41 if (e->ts.type == type)
42 return SUCCESS;
43
44 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
45 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
46 gfc_basic_typename (type));
47
48 return FAILURE;
49 }
50
51
52 /* Check that the expression is a numeric type. */
53
54 static try
55 numeric_check (gfc_expr * e, int n)
56 {
57 if (gfc_numeric_ts (&e->ts))
58 return SUCCESS;
59
60 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
61 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
62
63 return FAILURE;
64 }
65
66
67 /* Check that an expression is integer or real. */
68
69 static try
70 int_or_real_check (gfc_expr * e, int n)
71 {
72 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
73 {
74 gfc_error (
75 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
76 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
77 return FAILURE;
78 }
79
80 return SUCCESS;
81 }
82
83
84 /* Check that an expression is real or complex. */
85
86 static try
87 real_or_complex_check (gfc_expr * e, int n)
88 {
89 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
90 {
91 gfc_error (
92 "'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
93 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
94 return FAILURE;
95 }
96
97 return SUCCESS;
98 }
99
100
101 /* Check that the expression is an optional constant integer
102 and that it specifies a valid kind for that type. */
103
104 static try
105 kind_check (gfc_expr * k, int n, bt type)
106 {
107 int kind;
108
109 if (k == NULL)
110 return SUCCESS;
111
112 if (type_check (k, n, BT_INTEGER) == FAILURE)
113 return FAILURE;
114
115 if (k->expr_type != EXPR_CONSTANT)
116 {
117 gfc_error (
118 "'%s' argument of '%s' intrinsic at %L must be a constant",
119 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
120 return FAILURE;
121 }
122
123 if (gfc_extract_int (k, &kind) != NULL
124 || gfc_validate_kind (type, kind, true) < 0)
125 {
126 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
127 &k->where);
128 return FAILURE;
129 }
130
131 return SUCCESS;
132 }
133
134
135 /* Make sure the expression is a double precision real. */
136
137 static try
138 double_check (gfc_expr * d, int n)
139 {
140 if (type_check (d, n, BT_REAL) == FAILURE)
141 return FAILURE;
142
143 if (d->ts.kind != gfc_default_double_kind)
144 {
145 gfc_error (
146 "'%s' argument of '%s' intrinsic at %L must be double precision",
147 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
148 return FAILURE;
149 }
150
151 return SUCCESS;
152 }
153
154
155 /* Make sure the expression is a logical array. */
156
157 static try
158 logical_array_check (gfc_expr * array, int n)
159 {
160 if (array->ts.type != BT_LOGICAL || array->rank == 0)
161 {
162 gfc_error (
163 "'%s' argument of '%s' intrinsic at %L must be a logical array",
164 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
165 return FAILURE;
166 }
167
168 return SUCCESS;
169 }
170
171
172 /* Make sure an expression is an array. */
173
174 static try
175 array_check (gfc_expr * e, int n)
176 {
177 if (e->rank != 0)
178 return SUCCESS;
179
180 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
181 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
182
183 return FAILURE;
184 }
185
186
187 /* Make sure an expression is a scalar. */
188
189 static try
190 scalar_check (gfc_expr * e, int n)
191 {
192 if (e->rank == 0)
193 return SUCCESS;
194
195 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
196 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
197
198 return FAILURE;
199 }
200
201
202 /* Make sure two expressions have the same type. */
203
204 static try
205 same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
206 {
207 if (gfc_compare_types (&e->ts, &f->ts))
208 return SUCCESS;
209
210 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
211 "and kind as '%s'", gfc_current_intrinsic_arg[m],
212 gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
213 return FAILURE;
214 }
215
216
217 /* Make sure that an expression has a certain (nonzero) rank. */
218
219 static try
220 rank_check (gfc_expr * e, int n, int rank)
221 {
222 if (e->rank == rank)
223 return SUCCESS;
224
225 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
226 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
227 &e->where, rank);
228 return FAILURE;
229 }
230
231
232 /* Make sure a variable expression is not an optional dummy argument. */
233
234 static try
235 nonoptional_check (gfc_expr * e, int n)
236 {
237 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
238 {
239 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
240 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
241 &e->where);
242
243 }
244
245 /* TODO: Recursive check on nonoptional variables? */
246
247 return SUCCESS;
248 }
249
250
251 /* Check that an expression has a particular kind. */
252
253 static try
254 kind_value_check (gfc_expr * e, int n, int k)
255 {
256 if (e->ts.kind == k)
257 return SUCCESS;
258
259 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
260 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
261 &e->where, k);
262 return FAILURE;
263 }
264
265
266 /* Make sure an expression is a variable. */
267
268 static try
269 variable_check (gfc_expr * e, int n)
270 {
271 if ((e->expr_type == EXPR_VARIABLE
272 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
273 || (e->expr_type == EXPR_FUNCTION
274 && e->symtree->n.sym->result == e->symtree->n.sym))
275 return SUCCESS;
276
277 if (e->expr_type == EXPR_VARIABLE
278 && e->symtree->n.sym->attr.intent == INTENT_IN)
279 {
280 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
281 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
282 &e->where);
283 return FAILURE;
284 }
285
286 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
287 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
288
289 return FAILURE;
290 }
291
292
293 /* Check the common DIM parameter for correctness. */
294
295 static try
296 dim_check (gfc_expr * dim, int n, int optional)
297 {
298 if (optional && dim == NULL)
299 return SUCCESS;
300
301 if (dim == NULL)
302 {
303 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
304 gfc_current_intrinsic, gfc_current_intrinsic_where);
305 return FAILURE;
306 }
307
308 if (type_check (dim, n, BT_INTEGER) == FAILURE)
309 return FAILURE;
310
311 if (scalar_check (dim, n) == FAILURE)
312 return FAILURE;
313
314 if (nonoptional_check (dim, n) == FAILURE)
315 return FAILURE;
316
317 return SUCCESS;
318 }
319
320
321 /* If a DIM parameter is a constant, make sure that it is greater than
322 zero and less than or equal to the rank of the given array. If
323 allow_assumed is zero then dim must be less than the rank of the array
324 for assumed size arrays. */
325
326 static try
327 dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
328 {
329 gfc_array_ref *ar;
330 int rank;
331
332 if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
333 return SUCCESS;
334
335 ar = gfc_find_array_ref (array);
336 rank = array->rank;
337 if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
338 rank--;
339
340 if (mpz_cmp_ui (dim->value.integer, 1) < 0
341 || mpz_cmp_ui (dim->value.integer, rank) > 0)
342 {
343 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
344 "dimension index", gfc_current_intrinsic, &dim->where);
345
346 return FAILURE;
347 }
348
349 return SUCCESS;
350 }
351
352 /* Compare the size of a along dimension ai with the size of b along
353 dimension bi, returning 0 if they are known not to be identical,
354 and 1 if they are identical, or if this cannot be determined. */
355
356 static int
357 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
358 {
359 mpz_t a_size, b_size;
360 int ret;
361
362 gcc_assert (a->rank > ai);
363 gcc_assert (b->rank > bi);
364
365 ret = 1;
366
367 if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
368 {
369 if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
370 {
371 if (mpz_cmp (a_size, b_size) != 0)
372 ret = 0;
373
374 mpz_clear (b_size);
375 }
376 mpz_clear (a_size);
377 }
378 return ret;
379 }
380
381 /* Error return for transformational intrinsics not allowed in
382 initialization expressions. */
383
384 static try
385 non_init_transformational (void)
386 {
387 gfc_error ("transformational intrinsic '%s' at %L is not permitted "
388 "in an initialization expression", gfc_current_intrinsic,
389 gfc_current_intrinsic_where);
390 return FAILURE;
391 }
392
393 /***** Check functions *****/
394
395 /* Check subroutine suitable for intrinsics taking a real argument and
396 a kind argument for the result. */
397
398 static try
399 check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
400 {
401 if (type_check (a, 0, BT_REAL) == FAILURE)
402 return FAILURE;
403 if (kind_check (kind, 1, type) == FAILURE)
404 return FAILURE;
405
406 return SUCCESS;
407 }
408
409 /* Check subroutine suitable for ceiling, floor and nint. */
410
411 try
412 gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
413 {
414 return check_a_kind (a, kind, BT_INTEGER);
415 }
416
417 /* Check subroutine suitable for aint, anint. */
418
419 try
420 gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
421 {
422 return check_a_kind (a, kind, BT_REAL);
423 }
424
425 try
426 gfc_check_abs (gfc_expr * a)
427 {
428 if (numeric_check (a, 0) == FAILURE)
429 return FAILURE;
430
431 return SUCCESS;
432 }
433
434 try
435 gfc_check_achar (gfc_expr * a)
436 {
437
438 if (type_check (a, 0, BT_INTEGER) == FAILURE)
439 return FAILURE;
440
441 return SUCCESS;
442 }
443
444
445 try
446 gfc_check_access_func (gfc_expr * name, gfc_expr * mode)
447 {
448 if (type_check (name, 0, BT_CHARACTER) == FAILURE
449 || scalar_check (name, 0) == FAILURE)
450 return FAILURE;
451
452
453 if (type_check (mode, 1, BT_CHARACTER) == FAILURE
454 || scalar_check (mode, 1) == FAILURE)
455 return FAILURE;
456
457 return SUCCESS;
458 }
459
460
461 try
462 gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
463 {
464 if (logical_array_check (mask, 0) == FAILURE)
465 return FAILURE;
466
467 if (dim_check (dim, 1, 1) == FAILURE)
468 return FAILURE;
469
470 if (gfc_init_expr)
471 return non_init_transformational ();
472
473 return SUCCESS;
474 }
475
476
477 try
478 gfc_check_allocated (gfc_expr * array)
479 {
480 symbol_attribute attr;
481
482 if (variable_check (array, 0) == FAILURE)
483 return FAILURE;
484
485 if (array_check (array, 0) == FAILURE)
486 return FAILURE;
487
488 attr = gfc_variable_attr (array, NULL);
489 if (!attr.allocatable)
490 {
491 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
492 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
493 &array->where);
494 return FAILURE;
495 }
496
497 return SUCCESS;
498 }
499
500
501 /* Common check function where the first argument must be real or
502 integer and the second argument must be the same as the first. */
503
504 try
505 gfc_check_a_p (gfc_expr * a, gfc_expr * p)
506 {
507 if (int_or_real_check (a, 0) == FAILURE)
508 return FAILURE;
509
510 if (a->ts.type != p->ts.type)
511 {
512 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
513 "have the same type", gfc_current_intrinsic_arg[0],
514 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
515 &p->where);
516 return FAILURE;
517 }
518
519 if (a->ts.kind != p->ts.kind)
520 {
521 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
522 &p->where) == FAILURE)
523 return FAILURE;
524 }
525
526 return SUCCESS;
527 }
528
529
530 try
531 gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
532 {
533 symbol_attribute attr;
534 int i;
535 try t;
536 locus *where;
537
538 where = &pointer->where;
539
540 if (pointer->expr_type == EXPR_VARIABLE)
541 attr = gfc_variable_attr (pointer, NULL);
542 else if (pointer->expr_type == EXPR_FUNCTION)
543 attr = pointer->symtree->n.sym->attr;
544 else if (pointer->expr_type == EXPR_NULL)
545 goto null_arg;
546 else
547 gcc_assert (0); /* Pointer must be a variable or a function. */
548
549 if (!attr.pointer)
550 {
551 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
552 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
553 &pointer->where);
554 return FAILURE;
555 }
556
557 /* Target argument is optional. */
558 if (target == NULL)
559 return SUCCESS;
560
561 where = &target->where;
562 if (target->expr_type == EXPR_NULL)
563 goto null_arg;
564
565 if (target->expr_type == EXPR_VARIABLE)
566 attr = gfc_variable_attr (target, NULL);
567 else if (target->expr_type == EXPR_FUNCTION)
568 attr = target->symtree->n.sym->attr;
569 else
570 {
571 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
572 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
573 gfc_current_intrinsic, &target->where);
574 return FAILURE;
575 }
576
577 if (!attr.pointer && !attr.target)
578 {
579 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
580 "or a TARGET", gfc_current_intrinsic_arg[1],
581 gfc_current_intrinsic, &target->where);
582 return FAILURE;
583 }
584
585 t = SUCCESS;
586 if (same_type_check (pointer, 0, target, 1) == FAILURE)
587 t = FAILURE;
588 if (rank_check (target, 0, pointer->rank) == FAILURE)
589 t = FAILURE;
590 if (target->rank > 0)
591 {
592 for (i = 0; i < target->rank; i++)
593 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
594 {
595 gfc_error ("Array section with a vector subscript at %L shall not "
596 "be the target of a pointer",
597 &target->where);
598 t = FAILURE;
599 break;
600 }
601 }
602 return t;
603
604 null_arg:
605
606 gfc_error ("NULL pointer at %L is not permitted as actual argument "
607 "of '%s' intrinsic function", where, gfc_current_intrinsic);
608 return FAILURE;
609
610 }
611
612
613 try
614 gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
615 {
616 if (type_check (y, 0, BT_REAL) == FAILURE)
617 return FAILURE;
618 if (same_type_check (y, 0, x, 1) == FAILURE)
619 return FAILURE;
620
621 return SUCCESS;
622 }
623
624
625 /* BESJN and BESYN functions. */
626
627 try
628 gfc_check_besn (gfc_expr * n, gfc_expr * x)
629 {
630 if (scalar_check (n, 0) == FAILURE)
631 return FAILURE;
632
633 if (type_check (n, 0, BT_INTEGER) == FAILURE)
634 return FAILURE;
635
636 if (scalar_check (x, 1) == FAILURE)
637 return FAILURE;
638
639 if (type_check (x, 1, BT_REAL) == FAILURE)
640 return FAILURE;
641
642 return SUCCESS;
643 }
644
645
646 try
647 gfc_check_btest (gfc_expr * i, gfc_expr * pos)
648 {
649 if (type_check (i, 0, BT_INTEGER) == FAILURE)
650 return FAILURE;
651 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
652 return FAILURE;
653
654 return SUCCESS;
655 }
656
657
658 try
659 gfc_check_char (gfc_expr * i, gfc_expr * kind)
660 {
661 if (type_check (i, 0, BT_INTEGER) == FAILURE)
662 return FAILURE;
663 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
664 return FAILURE;
665
666 return SUCCESS;
667 }
668
669
670 try
671 gfc_check_chdir (gfc_expr * dir)
672 {
673 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
674 return FAILURE;
675
676 return SUCCESS;
677 }
678
679
680 try
681 gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
682 {
683 if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
684 return FAILURE;
685
686 if (status == NULL)
687 return SUCCESS;
688
689 if (type_check (status, 1, BT_INTEGER) == FAILURE)
690 return FAILURE;
691
692 if (scalar_check (status, 1) == FAILURE)
693 return FAILURE;
694
695 return SUCCESS;
696 }
697
698
699 try
700 gfc_check_chmod (gfc_expr * name, gfc_expr * mode)
701 {
702 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
703 return FAILURE;
704
705 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
706 return FAILURE;
707
708 return SUCCESS;
709 }
710
711
712 try
713 gfc_check_chmod_sub (gfc_expr * name, gfc_expr * mode, gfc_expr * status)
714 {
715 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
716 return FAILURE;
717
718 if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
719 return FAILURE;
720
721 if (status == NULL)
722 return SUCCESS;
723
724 if (type_check (status, 2, BT_INTEGER) == FAILURE)
725 return FAILURE;
726
727 if (scalar_check (status, 2) == FAILURE)
728 return FAILURE;
729
730 return SUCCESS;
731 }
732
733
734 try
735 gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
736 {
737 if (numeric_check (x, 0) == FAILURE)
738 return FAILURE;
739
740 if (y != NULL)
741 {
742 if (numeric_check (y, 1) == FAILURE)
743 return FAILURE;
744
745 if (x->ts.type == BT_COMPLEX)
746 {
747 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
748 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
749 gfc_current_intrinsic, &y->where);
750 return FAILURE;
751 }
752 }
753
754 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
755 return FAILURE;
756
757 return SUCCESS;
758 }
759
760
761 try
762 gfc_check_complex (gfc_expr * x, gfc_expr * y)
763 {
764 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
765 {
766 gfc_error (
767 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
768 gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
769 return FAILURE;
770 }
771 if (scalar_check (x, 0) == FAILURE)
772 return FAILURE;
773
774 if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
775 {
776 gfc_error (
777 "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
778 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
779 return FAILURE;
780 }
781 if (scalar_check (y, 1) == FAILURE)
782 return FAILURE;
783
784 return SUCCESS;
785 }
786
787
788 try
789 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
790 {
791 if (logical_array_check (mask, 0) == FAILURE)
792 return FAILURE;
793 if (dim_check (dim, 1, 1) == FAILURE)
794 return FAILURE;
795
796 if (gfc_init_expr)
797 return non_init_transformational ();
798
799 return SUCCESS;
800 }
801
802
803 try
804 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
805 {
806 if (array_check (array, 0) == FAILURE)
807 return FAILURE;
808
809 if (array->rank == 1)
810 {
811 if (scalar_check (shift, 1) == FAILURE)
812 return FAILURE;
813 }
814 else
815 {
816 /* TODO: more requirements on shift parameter. */
817 }
818
819 if (dim_check (dim, 2, 1) == FAILURE)
820 return FAILURE;
821
822 if (gfc_init_expr)
823 return non_init_transformational ();
824
825 return SUCCESS;
826 }
827
828
829 try
830 gfc_check_ctime (gfc_expr * time)
831 {
832 if (scalar_check (time, 0) == FAILURE)
833 return FAILURE;
834
835 if (type_check (time, 0, BT_INTEGER) == FAILURE)
836 return FAILURE;
837
838 return SUCCESS;
839 }
840
841
842 try
843 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
844 {
845 if (numeric_check (x, 0) == FAILURE)
846 return FAILURE;
847
848 if (y != NULL)
849 {
850 if (numeric_check (y, 1) == FAILURE)
851 return FAILURE;
852
853 if (x->ts.type == BT_COMPLEX)
854 {
855 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
856 "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
857 gfc_current_intrinsic, &y->where);
858 return FAILURE;
859 }
860 }
861
862 return SUCCESS;
863 }
864
865
866 try
867 gfc_check_dble (gfc_expr * x)
868 {
869 if (numeric_check (x, 0) == FAILURE)
870 return FAILURE;
871
872 return SUCCESS;
873 }
874
875
876 try
877 gfc_check_digits (gfc_expr * x)
878 {
879 if (int_or_real_check (x, 0) == FAILURE)
880 return FAILURE;
881
882 return SUCCESS;
883 }
884
885
886 try
887 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
888 {
889 switch (vector_a->ts.type)
890 {
891 case BT_LOGICAL:
892 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
893 return FAILURE;
894 break;
895
896 case BT_INTEGER:
897 case BT_REAL:
898 case BT_COMPLEX:
899 if (numeric_check (vector_b, 1) == FAILURE)
900 return FAILURE;
901 break;
902
903 default:
904 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
905 "or LOGICAL", gfc_current_intrinsic_arg[0],
906 gfc_current_intrinsic, &vector_a->where);
907 return FAILURE;
908 }
909
910 if (rank_check (vector_a, 0, 1) == FAILURE)
911 return FAILURE;
912
913 if (rank_check (vector_b, 1, 1) == FAILURE)
914 return FAILURE;
915
916 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
917 {
918 gfc_error ("different shape for arguments '%s' and '%s' "
919 "at %L for intrinsic 'dot_product'",
920 gfc_current_intrinsic_arg[0],
921 gfc_current_intrinsic_arg[1],
922 &vector_a->where);
923 return FAILURE;
924 }
925
926 if (gfc_init_expr)
927 return non_init_transformational ();
928
929 return SUCCESS;
930 }
931
932
933 try
934 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
935 gfc_expr * dim)
936 {
937 if (array_check (array, 0) == FAILURE)
938 return FAILURE;
939
940 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
941 return FAILURE;
942
943 if (array->rank == 1)
944 {
945 if (scalar_check (shift, 2) == FAILURE)
946 return FAILURE;
947 }
948 else
949 {
950 /* TODO: more weird restrictions on shift. */
951 }
952
953 if (boundary != NULL)
954 {
955 if (same_type_check (array, 0, boundary, 2) == FAILURE)
956 return FAILURE;
957
958 /* TODO: more restrictions on boundary. */
959 }
960
961 if (dim_check (dim, 1, 1) == FAILURE)
962 return FAILURE;
963
964 if (gfc_init_expr)
965 return non_init_transformational ();
966
967 return SUCCESS;
968 }
969
970
971 /* A single complex argument. */
972
973 try
974 gfc_check_fn_c (gfc_expr * a)
975 {
976 if (type_check (a, 0, BT_COMPLEX) == FAILURE)
977 return FAILURE;
978
979 return SUCCESS;
980 }
981
982
983 /* A single real argument. */
984
985 try
986 gfc_check_fn_r (gfc_expr * a)
987 {
988 if (type_check (a, 0, BT_REAL) == FAILURE)
989 return FAILURE;
990
991 return SUCCESS;
992 }
993
994
995 /* A single real or complex argument. */
996
997 try
998 gfc_check_fn_rc (gfc_expr * a)
999 {
1000 if (real_or_complex_check (a, 0) == FAILURE)
1001 return FAILURE;
1002
1003 return SUCCESS;
1004 }
1005
1006
1007 try
1008 gfc_check_fnum (gfc_expr * unit)
1009 {
1010 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1011 return FAILURE;
1012
1013 if (scalar_check (unit, 0) == FAILURE)
1014 return FAILURE;
1015
1016 return SUCCESS;
1017 }
1018
1019
1020 /* This is used for the g77 one-argument Bessel functions, and the
1021 error function. */
1022
1023 try
1024 gfc_check_g77_math1 (gfc_expr * x)
1025 {
1026 if (scalar_check (x, 0) == FAILURE)
1027 return FAILURE;
1028
1029 if (type_check (x, 0, BT_REAL) == FAILURE)
1030 return FAILURE;
1031
1032 return SUCCESS;
1033 }
1034
1035
1036 try
1037 gfc_check_huge (gfc_expr * x)
1038 {
1039 if (int_or_real_check (x, 0) == FAILURE)
1040 return FAILURE;
1041
1042 return SUCCESS;
1043 }
1044
1045
1046 /* Check that the single argument is an integer. */
1047
1048 try
1049 gfc_check_i (gfc_expr * i)
1050 {
1051 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1052 return FAILURE;
1053
1054 return SUCCESS;
1055 }
1056
1057
1058 try
1059 gfc_check_iand (gfc_expr * i, gfc_expr * j)
1060 {
1061 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1062 return FAILURE;
1063
1064 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1065 return FAILURE;
1066
1067 if (i->ts.kind != j->ts.kind)
1068 {
1069 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1070 &i->where) == FAILURE)
1071 return FAILURE;
1072 }
1073
1074 return SUCCESS;
1075 }
1076
1077
1078 try
1079 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
1080 {
1081 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1082 return FAILURE;
1083
1084 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1085 return FAILURE;
1086
1087 return SUCCESS;
1088 }
1089
1090
1091 try
1092 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
1093 {
1094 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1095 return FAILURE;
1096
1097 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1098 return FAILURE;
1099
1100 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1101 return FAILURE;
1102
1103 return SUCCESS;
1104 }
1105
1106
1107 try
1108 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
1109 {
1110 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1111 return FAILURE;
1112
1113 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1114 return FAILURE;
1115
1116 return SUCCESS;
1117 }
1118
1119
1120 try
1121 gfc_check_ichar_iachar (gfc_expr * c)
1122 {
1123 int i;
1124
1125 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1126 return FAILURE;
1127
1128 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1129 {
1130 gfc_expr *start;
1131 gfc_expr *end;
1132 gfc_ref *ref;
1133
1134 /* Substring references don't have the charlength set. */
1135 ref = c->ref;
1136 while (ref && ref->type != REF_SUBSTRING)
1137 ref = ref->next;
1138
1139 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1140
1141 if (!ref)
1142 {
1143 /* Check that the argument is length one. Non-constant lengths
1144 can't be checked here, so assume they are ok. */
1145 if (c->ts.cl && c->ts.cl->length)
1146 {
1147 /* If we already have a length for this expression then use it. */
1148 if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1149 return SUCCESS;
1150 i = mpz_get_si (c->ts.cl->length->value.integer);
1151 }
1152 else
1153 return SUCCESS;
1154 }
1155 else
1156 {
1157 start = ref->u.ss.start;
1158 end = ref->u.ss.end;
1159
1160 gcc_assert (start);
1161 if (end == NULL || end->expr_type != EXPR_CONSTANT
1162 || start->expr_type != EXPR_CONSTANT)
1163 return SUCCESS;
1164
1165 i = mpz_get_si (end->value.integer) + 1
1166 - mpz_get_si (start->value.integer);
1167 }
1168 }
1169 else
1170 return SUCCESS;
1171
1172 if (i != 1)
1173 {
1174 gfc_error ("Argument of %s at %L must be of length one",
1175 gfc_current_intrinsic, &c->where);
1176 return FAILURE;
1177 }
1178
1179 return SUCCESS;
1180 }
1181
1182
1183 try
1184 gfc_check_idnint (gfc_expr * a)
1185 {
1186 if (double_check (a, 0) == FAILURE)
1187 return FAILURE;
1188
1189 return SUCCESS;
1190 }
1191
1192
1193 try
1194 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
1195 {
1196 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1197 return FAILURE;
1198
1199 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1200 return FAILURE;
1201
1202 if (i->ts.kind != j->ts.kind)
1203 {
1204 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1205 &i->where) == FAILURE)
1206 return FAILURE;
1207 }
1208
1209 return SUCCESS;
1210 }
1211
1212
1213 try
1214 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
1215 {
1216 if (type_check (string, 0, BT_CHARACTER) == FAILURE
1217 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1218 return FAILURE;
1219
1220
1221 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1222 return FAILURE;
1223
1224 if (string->ts.kind != substring->ts.kind)
1225 {
1226 gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1227 "kind as '%s'", gfc_current_intrinsic_arg[1],
1228 gfc_current_intrinsic, &substring->where,
1229 gfc_current_intrinsic_arg[0]);
1230 return FAILURE;
1231 }
1232
1233 return SUCCESS;
1234 }
1235
1236
1237 try
1238 gfc_check_int (gfc_expr * x, gfc_expr * kind)
1239 {
1240 if (numeric_check (x, 0) == FAILURE)
1241 return FAILURE;
1242
1243 if (kind != NULL)
1244 {
1245 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1246 return FAILURE;
1247
1248 if (scalar_check (kind, 1) == FAILURE)
1249 return FAILURE;
1250 }
1251
1252 return SUCCESS;
1253 }
1254
1255
1256 try
1257 gfc_check_intconv (gfc_expr * x)
1258 {
1259 if (numeric_check (x, 0) == FAILURE)
1260 return FAILURE;
1261
1262 return SUCCESS;
1263 }
1264
1265
1266 try
1267 gfc_check_ior (gfc_expr * i, gfc_expr * j)
1268 {
1269 if (type_check (i, 0, BT_INTEGER) == FAILURE)
1270 return FAILURE;
1271
1272 if (type_check (j, 1, BT_INTEGER) == FAILURE)
1273 return FAILURE;
1274
1275 if (i->ts.kind != j->ts.kind)
1276 {
1277 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1278 &i->where) == FAILURE)
1279 return FAILURE;
1280 }
1281
1282 return SUCCESS;
1283 }
1284
1285
1286 try
1287 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
1288 {
1289 if (type_check (i, 0, BT_INTEGER) == FAILURE
1290 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1291 return FAILURE;
1292
1293 return SUCCESS;
1294 }
1295
1296
1297 try
1298 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
1299 {
1300 if (type_check (i, 0, BT_INTEGER) == FAILURE
1301 || type_check (shift, 1, BT_INTEGER) == FAILURE)
1302 return FAILURE;
1303
1304 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1305 return FAILURE;
1306
1307 return SUCCESS;
1308 }
1309
1310
1311 try
1312 gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
1313 {
1314 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1315 return FAILURE;
1316
1317 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1318 return FAILURE;
1319
1320 return SUCCESS;
1321 }
1322
1323
1324 try
1325 gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
1326 {
1327 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1328 return FAILURE;
1329
1330 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1331 return FAILURE;
1332
1333 if (status == NULL)
1334 return SUCCESS;
1335
1336 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1337 return FAILURE;
1338
1339 if (scalar_check (status, 2) == FAILURE)
1340 return FAILURE;
1341
1342 return SUCCESS;
1343 }
1344
1345
1346 try
1347 gfc_check_kind (gfc_expr * x)
1348 {
1349 if (x->ts.type == BT_DERIVED)
1350 {
1351 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1352 "non-derived type", gfc_current_intrinsic_arg[0],
1353 gfc_current_intrinsic, &x->where);
1354 return FAILURE;
1355 }
1356
1357 return SUCCESS;
1358 }
1359
1360
1361 try
1362 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1363 {
1364 if (array_check (array, 0) == FAILURE)
1365 return FAILURE;
1366
1367 if (dim != NULL)
1368 {
1369 if (dim_check (dim, 1, 1) == FAILURE)
1370 return FAILURE;
1371
1372 if (dim_rank_check (dim, array, 1) == FAILURE)
1373 return FAILURE;
1374 }
1375 return SUCCESS;
1376 }
1377
1378
1379 try
1380 gfc_check_link (gfc_expr * path1, gfc_expr * path2)
1381 {
1382 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1383 return FAILURE;
1384
1385 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1386 return FAILURE;
1387
1388 return SUCCESS;
1389 }
1390
1391
1392 try
1393 gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1394 {
1395 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1396 return FAILURE;
1397
1398 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1399 return FAILURE;
1400
1401 if (status == NULL)
1402 return SUCCESS;
1403
1404 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1405 return FAILURE;
1406
1407 if (scalar_check (status, 2) == FAILURE)
1408 return FAILURE;
1409
1410 return SUCCESS;
1411 }
1412
1413 try
1414 gfc_check_loc (gfc_expr *expr)
1415 {
1416 return variable_check (expr, 0);
1417 }
1418
1419
1420 try
1421 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
1422 {
1423 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1424 return FAILURE;
1425
1426 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1427 return FAILURE;
1428
1429 return SUCCESS;
1430 }
1431
1432
1433 try
1434 gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1435 {
1436 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1437 return FAILURE;
1438
1439 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1440 return FAILURE;
1441
1442 if (status == NULL)
1443 return SUCCESS;
1444
1445 if (type_check (status, 2, BT_INTEGER) == FAILURE)
1446 return FAILURE;
1447
1448 if (scalar_check (status, 2) == FAILURE)
1449 return FAILURE;
1450
1451 return SUCCESS;
1452 }
1453
1454
1455 try
1456 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1457 {
1458 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1459 return FAILURE;
1460 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1461 return FAILURE;
1462
1463 return SUCCESS;
1464 }
1465
1466
1467 /* Min/max family. */
1468
1469 static try
1470 min_max_args (gfc_actual_arglist * arg)
1471 {
1472 if (arg == NULL || arg->next == NULL)
1473 {
1474 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1475 gfc_current_intrinsic, gfc_current_intrinsic_where);
1476 return FAILURE;
1477 }
1478
1479 return SUCCESS;
1480 }
1481
1482
1483 static try
1484 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1485 {
1486 gfc_expr *x;
1487 int n;
1488
1489 if (min_max_args (arg) == FAILURE)
1490 return FAILURE;
1491
1492 n = 1;
1493
1494 for (; arg; arg = arg->next, n++)
1495 {
1496 x = arg->expr;
1497 if (x->ts.type != type || x->ts.kind != kind)
1498 {
1499 if (x->ts.type == type)
1500 {
1501 if (gfc_notify_std (GFC_STD_GNU,
1502 "Extension: Different type kinds at %L", &x->where)
1503 == FAILURE)
1504 return FAILURE;
1505 }
1506 else
1507 {
1508 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1509 n, gfc_current_intrinsic, &x->where,
1510 gfc_basic_typename (type), kind);
1511 return FAILURE;
1512 }
1513 }
1514 }
1515
1516 return SUCCESS;
1517 }
1518
1519
1520 try
1521 gfc_check_min_max (gfc_actual_arglist * arg)
1522 {
1523 gfc_expr *x;
1524
1525 if (min_max_args (arg) == FAILURE)
1526 return FAILURE;
1527
1528 x = arg->expr;
1529
1530 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1531 {
1532 gfc_error
1533 ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1534 gfc_current_intrinsic, &x->where);
1535 return FAILURE;
1536 }
1537
1538 return check_rest (x->ts.type, x->ts.kind, arg);
1539 }
1540
1541
1542 try
1543 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1544 {
1545 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1546 }
1547
1548
1549 try
1550 gfc_check_min_max_real (gfc_actual_arglist * arg)
1551 {
1552 return check_rest (BT_REAL, gfc_default_real_kind, arg);
1553 }
1554
1555
1556 try
1557 gfc_check_min_max_double (gfc_actual_arglist * arg)
1558 {
1559 return check_rest (BT_REAL, gfc_default_double_kind, arg);
1560 }
1561
1562 /* End of min/max family. */
1563
1564 try
1565 gfc_check_malloc (gfc_expr * size)
1566 {
1567 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1568 return FAILURE;
1569
1570 if (scalar_check (size, 0) == FAILURE)
1571 return FAILURE;
1572
1573 return SUCCESS;
1574 }
1575
1576
1577 try
1578 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1579 {
1580 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1581 {
1582 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1583 "or LOGICAL", gfc_current_intrinsic_arg[0],
1584 gfc_current_intrinsic, &matrix_a->where);
1585 return FAILURE;
1586 }
1587
1588 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1589 {
1590 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1591 "or LOGICAL", gfc_current_intrinsic_arg[1],
1592 gfc_current_intrinsic, &matrix_b->where);
1593 return FAILURE;
1594 }
1595
1596 switch (matrix_a->rank)
1597 {
1598 case 1:
1599 if (rank_check (matrix_b, 1, 2) == FAILURE)
1600 return FAILURE;
1601 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
1602 if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1603 {
1604 gfc_error ("different shape on dimension 1 for arguments '%s' "
1605 "and '%s' at %L for intrinsic matmul",
1606 gfc_current_intrinsic_arg[0],
1607 gfc_current_intrinsic_arg[1],
1608 &matrix_a->where);
1609 return FAILURE;
1610 }
1611 break;
1612
1613 case 2:
1614 if (matrix_b->rank != 2)
1615 {
1616 if (rank_check (matrix_b, 1, 1) == FAILURE)
1617 return FAILURE;
1618 }
1619 /* matrix_b has rank 1 or 2 here. Common check for the cases
1620 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1621 - matrix_a has shape (n,m) and matrix_b has shape (m). */
1622 if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1623 {
1624 gfc_error ("different shape on dimension 2 for argument '%s' and "
1625 "dimension 1 for argument '%s' at %L for intrinsic "
1626 "matmul", gfc_current_intrinsic_arg[0],
1627 gfc_current_intrinsic_arg[1], &matrix_a->where);
1628 return FAILURE;
1629 }
1630 break;
1631
1632 default:
1633 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1634 "1 or 2", gfc_current_intrinsic_arg[0],
1635 gfc_current_intrinsic, &matrix_a->where);
1636 return FAILURE;
1637 }
1638
1639 if (gfc_init_expr)
1640 return non_init_transformational ();
1641
1642 return SUCCESS;
1643 }
1644
1645
1646 /* Whoever came up with this interface was probably on something.
1647 The possibilities for the occupation of the second and third
1648 parameters are:
1649
1650 Arg #2 Arg #3
1651 NULL NULL
1652 DIM NULL
1653 MASK NULL
1654 NULL MASK minloc(array, mask=m)
1655 DIM MASK
1656
1657 I.e. in the case of minloc(array,mask), mask will be in the second
1658 position of the argument list and we'll have to fix that up. */
1659
1660 try
1661 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1662 {
1663 gfc_expr *a, *m, *d;
1664
1665 a = ap->expr;
1666 if (int_or_real_check (a, 0) == FAILURE
1667 || array_check (a, 0) == FAILURE)
1668 return FAILURE;
1669
1670 d = ap->next->expr;
1671 m = ap->next->next->expr;
1672
1673 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1674 && ap->next->name == NULL)
1675 {
1676 m = d;
1677 d = NULL;
1678
1679 ap->next->expr = NULL;
1680 ap->next->next->expr = m;
1681 }
1682
1683 if (dim_check (d, 1, 1) == FAILURE)
1684 return FAILURE;
1685
1686 if (d && dim_rank_check (d, a, 0) == FAILURE)
1687 return FAILURE;
1688
1689 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1690 return FAILURE;
1691
1692 if (m != NULL)
1693 {
1694 char buffer[80];
1695 snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1696 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1697 gfc_current_intrinsic);
1698 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1699 return FAILURE;
1700 }
1701
1702 if (gfc_init_expr)
1703 return non_init_transformational ();
1704
1705 return SUCCESS;
1706 }
1707
1708
1709 /* Similar to minloc/maxloc, the argument list might need to be
1710 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
1711 difference is that MINLOC/MAXLOC take an additional KIND argument.
1712 The possibilities are:
1713
1714 Arg #2 Arg #3
1715 NULL NULL
1716 DIM NULL
1717 MASK NULL
1718 NULL MASK minval(array, mask=m)
1719 DIM MASK
1720
1721 I.e. in the case of minval(array,mask), mask will be in the second
1722 position of the argument list and we'll have to fix that up. */
1723
1724 static try
1725 check_reduction (gfc_actual_arglist * ap)
1726 {
1727 gfc_expr *a, *m, *d;
1728
1729 a = ap->expr;
1730 d = ap->next->expr;
1731 m = ap->next->next->expr;
1732
1733 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1734 && ap->next->name == NULL)
1735 {
1736 m = d;
1737 d = NULL;
1738
1739 ap->next->expr = NULL;
1740 ap->next->next->expr = m;
1741 }
1742
1743 if (dim_check (d, 1, 1) == FAILURE)
1744 return FAILURE;
1745
1746 if (d && dim_rank_check (d, a, 0) == FAILURE)
1747 return FAILURE;
1748
1749 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1750 return FAILURE;
1751
1752 if (m != NULL)
1753 {
1754 char buffer[80];
1755 snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1756 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1757 gfc_current_intrinsic);
1758 if (gfc_check_conformance (buffer, a, m) == FAILURE)
1759 return FAILURE;
1760 }
1761
1762 return SUCCESS;
1763 }
1764
1765
1766 try
1767 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1768 {
1769 if (int_or_real_check (ap->expr, 0) == FAILURE
1770 || array_check (ap->expr, 0) == FAILURE)
1771 return FAILURE;
1772
1773 if (gfc_init_expr)
1774 return non_init_transformational ();
1775
1776 return check_reduction (ap);
1777 }
1778
1779
1780 try
1781 gfc_check_product_sum (gfc_actual_arglist * ap)
1782 {
1783 if (numeric_check (ap->expr, 0) == FAILURE
1784 || array_check (ap->expr, 0) == FAILURE)
1785 return FAILURE;
1786
1787 if (gfc_init_expr)
1788 return non_init_transformational ();
1789
1790 return check_reduction (ap);
1791 }
1792
1793
1794 try
1795 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1796 {
1797 char buffer[80];
1798
1799 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1800 return FAILURE;
1801
1802 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1803 return FAILURE;
1804
1805 snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1806 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1807 gfc_current_intrinsic);
1808 if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
1809 return FAILURE;
1810
1811 snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1812 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1813 gfc_current_intrinsic);
1814 if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
1815 return FAILURE;
1816
1817 return SUCCESS;
1818 }
1819
1820 try
1821 gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
1822 {
1823 symbol_attribute attr;
1824
1825 if (variable_check (from, 0) == FAILURE)
1826 return FAILURE;
1827
1828 if (array_check (from, 0) == FAILURE)
1829 return FAILURE;
1830
1831 attr = gfc_variable_attr (from, NULL);
1832 if (!attr.allocatable)
1833 {
1834 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1835 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1836 &from->where);
1837 return FAILURE;
1838 }
1839
1840 if (variable_check (to, 0) == FAILURE)
1841 return FAILURE;
1842
1843 if (array_check (to, 0) == FAILURE)
1844 return FAILURE;
1845
1846 attr = gfc_variable_attr (to, NULL);
1847 if (!attr.allocatable)
1848 {
1849 gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1850 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1851 &to->where);
1852 return FAILURE;
1853 }
1854
1855 if (same_type_check (from, 0, to, 1) == FAILURE)
1856 return FAILURE;
1857
1858 if (to->rank != from->rank)
1859 {
1860 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1861 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1862 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1863 &to->where, from->rank, to->rank);
1864 return FAILURE;
1865 }
1866
1867 if (to->ts.kind != from->ts.kind)
1868 {
1869 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1870 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1871 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1872 &to->where, from->ts.kind, to->ts.kind);
1873 return FAILURE;
1874 }
1875
1876 return SUCCESS;
1877 }
1878
1879 try
1880 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1881 {
1882 if (type_check (x, 0, BT_REAL) == FAILURE)
1883 return FAILURE;
1884
1885 if (type_check (s, 1, BT_REAL) == FAILURE)
1886 return FAILURE;
1887
1888 return SUCCESS;
1889 }
1890
1891 try
1892 gfc_check_new_line (gfc_expr * a)
1893 {
1894 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1895 return FAILURE;
1896
1897 return SUCCESS;
1898 }
1899
1900 try
1901 gfc_check_null (gfc_expr * mold)
1902 {
1903 symbol_attribute attr;
1904
1905 if (mold == NULL)
1906 return SUCCESS;
1907
1908 if (variable_check (mold, 0) == FAILURE)
1909 return FAILURE;
1910
1911 attr = gfc_variable_attr (mold, NULL);
1912
1913 if (!attr.pointer)
1914 {
1915 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1916 gfc_current_intrinsic_arg[0],
1917 gfc_current_intrinsic, &mold->where);
1918 return FAILURE;
1919 }
1920
1921 return SUCCESS;
1922 }
1923
1924
1925 try
1926 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1927 {
1928 char buffer[80];
1929
1930 if (array_check (array, 0) == FAILURE)
1931 return FAILURE;
1932
1933 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1934 return FAILURE;
1935
1936 snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1937 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1938 gfc_current_intrinsic);
1939 if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1940 return FAILURE;
1941
1942 if (vector != NULL)
1943 {
1944 if (same_type_check (array, 0, vector, 2) == FAILURE)
1945 return FAILURE;
1946
1947 if (rank_check (vector, 2, 1) == FAILURE)
1948 return FAILURE;
1949
1950 /* TODO: More constraints here. */
1951 }
1952
1953 if (gfc_init_expr)
1954 return non_init_transformational ();
1955
1956 return SUCCESS;
1957 }
1958
1959
1960 try
1961 gfc_check_precision (gfc_expr * x)
1962 {
1963 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1964 {
1965 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1966 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1967 gfc_current_intrinsic, &x->where);
1968 return FAILURE;
1969 }
1970
1971 return SUCCESS;
1972 }
1973
1974
1975 try
1976 gfc_check_present (gfc_expr * a)
1977 {
1978 gfc_symbol *sym;
1979
1980 if (variable_check (a, 0) == FAILURE)
1981 return FAILURE;
1982
1983 sym = a->symtree->n.sym;
1984 if (!sym->attr.dummy)
1985 {
1986 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1987 "dummy variable", gfc_current_intrinsic_arg[0],
1988 gfc_current_intrinsic, &a->where);
1989 return FAILURE;
1990 }
1991
1992 if (!sym->attr.optional)
1993 {
1994 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1995 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1996 gfc_current_intrinsic, &a->where);
1997 return FAILURE;
1998 }
1999
2000 /* 13.14.82 PRESENT(A)
2001 ......
2002 Argument. A shall be the name of an optional dummy argument that is accessible
2003 in the subprogram in which the PRESENT function reference appears... */
2004
2005 if (a->ref != NULL
2006 && !(a->ref->next == NULL
2007 && a->ref->type == REF_ARRAY
2008 && a->ref->u.ar.type == AR_FULL))
2009 {
2010 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-"
2011 "object of '%s'", gfc_current_intrinsic_arg[0],
2012 gfc_current_intrinsic, &a->where, sym->name);
2013 return FAILURE;
2014 }
2015
2016 return SUCCESS;
2017 }
2018
2019
2020 try
2021 gfc_check_radix (gfc_expr * x)
2022 {
2023 if (int_or_real_check (x, 0) == FAILURE)
2024 return FAILURE;
2025
2026 return SUCCESS;
2027 }
2028
2029
2030 try
2031 gfc_check_range (gfc_expr * x)
2032 {
2033 if (numeric_check (x, 0) == FAILURE)
2034 return FAILURE;
2035
2036 return SUCCESS;
2037 }
2038
2039
2040 /* real, float, sngl. */
2041 try
2042 gfc_check_real (gfc_expr * a, gfc_expr * kind)
2043 {
2044 if (numeric_check (a, 0) == FAILURE)
2045 return FAILURE;
2046
2047 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2048 return FAILURE;
2049
2050 return SUCCESS;
2051 }
2052
2053
2054 try
2055 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
2056 {
2057 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2058 return FAILURE;
2059
2060 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2061 return FAILURE;
2062
2063 return SUCCESS;
2064 }
2065
2066
2067 try
2068 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
2069 {
2070 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2071 return FAILURE;
2072
2073 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2074 return FAILURE;
2075
2076 if (status == NULL)
2077 return SUCCESS;
2078
2079 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2080 return FAILURE;
2081
2082 if (scalar_check (status, 2) == FAILURE)
2083 return FAILURE;
2084
2085 return SUCCESS;
2086 }
2087
2088
2089 try
2090 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
2091 {
2092 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2093 return FAILURE;
2094
2095 if (scalar_check (x, 0) == FAILURE)
2096 return FAILURE;
2097
2098 if (type_check (y, 0, BT_INTEGER) == FAILURE)
2099 return FAILURE;
2100
2101 if (scalar_check (y, 1) == FAILURE)
2102 return FAILURE;
2103
2104 return SUCCESS;
2105 }
2106
2107
2108 try
2109 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
2110 gfc_expr * pad, gfc_expr * order)
2111 {
2112 mpz_t size;
2113 mpz_t nelems;
2114 int m;
2115
2116 if (array_check (source, 0) == FAILURE)
2117 return FAILURE;
2118
2119 if (rank_check (shape, 1, 1) == FAILURE)
2120 return FAILURE;
2121
2122 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2123 return FAILURE;
2124
2125 if (gfc_array_size (shape, &size) != SUCCESS)
2126 {
2127 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2128 "array of constant size", &shape->where);
2129 return FAILURE;
2130 }
2131
2132 m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2133 mpz_clear (size);
2134
2135 if (m > 0)
2136 {
2137 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2138 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2139 return FAILURE;
2140 }
2141
2142 if (pad != NULL)
2143 {
2144 if (same_type_check (source, 0, pad, 2) == FAILURE)
2145 return FAILURE;
2146 if (array_check (pad, 2) == FAILURE)
2147 return FAILURE;
2148 }
2149
2150 if (order != NULL && array_check (order, 3) == FAILURE)
2151 return FAILURE;
2152
2153 if (pad == NULL
2154 && shape->expr_type == EXPR_ARRAY
2155 && gfc_is_constant_expr (shape)
2156 && !(source->expr_type == EXPR_VARIABLE
2157 && source->symtree->n.sym->as
2158 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2159 {
2160 /* Check the match in size between source and destination. */
2161 if (gfc_array_size (source, &nelems) == SUCCESS)
2162 {
2163 gfc_constructor *c;
2164 bool test;
2165
2166 c = shape->value.constructor;
2167 mpz_init_set_ui (size, 1);
2168 for (; c; c = c->next)
2169 mpz_mul (size, size, c->expr->value.integer);
2170
2171 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2172 mpz_clear (nelems);
2173 mpz_clear (size);
2174
2175 if (test)
2176 {
2177 gfc_error ("Without padding, there are not enough elements in the "
2178 "intrinsic RESHAPE source at %L to match the shape",
2179 &source->where);
2180 return FAILURE;
2181 }
2182 }
2183 }
2184
2185 return SUCCESS;
2186 }
2187
2188
2189 try
2190 gfc_check_scale (gfc_expr * x, gfc_expr * i)
2191 {
2192 if (type_check (x, 0, BT_REAL) == FAILURE)
2193 return FAILURE;
2194
2195 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2196 return FAILURE;
2197
2198 return SUCCESS;
2199 }
2200
2201
2202 try
2203 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2204 {
2205 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2206 return FAILURE;
2207
2208 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2209 return FAILURE;
2210
2211 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2212 return FAILURE;
2213
2214 if (same_type_check (x, 0, y, 1) == FAILURE)
2215 return FAILURE;
2216
2217 return SUCCESS;
2218 }
2219
2220
2221 try
2222 gfc_check_secnds (gfc_expr * r)
2223 {
2224
2225 if (type_check (r, 0, BT_REAL) == FAILURE)
2226 return FAILURE;
2227
2228 if (kind_value_check (r, 0, 4) == FAILURE)
2229 return FAILURE;
2230
2231 if (scalar_check (r, 0) == FAILURE)
2232 return FAILURE;
2233
2234 return SUCCESS;
2235 }
2236
2237
2238 try
2239 gfc_check_selected_int_kind (gfc_expr * r)
2240 {
2241
2242 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2243 return FAILURE;
2244
2245 if (scalar_check (r, 0) == FAILURE)
2246 return FAILURE;
2247
2248 return SUCCESS;
2249 }
2250
2251
2252 try
2253 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
2254 {
2255 if (p == NULL && r == NULL)
2256 {
2257 gfc_error ("Missing arguments to %s intrinsic at %L",
2258 gfc_current_intrinsic, gfc_current_intrinsic_where);
2259
2260 return FAILURE;
2261 }
2262
2263 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2264 return FAILURE;
2265
2266 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2267 return FAILURE;
2268
2269 return SUCCESS;
2270 }
2271
2272
2273 try
2274 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
2275 {
2276 if (type_check (x, 0, BT_REAL) == FAILURE)
2277 return FAILURE;
2278
2279 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2280 return FAILURE;
2281
2282 return SUCCESS;
2283 }
2284
2285
2286 try
2287 gfc_check_shape (gfc_expr * source)
2288 {
2289 gfc_array_ref *ar;
2290
2291 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2292 return SUCCESS;
2293
2294 ar = gfc_find_array_ref (source);
2295
2296 if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2297 {
2298 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2299 "an assumed size array", &source->where);
2300 return FAILURE;
2301 }
2302
2303 return SUCCESS;
2304 }
2305
2306
2307 try
2308 gfc_check_sign (gfc_expr * a, gfc_expr * b)
2309 {
2310 if (int_or_real_check (a, 0) == FAILURE)
2311 return FAILURE;
2312
2313 if (same_type_check (a, 0, b, 1) == FAILURE)
2314 return FAILURE;
2315
2316 return SUCCESS;
2317 }
2318
2319
2320 try
2321 gfc_check_size (gfc_expr * array, gfc_expr * dim)
2322 {
2323 if (array_check (array, 0) == FAILURE)
2324 return FAILURE;
2325
2326 if (dim != NULL)
2327 {
2328 if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2329 return FAILURE;
2330
2331 if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2332 return FAILURE;
2333
2334 if (dim_rank_check (dim, array, 0) == FAILURE)
2335 return FAILURE;
2336 }
2337
2338 return SUCCESS;
2339 }
2340
2341
2342 try
2343 gfc_check_sleep_sub (gfc_expr * seconds)
2344 {
2345 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2346 return FAILURE;
2347
2348 if (scalar_check (seconds, 0) == FAILURE)
2349 return FAILURE;
2350
2351 return SUCCESS;
2352 }
2353
2354
2355 try
2356 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
2357 {
2358 if (source->rank >= GFC_MAX_DIMENSIONS)
2359 {
2360 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2361 "than rank %d", gfc_current_intrinsic_arg[0],
2362 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2363
2364 return FAILURE;
2365 }
2366
2367 if (dim_check (dim, 1, 0) == FAILURE)
2368 return FAILURE;
2369
2370 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2371 return FAILURE;
2372
2373 if (scalar_check (ncopies, 2) == FAILURE)
2374 return FAILURE;
2375
2376 if (gfc_init_expr)
2377 return non_init_transformational ();
2378
2379 return SUCCESS;
2380 }
2381
2382
2383 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2384 functions). */
2385 try
2386 gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
2387 {
2388 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2389 return FAILURE;
2390
2391 if (scalar_check (unit, 0) == FAILURE)
2392 return FAILURE;
2393
2394 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2395 return FAILURE;
2396
2397 if (status == NULL)
2398 return SUCCESS;
2399
2400 if (type_check (status, 2, BT_INTEGER) == FAILURE
2401 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2402 || scalar_check (status, 2) == FAILURE)
2403 return FAILURE;
2404
2405 return SUCCESS;
2406 }
2407
2408
2409 try
2410 gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
2411 {
2412 return gfc_check_fgetputc_sub (unit, c, NULL);
2413 }
2414
2415
2416 try
2417 gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
2418 {
2419 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2420 return FAILURE;
2421
2422 if (status == NULL)
2423 return SUCCESS;
2424
2425 if (type_check (status, 1, BT_INTEGER) == FAILURE
2426 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2427 || scalar_check (status, 1) == FAILURE)
2428 return FAILURE;
2429
2430 return SUCCESS;
2431 }
2432
2433
2434 try
2435 gfc_check_fgetput (gfc_expr * c)
2436 {
2437 return gfc_check_fgetput_sub (c, NULL);
2438 }
2439
2440
2441 try
2442 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2443 {
2444 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2445 return FAILURE;
2446
2447 if (scalar_check (unit, 0) == FAILURE)
2448 return FAILURE;
2449
2450 if (type_check (array, 1, BT_INTEGER) == FAILURE
2451 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2452 return FAILURE;
2453
2454 if (array_check (array, 1) == FAILURE)
2455 return FAILURE;
2456
2457 return SUCCESS;
2458 }
2459
2460
2461 try
2462 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2463 {
2464 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2465 return FAILURE;
2466
2467 if (scalar_check (unit, 0) == FAILURE)
2468 return FAILURE;
2469
2470 if (type_check (array, 1, BT_INTEGER) == FAILURE
2471 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2472 return FAILURE;
2473
2474 if (array_check (array, 1) == FAILURE)
2475 return FAILURE;
2476
2477 if (status == NULL)
2478 return SUCCESS;
2479
2480 if (type_check (status, 2, BT_INTEGER) == FAILURE
2481 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2482 return FAILURE;
2483
2484 if (scalar_check (status, 2) == FAILURE)
2485 return FAILURE;
2486
2487 return SUCCESS;
2488 }
2489
2490
2491 try
2492 gfc_check_ftell (gfc_expr * unit)
2493 {
2494 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2495 return FAILURE;
2496
2497 if (scalar_check (unit, 0) == FAILURE)
2498 return FAILURE;
2499
2500 return SUCCESS;
2501 }
2502
2503
2504 try
2505 gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
2506 {
2507 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2508 return FAILURE;
2509
2510 if (scalar_check (unit, 0) == FAILURE)
2511 return FAILURE;
2512
2513 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2514 return FAILURE;
2515
2516 if (scalar_check (offset, 1) == FAILURE)
2517 return FAILURE;
2518
2519 return SUCCESS;
2520 }
2521
2522
2523 try
2524 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2525 {
2526 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2527 return FAILURE;
2528
2529 if (type_check (array, 1, BT_INTEGER) == FAILURE
2530 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2531 return FAILURE;
2532
2533 if (array_check (array, 1) == FAILURE)
2534 return FAILURE;
2535
2536 return SUCCESS;
2537 }
2538
2539
2540 try
2541 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2542 {
2543 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2544 return FAILURE;
2545
2546 if (type_check (array, 1, BT_INTEGER) == FAILURE
2547 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2548 return FAILURE;
2549
2550 if (array_check (array, 1) == FAILURE)
2551 return FAILURE;
2552
2553 if (status == NULL)
2554 return SUCCESS;
2555
2556 if (type_check (status, 2, BT_INTEGER) == FAILURE
2557 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2558 return FAILURE;
2559
2560 if (scalar_check (status, 2) == FAILURE)
2561 return FAILURE;
2562
2563 return SUCCESS;
2564 }
2565
2566
2567 try
2568 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2569 gfc_expr * mold ATTRIBUTE_UNUSED,
2570 gfc_expr * size)
2571 {
2572 if (size != NULL)
2573 {
2574 if (type_check (size, 2, BT_INTEGER) == FAILURE)
2575 return FAILURE;
2576
2577 if (scalar_check (size, 2) == FAILURE)
2578 return FAILURE;
2579
2580 if (nonoptional_check (size, 2) == FAILURE)
2581 return FAILURE;
2582 }
2583
2584 return SUCCESS;
2585 }
2586
2587
2588 try
2589 gfc_check_transpose (gfc_expr * matrix)
2590 {
2591 if (rank_check (matrix, 0, 2) == FAILURE)
2592 return FAILURE;
2593
2594 if (gfc_init_expr)
2595 return non_init_transformational ();
2596
2597 return SUCCESS;
2598 }
2599
2600
2601 try
2602 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2603 {
2604 if (array_check (array, 0) == FAILURE)
2605 return FAILURE;
2606
2607 if (dim != NULL)
2608 {
2609 if (dim_check (dim, 1, 1) == FAILURE)
2610 return FAILURE;
2611
2612 if (dim_rank_check (dim, array, 0) == FAILURE)
2613 return FAILURE;
2614 }
2615
2616 return SUCCESS;
2617 }
2618
2619
2620 try
2621 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2622 {
2623 if (rank_check (vector, 0, 1) == FAILURE)
2624 return FAILURE;
2625
2626 if (array_check (mask, 1) == FAILURE)
2627 return FAILURE;
2628
2629 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2630 return FAILURE;
2631
2632 if (same_type_check (vector, 0, field, 2) == FAILURE)
2633 return FAILURE;
2634
2635 if (gfc_init_expr)
2636 return non_init_transformational ();
2637
2638 return SUCCESS;
2639 }
2640
2641
2642 try
2643 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2644 {
2645 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2646 return FAILURE;
2647
2648 if (same_type_check (x, 0, y, 1) == FAILURE)
2649 return FAILURE;
2650
2651 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2652 return FAILURE;
2653
2654 return SUCCESS;
2655 }
2656
2657
2658 try
2659 gfc_check_trim (gfc_expr * x)
2660 {
2661 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2662 return FAILURE;
2663
2664 if (scalar_check (x, 0) == FAILURE)
2665 return FAILURE;
2666
2667 return SUCCESS;
2668 }
2669
2670
2671 try
2672 gfc_check_ttynam (gfc_expr * unit)
2673 {
2674 if (scalar_check (unit, 0) == FAILURE)
2675 return FAILURE;
2676
2677 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2678 return FAILURE;
2679
2680 return SUCCESS;
2681 }
2682
2683
2684 /* Common check function for the half a dozen intrinsics that have a
2685 single real argument. */
2686
2687 try
2688 gfc_check_x (gfc_expr * x)
2689 {
2690 if (type_check (x, 0, BT_REAL) == FAILURE)
2691 return FAILURE;
2692
2693 return SUCCESS;
2694 }
2695
2696
2697 /************* Check functions for intrinsic subroutines *************/
2698
2699 try
2700 gfc_check_cpu_time (gfc_expr * time)
2701 {
2702 if (scalar_check (time, 0) == FAILURE)
2703 return FAILURE;
2704
2705 if (type_check (time, 0, BT_REAL) == FAILURE)
2706 return FAILURE;
2707
2708 if (variable_check (time, 0) == FAILURE)
2709 return FAILURE;
2710
2711 return SUCCESS;
2712 }
2713
2714
2715 try
2716 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2717 gfc_expr * zone, gfc_expr * values)
2718 {
2719 if (date != NULL)
2720 {
2721 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2722 return FAILURE;
2723 if (scalar_check (date, 0) == FAILURE)
2724 return FAILURE;
2725 if (variable_check (date, 0) == FAILURE)
2726 return FAILURE;
2727 }
2728
2729 if (time != NULL)
2730 {
2731 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2732 return FAILURE;
2733 if (scalar_check (time, 1) == FAILURE)
2734 return FAILURE;
2735 if (variable_check (time, 1) == FAILURE)
2736 return FAILURE;
2737 }
2738
2739 if (zone != NULL)
2740 {
2741 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2742 return FAILURE;
2743 if (scalar_check (zone, 2) == FAILURE)
2744 return FAILURE;
2745 if (variable_check (zone, 2) == FAILURE)
2746 return FAILURE;
2747 }
2748
2749 if (values != NULL)
2750 {
2751 if (type_check (values, 3, BT_INTEGER) == FAILURE)
2752 return FAILURE;
2753 if (array_check (values, 3) == FAILURE)
2754 return FAILURE;
2755 if (rank_check (values, 3, 1) == FAILURE)
2756 return FAILURE;
2757 if (variable_check (values, 3) == FAILURE)
2758 return FAILURE;
2759 }
2760
2761 return SUCCESS;
2762 }
2763
2764
2765 try
2766 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2767 gfc_expr * to, gfc_expr * topos)
2768 {
2769 if (type_check (from, 0, BT_INTEGER) == FAILURE)
2770 return FAILURE;
2771
2772 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2773 return FAILURE;
2774
2775 if (type_check (len, 2, BT_INTEGER) == FAILURE)
2776 return FAILURE;
2777
2778 if (same_type_check (from, 0, to, 3) == FAILURE)
2779 return FAILURE;
2780
2781 if (variable_check (to, 3) == FAILURE)
2782 return FAILURE;
2783
2784 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2785 return FAILURE;
2786
2787 return SUCCESS;
2788 }
2789
2790
2791 try
2792 gfc_check_random_number (gfc_expr * harvest)
2793 {
2794 if (type_check (harvest, 0, BT_REAL) == FAILURE)
2795 return FAILURE;
2796
2797 if (variable_check (harvest, 0) == FAILURE)
2798 return FAILURE;
2799
2800 return SUCCESS;
2801 }
2802
2803
2804 try
2805 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2806 {
2807 if (size != NULL)
2808 {
2809 if (scalar_check (size, 0) == FAILURE)
2810 return FAILURE;
2811
2812 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2813 return FAILURE;
2814
2815 if (variable_check (size, 0) == FAILURE)
2816 return FAILURE;
2817
2818 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2819 return FAILURE;
2820 }
2821
2822 if (put != NULL)
2823 {
2824
2825 if (size != NULL)
2826 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2827 &put->where);
2828
2829 if (array_check (put, 1) == FAILURE)
2830 return FAILURE;
2831
2832 if (rank_check (put, 1, 1) == FAILURE)
2833 return FAILURE;
2834
2835 if (type_check (put, 1, BT_INTEGER) == FAILURE)
2836 return FAILURE;
2837
2838 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2839 return FAILURE;
2840 }
2841
2842 if (get != NULL)
2843 {
2844
2845 if (size != NULL || put != NULL)
2846 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2847 &get->where);
2848
2849 if (array_check (get, 2) == FAILURE)
2850 return FAILURE;
2851
2852 if (rank_check (get, 2, 1) == FAILURE)
2853 return FAILURE;
2854
2855 if (type_check (get, 2, BT_INTEGER) == FAILURE)
2856 return FAILURE;
2857
2858 if (variable_check (get, 2) == FAILURE)
2859 return FAILURE;
2860
2861 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2862 return FAILURE;
2863 }
2864
2865 return SUCCESS;
2866 }
2867
2868 try
2869 gfc_check_second_sub (gfc_expr * time)
2870 {
2871 if (scalar_check (time, 0) == FAILURE)
2872 return FAILURE;
2873
2874 if (type_check (time, 0, BT_REAL) == FAILURE)
2875 return FAILURE;
2876
2877 if (kind_value_check(time, 0, 4) == FAILURE)
2878 return FAILURE;
2879
2880 return SUCCESS;
2881 }
2882
2883
2884 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
2885 count, count_rate, and count_max are all optional arguments */
2886
2887 try
2888 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2889 gfc_expr * count_max)
2890 {
2891 if (count != NULL)
2892 {
2893 if (scalar_check (count, 0) == FAILURE)
2894 return FAILURE;
2895
2896 if (type_check (count, 0, BT_INTEGER) == FAILURE)
2897 return FAILURE;
2898
2899 if (variable_check (count, 0) == FAILURE)
2900 return FAILURE;
2901 }
2902
2903 if (count_rate != NULL)
2904 {
2905 if (scalar_check (count_rate, 1) == FAILURE)
2906 return FAILURE;
2907
2908 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2909 return FAILURE;
2910
2911 if (variable_check (count_rate, 1) == FAILURE)
2912 return FAILURE;
2913
2914 if (count != NULL
2915 && same_type_check (count, 0, count_rate, 1) == FAILURE)
2916 return FAILURE;
2917
2918 }
2919
2920 if (count_max != NULL)
2921 {
2922 if (scalar_check (count_max, 2) == FAILURE)
2923 return FAILURE;
2924
2925 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2926 return FAILURE;
2927
2928 if (variable_check (count_max, 2) == FAILURE)
2929 return FAILURE;
2930
2931 if (count != NULL
2932 && same_type_check (count, 0, count_max, 2) == FAILURE)
2933 return FAILURE;
2934
2935 if (count_rate != NULL
2936 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2937 return FAILURE;
2938 }
2939
2940 return SUCCESS;
2941 }
2942
2943 try
2944 gfc_check_irand (gfc_expr * x)
2945 {
2946 if (x == NULL)
2947 return SUCCESS;
2948
2949 if (scalar_check (x, 0) == FAILURE)
2950 return FAILURE;
2951
2952 if (type_check (x, 0, BT_INTEGER) == FAILURE)
2953 return FAILURE;
2954
2955 if (kind_value_check(x, 0, 4) == FAILURE)
2956 return FAILURE;
2957
2958 return SUCCESS;
2959 }
2960
2961
2962 try
2963 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2964 {
2965 if (scalar_check (seconds, 0) == FAILURE)
2966 return FAILURE;
2967
2968 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2969 return FAILURE;
2970
2971 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2972 {
2973 gfc_error (
2974 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2975 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2976 return FAILURE;
2977 }
2978
2979 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2980 return FAILURE;
2981
2982 if (status == NULL)
2983 return SUCCESS;
2984
2985 if (scalar_check (status, 2) == FAILURE)
2986 return FAILURE;
2987
2988 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2989 return FAILURE;
2990
2991 return SUCCESS;
2992 }
2993
2994
2995 try
2996 gfc_check_rand (gfc_expr * x)
2997 {
2998 if (x == NULL)
2999 return SUCCESS;
3000
3001 if (scalar_check (x, 0) == FAILURE)
3002 return FAILURE;
3003
3004 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3005 return FAILURE;
3006
3007 if (kind_value_check(x, 0, 4) == FAILURE)
3008 return FAILURE;
3009
3010 return SUCCESS;
3011 }
3012
3013 try
3014 gfc_check_srand (gfc_expr * x)
3015 {
3016 if (scalar_check (x, 0) == FAILURE)
3017 return FAILURE;
3018
3019 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3020 return FAILURE;
3021
3022 if (kind_value_check(x, 0, 4) == FAILURE)
3023 return FAILURE;
3024
3025 return SUCCESS;
3026 }
3027
3028 try
3029 gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
3030 {
3031 if (scalar_check (time, 0) == FAILURE)
3032 return FAILURE;
3033
3034 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3035 return FAILURE;
3036
3037 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3038 return FAILURE;
3039
3040 return SUCCESS;
3041 }
3042
3043 try
3044 gfc_check_etime (gfc_expr * x)
3045 {
3046 if (array_check (x, 0) == FAILURE)
3047 return FAILURE;
3048
3049 if (rank_check (x, 0, 1) == FAILURE)
3050 return FAILURE;
3051
3052 if (variable_check (x, 0) == FAILURE)
3053 return FAILURE;
3054
3055 if (type_check (x, 0, BT_REAL) == FAILURE)
3056 return FAILURE;
3057
3058 if (kind_value_check(x, 0, 4) == FAILURE)
3059 return FAILURE;
3060
3061 return SUCCESS;
3062 }
3063
3064 try
3065 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
3066 {
3067 if (array_check (values, 0) == FAILURE)
3068 return FAILURE;
3069
3070 if (rank_check (values, 0, 1) == FAILURE)
3071 return FAILURE;
3072
3073 if (variable_check (values, 0) == FAILURE)
3074 return FAILURE;
3075
3076 if (type_check (values, 0, BT_REAL) == FAILURE)
3077 return FAILURE;
3078
3079 if (kind_value_check(values, 0, 4) == FAILURE)
3080 return FAILURE;
3081
3082 if (scalar_check (time, 1) == FAILURE)
3083 return FAILURE;
3084
3085 if (type_check (time, 1, BT_REAL) == FAILURE)
3086 return FAILURE;
3087
3088 if (kind_value_check(time, 1, 4) == FAILURE)
3089 return FAILURE;
3090
3091 return SUCCESS;
3092 }
3093
3094
3095 try
3096 gfc_check_fdate_sub (gfc_expr * date)
3097 {
3098 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3099 return FAILURE;
3100
3101 return SUCCESS;
3102 }
3103
3104
3105 try
3106 gfc_check_gerror (gfc_expr * msg)
3107 {
3108 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3109 return FAILURE;
3110
3111 return SUCCESS;
3112 }
3113
3114
3115 try
3116 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
3117 {
3118 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3119 return FAILURE;
3120
3121 if (status == NULL)
3122 return SUCCESS;
3123
3124 if (scalar_check (status, 1) == FAILURE)
3125 return FAILURE;
3126
3127 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3128 return FAILURE;
3129
3130 return SUCCESS;
3131 }
3132
3133
3134 try
3135 gfc_check_getlog (gfc_expr * msg)
3136 {
3137 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3138 return FAILURE;
3139
3140 return SUCCESS;
3141 }
3142
3143
3144 try
3145 gfc_check_exit (gfc_expr * status)
3146 {
3147 if (status == NULL)
3148 return SUCCESS;
3149
3150 if (type_check (status, 0, BT_INTEGER) == FAILURE)
3151 return FAILURE;
3152
3153 if (scalar_check (status, 0) == FAILURE)
3154 return FAILURE;
3155
3156 return SUCCESS;
3157 }
3158
3159
3160 try
3161 gfc_check_flush (gfc_expr * unit)
3162 {
3163 if (unit == NULL)
3164 return SUCCESS;
3165
3166 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3167 return FAILURE;
3168
3169 if (scalar_check (unit, 0) == FAILURE)
3170 return FAILURE;
3171
3172 return SUCCESS;
3173 }
3174
3175
3176 try
3177 gfc_check_free (gfc_expr * i)
3178 {
3179 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3180 return FAILURE;
3181
3182 if (scalar_check (i, 0) == FAILURE)
3183 return FAILURE;
3184
3185 return SUCCESS;
3186 }
3187
3188
3189 try
3190 gfc_check_hostnm (gfc_expr * name)
3191 {
3192 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3193 return FAILURE;
3194
3195 return SUCCESS;
3196 }
3197
3198
3199 try
3200 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
3201 {
3202 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3203 return FAILURE;
3204
3205 if (status == NULL)
3206 return SUCCESS;
3207
3208 if (scalar_check (status, 1) == FAILURE)
3209 return FAILURE;
3210
3211 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3212 return FAILURE;
3213
3214 return SUCCESS;
3215 }
3216
3217
3218 try
3219 gfc_check_itime_idate (gfc_expr * values)
3220 {
3221 if (array_check (values, 0) == FAILURE)
3222 return FAILURE;
3223
3224 if (rank_check (values, 0, 1) == FAILURE)
3225 return FAILURE;
3226
3227 if (variable_check (values, 0) == FAILURE)
3228 return FAILURE;
3229
3230 if (type_check (values, 0, BT_INTEGER) == FAILURE)
3231 return FAILURE;
3232
3233 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3234 return FAILURE;
3235
3236 return SUCCESS;
3237 }
3238
3239
3240 try
3241 gfc_check_ltime_gmtime (gfc_expr * time, gfc_expr * values)
3242 {
3243 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3244 return FAILURE;
3245
3246 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3247 return FAILURE;
3248
3249 if (scalar_check (time, 0) == FAILURE)
3250 return FAILURE;
3251
3252 if (array_check (values, 1) == FAILURE)
3253 return FAILURE;
3254
3255 if (rank_check (values, 1, 1) == FAILURE)
3256 return FAILURE;
3257
3258 if (variable_check (values, 1) == FAILURE)
3259 return FAILURE;
3260
3261 if (type_check (values, 1, BT_INTEGER) == FAILURE)
3262 return FAILURE;
3263
3264 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3265 return FAILURE;
3266
3267 return SUCCESS;
3268 }
3269
3270
3271 try
3272 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
3273 {
3274 if (scalar_check (unit, 0) == FAILURE)
3275 return FAILURE;
3276
3277 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3278 return FAILURE;
3279
3280 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3281 return FAILURE;
3282
3283 return SUCCESS;
3284 }
3285
3286
3287 try
3288 gfc_check_isatty (gfc_expr * unit)
3289 {
3290 if (unit == NULL)
3291 return FAILURE;
3292
3293 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3294 return FAILURE;
3295
3296 if (scalar_check (unit, 0) == FAILURE)
3297 return FAILURE;
3298
3299 return SUCCESS;
3300 }
3301
3302
3303 try
3304 gfc_check_perror (gfc_expr * string)
3305 {
3306 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3307 return FAILURE;
3308
3309 return SUCCESS;
3310 }
3311
3312
3313 try
3314 gfc_check_umask (gfc_expr * mask)
3315 {
3316 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3317 return FAILURE;
3318
3319 if (scalar_check (mask, 0) == FAILURE)
3320 return FAILURE;
3321
3322 return SUCCESS;
3323 }
3324
3325
3326 try
3327 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
3328 {
3329 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3330 return FAILURE;
3331
3332 if (scalar_check (mask, 0) == FAILURE)
3333 return FAILURE;
3334
3335 if (old == NULL)
3336 return SUCCESS;
3337
3338 if (scalar_check (old, 1) == FAILURE)
3339 return FAILURE;
3340
3341 if (type_check (old, 1, BT_INTEGER) == FAILURE)
3342 return FAILURE;
3343
3344 return SUCCESS;
3345 }
3346
3347
3348 try
3349 gfc_check_unlink (gfc_expr * name)
3350 {
3351 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3352 return FAILURE;
3353
3354 return SUCCESS;
3355 }
3356
3357
3358 try
3359 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
3360 {
3361 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3362 return FAILURE;
3363
3364 if (status == NULL)
3365 return SUCCESS;
3366
3367 if (scalar_check (status, 1) == FAILURE)
3368 return FAILURE;
3369
3370 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3371 return FAILURE;
3372
3373 return SUCCESS;
3374 }
3375
3376
3377 try
3378 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
3379 {
3380 if (scalar_check (number, 0) == FAILURE)
3381 return FAILURE;
3382
3383 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3384 return FAILURE;
3385
3386 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3387 {
3388 gfc_error (
3389 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3390 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3391 return FAILURE;
3392 }
3393
3394 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3395 return FAILURE;
3396
3397 return SUCCESS;
3398 }
3399
3400
3401 try
3402 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
3403 {
3404 if (scalar_check (number, 0) == FAILURE)
3405 return FAILURE;
3406
3407 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3408 return FAILURE;
3409
3410 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3411 {
3412 gfc_error (
3413 "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3414 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3415 return FAILURE;
3416 }
3417
3418 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3419 return FAILURE;
3420
3421 if (status == NULL)
3422 return SUCCESS;
3423
3424 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3425 return FAILURE;
3426
3427 if (scalar_check (status, 2) == FAILURE)
3428 return FAILURE;
3429
3430 return SUCCESS;
3431 }
3432
3433
3434 try
3435 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
3436 {
3437 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3438 return FAILURE;
3439
3440 if (scalar_check (status, 1) == FAILURE)
3441 return FAILURE;
3442
3443 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3444 return FAILURE;
3445
3446 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3447 return FAILURE;
3448
3449 return SUCCESS;
3450 }
3451
3452
3453 /* This is used for the GNU intrinsics AND, OR and XOR. */
3454 try
3455 gfc_check_and (gfc_expr * i, gfc_expr * j)
3456 {
3457 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3458 {
3459 gfc_error (
3460 "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3461 gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
3462 return FAILURE;
3463 }
3464
3465 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3466 {
3467 gfc_error (
3468 "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3469 gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
3470 return FAILURE;
3471 }
3472
3473 if (i->ts.type != j->ts.type)
3474 {
3475 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3476 "have the same type", gfc_current_intrinsic_arg[0],
3477 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3478 &j->where);
3479 return FAILURE;
3480 }
3481
3482 if (scalar_check (i, 0) == FAILURE)
3483 return FAILURE;
3484
3485 if (scalar_check (j, 1) == FAILURE)
3486 return FAILURE;
3487
3488 return SUCCESS;
3489 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org