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