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