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