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