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