]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/check.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
check.c (gfc_check_system_clock): New function.
[gcc.git] / gcc / fortran / check.c
CommitLineData
6de9cd9a 1/* Check functions
9fc4d79b 2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Andy Vaught & Katherine Holcomb
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
9fc4d79b
TS		 18along with GCC; see the file COPYING. If not, write to the Free
19Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA. */
6de9cd9a
DN		 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
30#include <stdlib.h>
31#include <stdarg.h>
32
33#include "config.h"
34#include "system.h"
35#include "flags.h"
36#include "gfortran.h"
37#include "intrinsic.h"
38
39
40/* The fundamental complaint function of this source file. This
41 function can be called in all kinds of ways. */
42
43static void
44must_be (gfc_expr * e, int n, const char *thing)
45{
46
47 gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
48 gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
49 thing);
50}
51
52
53/* Check the type of an expression. */
54
55static try
56type_check (gfc_expr * e, int n, bt type)
57{
58
59 if (e->ts.type == type)
60 return SUCCESS;
61
62 must_be (e, n, gfc_basic_typename (type));
63
64 return FAILURE;
65}
66
67
68/* Check that the expression is a numeric type. */
69
70static try
71numeric_check (gfc_expr * e, int n)
72{
73
74 if (gfc_numeric_ts (&e->ts))
75 return SUCCESS;
76
77 must_be (e, n, "a numeric type");
78
79 return FAILURE;
80}
81
82
83/* Check that an expression is integer or real. */
84
85static try
86int_or_real_check (gfc_expr * e, int n)
87{
88
89 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
90 {
91 must_be (e, n, "INTEGER or REAL");
92 return FAILURE;
93 }
94
95 return SUCCESS;
96}
97
98
99/* Check that the expression is an optional constant integer
100 and that it specifies a valid kind for that type. */
101
102static try
103kind_check (gfc_expr * k, int n, bt type)
104{
105 int kind;
106
107 if (k == NULL)
108 return SUCCESS;
109
110 if (type_check (k, n, BT_INTEGER) == FAILURE)
111 return FAILURE;
112
113 if (k->expr_type != EXPR_CONSTANT)
114 {
115 must_be (k, n, "a constant");
116 return FAILURE;
117 }
118
119 if (gfc_extract_int (k, &kind) != NULL
120 || gfc_validate_kind (type, kind) == -1)
121 {
122 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
123 &k->where);
124 return FAILURE;
125 }
126
127 return SUCCESS;
128}
129
130
131/* Make sure the expression is a double precision real. */
132
133static try
134double_check (gfc_expr * d, int n)
135{
136
137 if (type_check (d, n, BT_REAL) == FAILURE)
138 return FAILURE;
139
140 if (d->ts.kind != gfc_default_double_kind ())
141 {
142 must_be (d, n, "double precision");
143 return FAILURE;
144 }
145
146 return SUCCESS;
147}
148
149
150/* Make sure the expression is a logical array. */
151
152static try
153logical_array_check (gfc_expr * array, int n)
154{
155
156 if (array->ts.type != BT_LOGICAL || array->rank == 0)
157 {
158 must_be (array, n, "a logical array");
159 return FAILURE;
160 }
161
162 return SUCCESS;
163}
164
165
166/* Make sure an expression is an array. */
167
168static try
169array_check (gfc_expr * e, int n)
170{
171
172 if (e->rank != 0)
173 return SUCCESS;
174
175 must_be (e, n, "an array");
176
177 return FAILURE;
178}
179
180
181/* Make sure an expression is a scalar. */
182
183static try
184scalar_check (gfc_expr * e, int n)
185{
186
187 if (e->rank == 0)
188 return SUCCESS;
189
190 must_be (e, n, "a scalar");
191
192 return FAILURE;
193}
194
195
196/* Make sure two expression have the same type. */
197
198static try
199same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
200{
201 char message[100];
202
203 if (gfc_compare_types (&e->ts, &f->ts))
204 return SUCCESS;
205
206 sprintf (message, "the same type and kind as '%s'",
207 gfc_current_intrinsic_arg[n]);
208
209 must_be (f, m, message);
210
211 return FAILURE;
212}
213
214
215/* Make sure that an expression has a certain (nonzero) rank. */
216
217static try
218rank_check (gfc_expr * e, int n, int rank)
219{
220 char message[100];
221
222 if (e->rank == rank)
223 return SUCCESS;
224
225 sprintf (message, "of rank %d", rank);
226
227 must_be (e, n, message);
228
229 return FAILURE;
230}
231
232
233/* Make sure a variable expression is not an optional dummy argument. */
234
235static try
236nonoptional_check (gfc_expr * e, int n)
237{
238
239 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
240 {
241 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
242 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
243 &e->where);
244
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
255static try
256kind_value_check (gfc_expr * e, int n, int k)
257{
258 char message[100];
259
260 if (e->ts.kind == k)
261 return SUCCESS;
262
263 sprintf (message, "of kind %d", k);
264
265 must_be (e, n, message);
266 return FAILURE;
267}
268
269
270/* Make sure an expression is a variable. */
271
272static try
273variable_check (gfc_expr * e, int n)
274{
275
276 if ((e->expr_type == EXPR_VARIABLE
277 && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
278 || (e->expr_type == EXPR_FUNCTION
279 && e->symtree->n.sym->result == e->symtree->n.sym))
280 return SUCCESS;
281
282 if (e->expr_type == EXPR_VARIABLE
283 && e->symtree->n.sym->attr.intent == INTENT_IN)
284 {
285 gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
286 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
287 &e->where);
288 return FAILURE;
289 }
290
291 must_be (e, n, "a variable");
292
293 return FAILURE;
294}
295
296
297/* Check the common DIM parameter for correctness. */
298
299static try
300dim_check (gfc_expr * dim, int n, int optional)
301{
302
303 if (optional)
304 {
305 if (dim == NULL)
306 return SUCCESS;
307
308 if (nonoptional_check (dim, n) == FAILURE)
309 return FAILURE;
310
311 return SUCCESS;
312 }
313
314 if (dim == NULL)
315 {
316 gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
317 gfc_current_intrinsic, gfc_current_intrinsic_where);
318 return FAILURE;
319 }
320
321 if (type_check (dim, n, BT_INTEGER) == FAILURE)
322 return FAILURE;
323
324 if (scalar_check (dim, n) == FAILURE)
325 return FAILURE;
326
327 return SUCCESS;
328}
329
330
331/* If a DIM parameter is a constant, make sure that it is greater than
332 zero and less than or equal to the rank of the given array. If
333 allow_assumed is zero then dim must be less than the rank of the array
334 for assumed size arrays. */
335
336static try
337dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
338{
339 gfc_array_ref *ar;
340 int rank;
341
342 if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
343 return SUCCESS;
344
345 ar = gfc_find_array_ref (array);
346 rank = array->rank;
347 if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
348 rank--;
349
350 if (mpz_cmp_ui (dim->value.integer, 1) < 0
351 || mpz_cmp_ui (dim->value.integer, rank) > 0)
352 {
353 gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
354 "dimension index", gfc_current_intrinsic, &dim->where);
355
356 return FAILURE;
357 }
358
359 return SUCCESS;
360}
361
362
363/***** Check functions *****/
364
365/* Check subroutine suitable for intrinsics taking a real argument and
366 a kind argument for the result. */
367
368static try
369check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
370{
371
372 if (type_check (a, 0, BT_REAL) == FAILURE)
373 return FAILURE;
374 if (kind_check (kind, 1, type) == FAILURE)
375 return FAILURE;
376
377 return SUCCESS;
378}
379
380/* Check subroutine suitable for ceiling, floor and nint. */
381
382try
383gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
384{
385
386 return check_a_kind (a, kind, BT_INTEGER);
387}
388
389/* Check subroutine suitable for aint, anint. */
390
391try
392gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
393{
394
395 return check_a_kind (a, kind, BT_REAL);
396}
397
398try
399gfc_check_abs (gfc_expr * a)
400{
401
402 if (numeric_check (a, 0) == FAILURE)
403 return FAILURE;
404
405 return SUCCESS;
406}
407
408
409try
410gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
411{
412
413 if (logical_array_check (mask, 0) == FAILURE)
414 return FAILURE;
415
416 if (dim_check (dim, 1, 1) == FAILURE)
417 return FAILURE;
418
419 return SUCCESS;
420}
421
422
423try
424gfc_check_allocated (gfc_expr * array)
425{
426
427 if (variable_check (array, 0) == FAILURE)
428 return FAILURE;
429
430 if (array_check (array, 0) == FAILURE)
431 return FAILURE;
432
433 if (!array->symtree->n.sym->attr.allocatable)
434 {
435 must_be (array, 0, "ALLOCATABLE");
436 return FAILURE;
437 }
438
439 return SUCCESS;
440}
441
442
443/* Common check function where the first argument must be real or
444 integer and the second argument must be the same as the first. */
445
446try
447gfc_check_a_p (gfc_expr * a, gfc_expr * p)
448{
449
450 if (int_or_real_check (a, 0) == FAILURE)
451 return FAILURE;
452
453 if (same_type_check (a, 0, p, 1) == FAILURE)
454 return FAILURE;
455
456 return SUCCESS;
457}
458
459
460try
461gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
462{
463 symbol_attribute attr;
464 int i;
465 try t;
466
467 if (variable_check (pointer, 0) == FAILURE)
468 return FAILURE;
469
470 attr = gfc_variable_attr (pointer, NULL);
471 if (!attr.pointer)
472 {
473 must_be (pointer, 0, "a POINTER");
474 return FAILURE;
475 }
476
477 if (target == NULL)
478 return SUCCESS;
479
480 /* Target argument is optional. */
481 if (target->expr_type == EXPR_NULL)
482 {
483 gfc_error ("NULL pointer at %L is not permitted as actual argument "
484 "of '%s' intrinsic function",
485 &target->where, gfc_current_intrinsic);
486 return FAILURE;
487 }
488
489 attr = gfc_variable_attr (target, NULL);
490 if (!attr.pointer && !attr.target)
491 {
492 must_be (target, 1, "a POINTER or a TARGET");
493 return FAILURE;
494 }
495
496 t = SUCCESS;
497 if (same_type_check (pointer, 0, target, 1) == FAILURE)
498 t = FAILURE;
499 if (rank_check (target, 0, pointer->rank) == FAILURE)
500 t = FAILURE;
501 if (target->rank > 0)
502 {
503 for (i = 0; i < target->rank; i++)
504 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
505 {
506 gfc_error ("Array section with a vector subscript at %L shall not "
507 "be the target of an pointer",
508 &target->where);
509 t = FAILURE;
510 break;
511 }
512 }
513 return t;
514}
515
516
517try
518gfc_check_btest (gfc_expr * i, gfc_expr * pos)
519{
520
521 if (type_check (i, 0, BT_INTEGER) == FAILURE)
522 return FAILURE;
523 if (type_check (pos, 1, BT_INTEGER) == FAILURE)
524 return FAILURE;
525
526 return SUCCESS;
527}
528
529
530try
531gfc_check_char (gfc_expr * i, gfc_expr * kind)
532{
533
534 if (type_check (i, 0, BT_INTEGER) == FAILURE)
535 return FAILURE;
536 if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
537 return FAILURE;
538
539 return SUCCESS;
540}
541
542
543try
544gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
545{
546
547 if (numeric_check (x, 0) == FAILURE)
548 return FAILURE;
549
550 if (y != NULL)
551 {
552 if (numeric_check (y, 1) == FAILURE)
553 return FAILURE;
554
555 if (x->ts.type == BT_COMPLEX)
556 {
557 must_be (y, 1, "not be present if 'x' is COMPLEX");
558 return FAILURE;
559 }
560 }
561
562 if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
563 return FAILURE;
564
565 return SUCCESS;
566}
567
568
569try
570gfc_check_count (gfc_expr * mask, gfc_expr * dim)
571{
572
573 if (logical_array_check (mask, 0) == FAILURE)
574 return FAILURE;
575 if (dim_check (dim, 1, 1) == FAILURE)
576 return FAILURE;
577
578 return SUCCESS;
579}
580
581
582try
583gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
584{
585
586 if (array_check (array, 0) == FAILURE)
587 return FAILURE;
588
589 if (array->rank == 1)
590 {
591 if (scalar_check (shift, 1) == FAILURE)
592 return FAILURE;
593 }
594 else
595 {
596 /* TODO: more requirements on shift parameter. */
597 }
598
599 if (dim_check (dim, 2, 1) == FAILURE)
600 return FAILURE;
601
602 return SUCCESS;
603}
604
605
606try
607gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
608{
609
610 if (numeric_check (x, 0) == FAILURE)
611 return FAILURE;
612
613 if (y != NULL)
614 {
615 if (numeric_check (y, 1) == FAILURE)
616 return FAILURE;
617
618 if (x->ts.type == BT_COMPLEX)
619 {
620 must_be (y, 1, "not be present if 'x' is COMPLEX");
621 return FAILURE;
622 }
623 }
624
625 return SUCCESS;
626}
627
628
629try
630gfc_check_dble (gfc_expr * x)
631{
632
633 if (numeric_check (x, 0) == FAILURE)
634 return FAILURE;
635
636 return SUCCESS;
637}
638
639
640try
641gfc_check_digits (gfc_expr * x)
642{
643
644 if (int_or_real_check (x, 0) == FAILURE)
645 return FAILURE;
646
647 return SUCCESS;
648}
649
650
651try
652gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
653{
654
655 switch (vector_a->ts.type)
656 {
657 case BT_LOGICAL:
658 if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
659 return FAILURE;
660 break;
661
662 case BT_INTEGER:
663 case BT_REAL:
664 case BT_COMPLEX:
665 if (numeric_check (vector_b, 1) == FAILURE)
666 return FAILURE;
667 break;
668
669 default:
670 must_be (vector_a, 0, "numeric or LOGICAL");
671 return FAILURE;
672 }
673
674 if (rank_check (vector_a, 0, 1) == FAILURE)
675 return FAILURE;
676
677 if (rank_check (vector_b, 1, 1) == FAILURE)
678 return FAILURE;
679
680 return SUCCESS;
681}
682
683
684try
685gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
686 gfc_expr * dim)
687{
688
689 if (array_check (array, 0) == FAILURE)
690 return FAILURE;
691
692 if (type_check (shift, 1, BT_INTEGER) == FAILURE)
693 return FAILURE;
694
695 if (array->rank == 1)
696 {
697 if (scalar_check (shift, 2) == FAILURE)
698 return FAILURE;
699 }
700 else
701 {
702 /* TODO: more weird restrictions on shift. */
703 }
704
705 if (boundary != NULL)
706 {
707 if (same_type_check (array, 0, boundary, 2) == FAILURE)
708 return FAILURE;
709
710 /* TODO: more restrictions on boundary. */
711 }
712
713 if (dim_check (dim, 1, 1) == FAILURE)
714 return FAILURE;
715
716 return SUCCESS;
717}
718
719
720
721try
722gfc_check_huge (gfc_expr * x)
723{
724
725 if (int_or_real_check (x, 0) == FAILURE)
726 return FAILURE;
727
728 return SUCCESS;
729}
730
731
732/* Check that the single argument is an integer. */
733
734try
735gfc_check_i (gfc_expr * i)
736{
737
738 if (type_check (i, 0, BT_INTEGER) == FAILURE)
739 return FAILURE;
740
741 return SUCCESS;
742}
743
744
745try
746gfc_check_iand (gfc_expr * i, gfc_expr * j)
747{
748
749 if (type_check (i, 0, BT_INTEGER) == FAILURE
750 || type_check (j, 1, BT_INTEGER) == FAILURE)
751 return FAILURE;
752
753 if (same_type_check (i, 0, j, 1) == FAILURE)
754 return FAILURE;
755
756 return SUCCESS;
757}
758
759
760try
761gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
762{
763
764 if (type_check (i, 0, BT_INTEGER) == FAILURE
765 || type_check (pos, 1, BT_INTEGER) == FAILURE
766 || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE)
767 return FAILURE;
768
769 return SUCCESS;
770}
771
772
773try
774gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
775{
776
777 if (type_check (i, 0, BT_INTEGER) == FAILURE
778 || type_check (pos, 1, BT_INTEGER) == FAILURE
779 || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE
780 || type_check (len, 2, BT_INTEGER) == FAILURE)
781 return FAILURE;
782
783 return SUCCESS;
784}
785
786
787try
788gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
789{
790
791 if (type_check (i, 0, BT_INTEGER) == FAILURE
792 || type_check (pos, 1, BT_INTEGER) == FAILURE
793 || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE)
794 return FAILURE;
795
796 return SUCCESS;
797}
798
799
800try
801gfc_check_idnint (gfc_expr * a)
802{
803
804 if (double_check (a, 0) == FAILURE)
805 return FAILURE;
806
807 return SUCCESS;
808}
809
810
811try
812gfc_check_ieor (gfc_expr * i, gfc_expr * j)
813{
814
815 if (type_check (i, 0, BT_INTEGER) == FAILURE
816 || type_check (j, 1, BT_INTEGER) == FAILURE)
817 return FAILURE;
818
819 if (same_type_check (i, 0, j, 1) == FAILURE)
820 return FAILURE;
821
822 return SUCCESS;
823}
824
825
826try
827gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
828{
829
830 if (type_check (string, 0, BT_CHARACTER) == FAILURE
831 || type_check (substring, 1, BT_CHARACTER) == FAILURE)
832 return FAILURE;
833
834
835 if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
836 return FAILURE;
837
838 if (string->ts.kind != substring->ts.kind)
839 {
840 must_be (substring, 1, "the same kind as 'string'");
841 return FAILURE;
842 }
843
844 return SUCCESS;
845}
846
847
848try
849gfc_check_int (gfc_expr * x, gfc_expr * kind)
850{
851
852 if (numeric_check (x, 0) == FAILURE
853 || kind_check (kind, 1, BT_INTEGER) == FAILURE)
854 return FAILURE;
855
856 return SUCCESS;
857}
858
859
860try
861gfc_check_ior (gfc_expr * i, gfc_expr * j)
862{
863
864 if (type_check (i, 0, BT_INTEGER) == FAILURE
865 || type_check (j, 1, BT_INTEGER) == FAILURE)
866 return FAILURE;
867
868 if (same_type_check (i, 0, j, 1) == FAILURE)
869 return FAILURE;
870
871 return SUCCESS;
872}
873
874
875try
876gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
877{
878
879 if (type_check (i, 0, BT_INTEGER) == FAILURE
880 || type_check (shift, 1, BT_INTEGER) == FAILURE)
881 return FAILURE;
882
883 return SUCCESS;
884}
885
886
887try
888gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
889{
890
891 if (type_check (i, 0, BT_INTEGER) == FAILURE
892 || type_check (shift, 1, BT_INTEGER) == FAILURE)
893 return FAILURE;
894
895 if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
896 return FAILURE;
897
898 return SUCCESS;
899}
900
901
902try
903gfc_check_kind (gfc_expr * x)
904{
905
906 if (x->ts.type == BT_DERIVED)
907 {
908 must_be (x, 0, "a non-derived type");
909 return FAILURE;
910 }
911
912 return SUCCESS;
913}
914
915
916try
917gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
918{
919
920 if (array_check (array, 0) == FAILURE)
921 return FAILURE;
922
923 if (dim != NULL)
924 {
925 if (dim_check (dim, 1, 1) == FAILURE)
926 return FAILURE;
927
928 if (dim_rank_check (dim, array, 1) == FAILURE)
929 return FAILURE;
930 }
931 return SUCCESS;
932}
933
934
935try
936gfc_check_logical (gfc_expr * a, gfc_expr * kind)
937{
938
939 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
940 return FAILURE;
941 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
942 return FAILURE;
943
944 return SUCCESS;
945}
946
947
948/* Min/max family. */
949
950static try
951min_max_args (gfc_actual_arglist * arg)
952{
953
954 if (arg == NULL || arg->next == NULL)
955 {
956 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
957 gfc_current_intrinsic, gfc_current_intrinsic_where);
958 return FAILURE;
959 }
960
961 return SUCCESS;
962}
963
964
965static try
966check_rest (bt type, int kind, gfc_actual_arglist * arg)
967{
968 gfc_expr *x;
969 int n;
970
971 if (min_max_args (arg) == FAILURE)
972 return FAILURE;
973
974 n = 1;
975
976 for (; arg; arg = arg->next, n++)
977 {
978 x = arg->expr;
979 if (x->ts.type != type || x->ts.kind != kind)
980 {
981 if (x->ts.type == type)
982 {
983 if (gfc_notify_std (GFC_STD_GNU,
984 "Extension: Different type kinds at %L", &x->where)
985 == FAILURE)
986 return FAILURE;
987 }
988 else
989 {
990 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
991 n, gfc_current_intrinsic, &x->where,
992 gfc_basic_typename (type), kind);
993 return FAILURE;
994 }
995 }
996 }
997
998 return SUCCESS;
999}
1000
1001
1002try
1003gfc_check_min_max (gfc_actual_arglist * arg)
1004{
1005 gfc_expr *x;
1006
1007 if (min_max_args (arg) == FAILURE)
1008 return FAILURE;
1009
1010 x = arg->expr;
1011
1012 if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1013 {
1014 gfc_error
1015 ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1016 gfc_current_intrinsic, &x->where);
1017 return FAILURE;
1018 }
1019
1020 return check_rest (x->ts.type, x->ts.kind, arg);
1021}
1022
1023
1024try
1025gfc_check_min_max_integer (gfc_actual_arglist * arg)
1026{
1027
1028 return check_rest (BT_INTEGER, gfc_default_integer_kind (), arg);
1029}
1030
1031
1032try
1033gfc_check_min_max_real (gfc_actual_arglist * arg)
1034{
1035
1036 return check_rest (BT_REAL, gfc_default_real_kind (), arg);
1037}
1038
1039
1040try
1041gfc_check_min_max_double (gfc_actual_arglist * arg)
1042{
1043
1044 return check_rest (BT_REAL, gfc_default_double_kind (), arg);
1045}
1046
1047/* End of min/max family. */
1048
1049
1050try
1051gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1052{
1053
1054 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1055 {
1056 must_be (matrix_a, 0, "numeric or LOGICAL");
1057 return FAILURE;
1058 }
1059
1060 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1061 {
1062 must_be (matrix_b, 0, "numeric or LOGICAL");
1063 return FAILURE;
1064 }
1065
1066 switch (matrix_a->rank)
1067 {
1068 case 1:
1069 if (rank_check (matrix_b, 1, 2) == FAILURE)
1070 return FAILURE;
1071 break;
1072
1073 case 2:
1074 if (matrix_b->rank == 2)
1075 break;
1076 if (rank_check (matrix_b, 1, 1) == FAILURE)
1077 return FAILURE;
1078 break;
1079
1080 default:
1081 must_be (matrix_a, 0, "of rank 1 or 2");
1082 return FAILURE;
1083 }
1084
1085 return SUCCESS;
1086}
1087
1088
1089/* Whoever came up with this interface was probably on something.
1090 The possibilities for the occupation of the second and third
1091 parameters are:
1092
1093 Arg #2 Arg #3
1094 NULL NULL
1095 DIM NULL
1096 MASK NULL
1097 NULL MASK minloc(array, mask=m)
1098 DIM MASK
1099*/
1100
1101try
1102gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
1103{
1104
1105 if (int_or_real_check (array, 0) == FAILURE)
1106 return FAILURE;
1107
1108 if (array_check (array, 0) == FAILURE)
1109 return FAILURE;
1110
1111 if (a3 != NULL)
1112 {
1113 if (logical_array_check (a3, 2) == FAILURE)
1114 return FAILURE;
1115
1116 if (a2 != NULL)
1117 {
1118 if (scalar_check (a2, 1) == FAILURE)
1119 return FAILURE;
1120 if (type_check (a2, 1, BT_INTEGER) == FAILURE)
1121 return FAILURE;
1122 }
1123 }
1124 else
1125 {
1126 if (a2 != NULL)
1127 {
1128 switch (a2->ts.type)
1129 {
1130 case BT_INTEGER:
1131 if (scalar_check (a2, 1) == FAILURE)
1132 return FAILURE;
1133 break;
1134
1135 case BT_LOGICAL: /* The '2' makes the error message correct */
1136 if (logical_array_check (a2, 2) == FAILURE)
1137 return FAILURE;
1138 break;
1139
1140 default:
1141 type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */
1142 return FAILURE;
1143 }
1144 }
1145 }
1146
1147 return SUCCESS;
1148}
1149
1150
1151try
1152gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
1153{
1154
1155 if (array_check (array, 0) == FAILURE)
1156 return FAILURE;
1157
1158 if (int_or_real_check (array, 0) == FAILURE)
1159 return FAILURE;
1160
1161 if (dim_check (dim, 1, 1) == FAILURE)
1162 return FAILURE;
1163
1164 if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
1165 return FAILURE;
1166
1167 return SUCCESS;
1168}
1169
1170
1171try
1172gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1173{
1174
1175 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1176 return FAILURE;
1177
1178 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1179 return FAILURE;
1180
1181 return SUCCESS;
1182}
1183
1184
1185try
1186gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1187{
1188
1189 if (type_check (x, 0, BT_REAL) == FAILURE)
1190 return FAILURE;
1191
1192 if (type_check (s, 1, BT_REAL) == FAILURE)
1193 return FAILURE;
1194
1195 return SUCCESS;
1196}
1197
1198
1199try
1200gfc_check_null (gfc_expr * mold)
1201{
1202 symbol_attribute attr;
1203
1204 if (mold == NULL)
1205 return SUCCESS;
1206
1207 if (variable_check (mold, 0) == FAILURE)
1208 return FAILURE;
1209
1210 attr = gfc_variable_attr (mold, NULL);
1211
1212 if (!attr.pointer)
1213 {
1214 must_be (mold, 0, "a POINTER");
1215 return FAILURE;
1216 }
1217
1218 return SUCCESS;
1219}
1220
1221
1222try
1223gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1224{
1225
1226 if (array_check (array, 0) == FAILURE)
1227 return FAILURE;
1228
1229 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1230 return FAILURE;
1231
1232 if (mask->rank != 0 && mask->rank != array->rank)
1233 {
1234 must_be (array, 0, "conformable with 'mask' argument");
1235 return FAILURE;
1236 }
1237
1238 if (vector != NULL)
1239 {
1240 if (same_type_check (array, 0, vector, 2) == FAILURE)
1241 return FAILURE;
1242
1243 if (rank_check (vector, 2, 1) == FAILURE)
1244 return FAILURE;
1245
1246 /* TODO: More constraints here. */
1247 }
1248
1249 return SUCCESS;
1250}
1251
1252
1253try
1254gfc_check_precision (gfc_expr * x)
1255{
1256
1257 if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1258 {
1259 must_be (x, 0, "of type REAL or COMPLEX");
1260 return FAILURE;
1261 }
1262
1263 return SUCCESS;
1264}
1265
1266
1267try
1268gfc_check_present (gfc_expr * a)
1269{
1270 gfc_symbol *sym;
1271
1272 if (variable_check (a, 0) == FAILURE)
1273 return FAILURE;
1274
1275 sym = a->symtree->n.sym;
1276 if (!sym->attr.dummy)
1277 {
1278 must_be (a, 0, "a dummy variable");
1279 return FAILURE;
1280 }
1281
1282 if (!sym->attr.optional)
1283 {
1284 must_be (a, 0, "an OPTIONAL dummy variable");
1285 return FAILURE;
1286 }
1287
1288 return SUCCESS;
1289}
1290
1291
1292try
1293gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
1294{
1295
1296 if (array_check (array, 0) == FAILURE)
1297 return FAILURE;
1298
1299 if (numeric_check (array, 0) == FAILURE)
1300 return FAILURE;
1301
1302 if (dim_check (dim, 1, 1) == FAILURE)
1303 return FAILURE;
1304
1305 if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
1306 return FAILURE;
1307
1308 return SUCCESS;
1309}
1310
1311
1312try
1313gfc_check_radix (gfc_expr * x)
1314{
1315
1316 if (int_or_real_check (x, 0) == FAILURE)
1317 return FAILURE;
1318
1319 return SUCCESS;
1320}
1321
1322
1323try
1324gfc_check_range (gfc_expr * x)
1325{
1326
1327 if (numeric_check (x, 0) == FAILURE)
1328 return FAILURE;
1329
1330 return SUCCESS;
1331}
1332
1333
1334/* real, float, sngl. */
1335try
1336gfc_check_real (gfc_expr * a, gfc_expr * kind)
1337{
1338
1339 if (numeric_check (a, 0) == FAILURE)
1340 return FAILURE;
1341
1342 if (kind_check (kind, 1, BT_REAL) == FAILURE)
1343 return FAILURE;
1344
1345 return SUCCESS;
1346}
1347
1348
1349try
1350gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1351{
1352
1353 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1354 return FAILURE;
1355
1356 if (scalar_check (x, 0) == FAILURE)
1357 return FAILURE;
1358
1359 if (type_check (y, 0, BT_INTEGER) == FAILURE)
1360 return FAILURE;
1361
1362 if (scalar_check (y, 1) == FAILURE)
1363 return FAILURE;
1364
1365 return SUCCESS;
1366}
1367
1368
1369try
1370gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1371 gfc_expr * pad, gfc_expr * order)
1372{
1373 mpz_t size;
1374 int m;
1375
1376 if (array_check (source, 0) == FAILURE)
1377 return FAILURE;
1378
1379 if (rank_check (shape, 1, 1) == FAILURE)
1380 return FAILURE;
1381
1382 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1383 return FAILURE;
1384
1385 if (gfc_array_size (shape, &size) != SUCCESS)
1386 {
1387 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1388 "array of constant size", &shape->where);
1389 return FAILURE;
1390 }
1391
1392 m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1393 mpz_clear (size);
1394
1395 if (m > 0)
1396 {
1397 gfc_error
1398 ("'shape' argument of 'reshape' intrinsic at %L has more than "
1399 stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1400 return FAILURE;
1401 }
1402
1403 if (pad != NULL)
1404 {
1405 if (same_type_check (source, 0, pad, 2) == FAILURE)
1406 return FAILURE;
1407 if (array_check (pad, 2) == FAILURE)
1408 return FAILURE;
1409 }
1410
1411 if (order != NULL && array_check (order, 3) == FAILURE)
1412 return FAILURE;
1413
1414 return SUCCESS;
1415}
1416
1417
1418try
1419gfc_check_scale (gfc_expr * x, gfc_expr * i)
1420{
1421
1422 if (type_check (x, 0, BT_REAL) == FAILURE)
1423 return FAILURE;
1424
1425 if (type_check (i, 1, BT_INTEGER) == FAILURE)
1426 return FAILURE;
1427
1428 return SUCCESS;
1429}
1430
1431
1432try
1433gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1434{
1435
1436 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1437 return FAILURE;
1438
1439 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1440 return FAILURE;
1441
1442 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1443 return FAILURE;
1444
1445 if (same_type_check (x, 0, y, 1) == FAILURE)
1446 return FAILURE;
1447
1448 return SUCCESS;
1449}
1450
1451
1452try
1453gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1454{
1455
1456 if (p == NULL && r == NULL)
1457 {
1458 gfc_error ("Missing arguments to %s intrinsic at %L",
1459 gfc_current_intrinsic, gfc_current_intrinsic_where);
1460
1461 return FAILURE;
1462 }
1463
1464 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1465 return FAILURE;
1466
1467 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1468 return FAILURE;
1469
1470 return SUCCESS;
1471}
1472
1473
1474try
1475gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1476{
1477
1478 if (type_check (x, 0, BT_REAL) == FAILURE)
1479 return FAILURE;
1480
1481 if (type_check (i, 1, BT_INTEGER) == FAILURE)
1482 return FAILURE;
1483
1484 return SUCCESS;
1485}
1486
1487
1488try
1489gfc_check_shape (gfc_expr * source)
1490{
1491 gfc_array_ref *ar;
1492
1493 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1494 return SUCCESS;
1495
1496 ar = gfc_find_array_ref (source);
1497
1498 if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1499 {
1500 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1501 "an assumed size array", &source->where);
1502 return FAILURE;
1503 }
1504
1505 return SUCCESS;
1506}
1507
1508
1509try
1510gfc_check_size (gfc_expr * array, gfc_expr * dim)
1511{
1512
1513 if (array_check (array, 0) == FAILURE)
1514 return FAILURE;
1515
1516 if (dim != NULL)
1517 {
1518 if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1519 return FAILURE;
1520
1521 if (kind_value_check (dim, 1, gfc_default_integer_kind ()) == FAILURE)
1522 return FAILURE;
1523
1524 if (dim_rank_check (dim, array, 0) == FAILURE)
1525 return FAILURE;
1526 }
1527
1528 return SUCCESS;
1529}
1530
1531
1532try
1533gfc_check_sign (gfc_expr * a, gfc_expr * b)
1534{
1535
1536 if (int_or_real_check (a, 0) == FAILURE)
1537 return FAILURE;
1538
1539 if (same_type_check (a, 0, b, 1) == FAILURE)
1540 return FAILURE;
1541
1542 return SUCCESS;
1543}
1544
1545
1546try
1547gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1548{
1549
1550 if (source->rank >= GFC_MAX_DIMENSIONS)
1551 {
1552 must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1553 return FAILURE;
1554 }
1555
1556 if (dim_check (dim, 1, 0) == FAILURE)
1557 return FAILURE;
1558
1559 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1560 return FAILURE;
1561 if (scalar_check (ncopies, 2) == FAILURE)
1562 return FAILURE;
1563
1564 return SUCCESS;
1565}
1566
1567
1568try
1569gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
1570{
1571
1572 if (array_check (array, 0) == FAILURE)
1573 return FAILURE;
1574
1575 if (numeric_check (array, 0) == FAILURE)
1576 return FAILURE;
1577
1578 if (dim_check (dim, 1, 1) == FAILURE)
1579 return FAILURE;
1580
1581 if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
1582 return FAILURE;
1583
1584 return SUCCESS;
1585}
1586
1587
1588try
1589gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1590 gfc_expr * mold ATTRIBUTE_UNUSED,
1591 gfc_expr * size)
1592{
1593
1594 if (size != NULL)
1595 {
1596 if (type_check (size, 2, BT_INTEGER) == FAILURE)
1597 return FAILURE;
1598
1599 if (scalar_check (size, 2) == FAILURE)
1600 return FAILURE;
1601
1602 if (nonoptional_check (size, 2) == FAILURE)
1603 return FAILURE;
1604 }
1605
1606 return SUCCESS;
1607}
1608
1609
1610try
1611gfc_check_transpose (gfc_expr * matrix)
1612{
1613
1614 if (rank_check (matrix, 0, 2) == FAILURE)
1615 return FAILURE;
1616
1617 return SUCCESS;
1618}
1619
1620
1621try
1622gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
1623{
1624
1625 if (array_check (array, 0) == FAILURE)
1626 return FAILURE;
1627
1628 if (dim != NULL)
1629 {
1630 if (dim_check (dim, 1, 1) == FAILURE)
1631 return FAILURE;
1632
1633 if (dim_rank_check (dim, array, 0) == FAILURE)
1634 return FAILURE;
1635 }
1636 return SUCCESS;
1637}
1638
1639
1640try
1641gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1642{
1643
1644 if (rank_check (vector, 0, 1) == FAILURE)
1645 return FAILURE;
1646
1647 if (array_check (mask, 1) == FAILURE)
1648 return FAILURE;
1649
1650 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1651 return FAILURE;
1652
1653 if (same_type_check (vector, 0, field, 2) == FAILURE)
1654 return FAILURE;
1655
1656 return SUCCESS;
1657}
1658
1659
1660try
1661gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1662{
1663
1664 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1665 return FAILURE;
1666
1667 if (same_type_check (x, 0, y, 1) == FAILURE)
1668 return FAILURE;
1669
1670 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1671 return FAILURE;
1672
1673 return SUCCESS;
1674}
1675
1676
1677try
1678gfc_check_trim (gfc_expr * x)
1679{
1680 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1681 return FAILURE;
1682
1683 if (scalar_check (x, 0) == FAILURE)
1684 return FAILURE;
1685
1686 return SUCCESS;
1687}
1688
1689
1690/* Common check function for the half a dozen intrinsics that have a
1691 single real argument. */
1692
1693try
1694gfc_check_x (gfc_expr * x)
1695{
1696
1697 if (type_check (x, 0, BT_REAL) == FAILURE)
1698 return FAILURE;
1699
1700 return SUCCESS;
1701}
1702
1703
1704/************* Check functions for intrinsic subroutines *************/
1705
1706try
1707gfc_check_cpu_time (gfc_expr * time)
1708{
1709
1710 if (scalar_check (time, 0) == FAILURE)
1711 return FAILURE;
1712
1713 if (type_check (time, 0, BT_REAL) == FAILURE)
1714 return FAILURE;
1715
1716 if (variable_check (time, 0) == FAILURE)
1717 return FAILURE;
1718
1719 return SUCCESS;
1720}
1721
1722
1723try
1724gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1725 gfc_expr * zone, gfc_expr * values)
1726{
1727
1728 if (date != NULL)
1729 {
1730 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1731 return FAILURE;
1732 if (scalar_check (date, 0) == FAILURE)
1733 return FAILURE;
1734 if (variable_check (date, 0) == FAILURE)
1735 return FAILURE;
1736 }
1737
1738 if (time != NULL)
1739 {
1740 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1741 return FAILURE;
1742 if (scalar_check (time, 1) == FAILURE)
1743 return FAILURE;
1744 if (variable_check (time, 1) == FAILURE)
1745 return FAILURE;
1746 }
1747
1748 if (zone != NULL)
1749 {
1750 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1751 return FAILURE;
1752 if (scalar_check (zone, 2) == FAILURE)
1753 return FAILURE;
1754 if (variable_check (zone, 2) == FAILURE)
1755 return FAILURE;
1756 }
1757
1758 if (values != NULL)
1759 {
1760 if (type_check (values, 3, BT_INTEGER) == FAILURE)
1761 return FAILURE;
1762 if (array_check (values, 3) == FAILURE)
1763 return FAILURE;
1764 if (rank_check (values, 3, 1) == FAILURE)
1765 return FAILURE;
1766 if (variable_check (values, 3) == FAILURE)
1767 return FAILURE;
1768 }
1769
1770 return SUCCESS;
1771}
1772
1773
1774try
1775gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1776 gfc_expr * to, gfc_expr * topos)
1777{
1778
1779 if (type_check (from, 0, BT_INTEGER) == FAILURE)
1780 return FAILURE;
1781
1782 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1783 return FAILURE;
1784
1785 if (type_check (len, 2, BT_INTEGER) == FAILURE)
1786 return FAILURE;
1787
1788 if (same_type_check (from, 0, to, 3) == FAILURE)
1789 return FAILURE;
1790
1791 if (variable_check (to, 3) == FAILURE)
1792 return FAILURE;
1793
1794 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1795 return FAILURE;
1796
1797 return SUCCESS;
1798}
1799
1800
1801try
1802gfc_check_random_number (gfc_expr * harvest)
1803{
1804
1805 if (type_check (harvest, 0, BT_REAL) == FAILURE)
1806 return FAILURE;
1807
1808 if (variable_check (harvest, 0) == FAILURE)
1809 return FAILURE;
1810
1811 return SUCCESS;
1812}
1813
1814
1815try
1816gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1817{
1818
1819 if (size != NULL)
1820 {
1821 if (scalar_check (size, 0) == FAILURE)
1822 return FAILURE;
1823
1824 if (type_check (size, 0, BT_INTEGER) == FAILURE)
1825 return FAILURE;
1826
1827 if (variable_check (size, 0) == FAILURE)
1828 return FAILURE;
1829
1830 if (kind_value_check (size, 0, gfc_default_integer_kind ()) == FAILURE)
1831 return FAILURE;
1832 }
1833
1834 if (put != NULL)
1835 {
1836 if (array_check (put, 1) == FAILURE)
1837 return FAILURE;
1838 if (rank_check (put, 1, 1) == FAILURE)
1839 return FAILURE;
1840
1841 if (type_check (put, 1, BT_INTEGER) == FAILURE)
1842 return FAILURE;
1843
1844 if (kind_value_check (put, 1, gfc_default_integer_kind ()) == FAILURE)
1845 return FAILURE;
1846 }
1847
1848 if (get != NULL)
1849 {
1850 if (array_check (get, 2) == FAILURE)
1851 return FAILURE;
1852 if (rank_check (get, 2, 1) == FAILURE)
1853 return FAILURE;
1854
1855 if (type_check (get, 2, BT_INTEGER) == FAILURE)
1856 return FAILURE;
1857
1858 if (variable_check (get, 2) == FAILURE)
1859 return FAILURE;
1860
1861 if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE)
1862 return FAILURE;
1863 }
1864
1865 return SUCCESS;
1866}
21fdfcc1
SK		 1867
1868/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
1869 count, count_rate, and count_max are all optional arguments */
1870
1871try
1872gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
1873 gfc_expr * count_max)
1874{
1875
1876 if (count != NULL)
1877 {
1878 if (scalar_check (count, 0) == FAILURE)
1879 return FAILURE;
1880
1881 if (type_check (count, 0, BT_INTEGER) == FAILURE)
1882 return FAILURE;
1883
1884 if (variable_check (count, 0) == FAILURE)
1885 return FAILURE;
1886 }
1887
1888 if (count_rate != NULL)
1889 {
1890 if (scalar_check (count_rate, 1) == FAILURE)
1891 return FAILURE;
1892
1893 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
1894 return FAILURE;
1895
1896 if (variable_check (count_rate, 1) == FAILURE)
1897 return FAILURE;
1898
1899 if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
1900 return FAILURE;
1901
1902 }
1903
1904 if (count_max != NULL)
1905 {
1906 if (scalar_check (count_max, 2) == FAILURE)
1907 return FAILURE;
1908
1909 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
1910 return FAILURE;
1911
1912 if (variable_check (count_max, 2) == FAILURE)
1913 return FAILURE;
1914
1915 if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
1916 return FAILURE;
1917
1918 if (count_rate != NULL
1919 && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
1920 return FAILURE;
1921
1922 }
1923
1924 return SUCCESS;
1925}
GNU Compiler Collection
This page took 0.236765 seconds and 5 git commands to generate.