?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / fortran / check.c
blobc02656ce669f9f527d2c5077d0e8cf7ce53358aa
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_int_kind (gfc_expr *r)
2354 {
2355 if (type_check (r, 0, BT_INTEGER) == FAILURE)
2356 return FAILURE;
2357
2358 if (scalar_check (r, 0) == FAILURE)
2359 return FAILURE;
2360
2361 return SUCCESS;
2362 }
2363
2364
2365 try
2366 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2367 {
2368 if (p == NULL && r == NULL)
2369 {
2370 gfc_error ("Missing arguments to %s intrinsic at %L",
2371 gfc_current_intrinsic, gfc_current_intrinsic_where);
2372
2373 return FAILURE;
2374 }
2375
2376 if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2377 return FAILURE;
2378
2379 if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2380 return FAILURE;
2381
2382 return SUCCESS;
2383 }
2384
2385
2386 try
2387 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2388 {
2389 if (type_check (x, 0, BT_REAL) == FAILURE)
2390 return FAILURE;
2391
2392 if (type_check (i, 1, BT_INTEGER) == FAILURE)
2393 return FAILURE;
2394
2395 return SUCCESS;
2396 }
2397
2398
2399 try
2400 gfc_check_shape (gfc_expr *source)
2401 {
2402 gfc_array_ref *ar;
2403
2404 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2405 return SUCCESS;
2406
2407 ar = gfc_find_array_ref (source);
2408
2409 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
2410 {
2411 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2412 "an assumed size array", &source->where);
2413 return FAILURE;
2414 }
2415
2416 return SUCCESS;
2417 }
2418
2419
2420 try
2421 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2422 {
2423 if (int_or_real_check (a, 0) == FAILURE)
2424 return FAILURE;
2425
2426 if (same_type_check (a, 0, b, 1) == FAILURE)
2427 return FAILURE;
2428
2429 return SUCCESS;
2430 }
2431
2432
2433 try
2434 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2435 {
2436 if (array_check (array, 0) == FAILURE)
2437 return FAILURE;
2438
2439 if (dim != NULL)
2440 {
2441 if (dim_check (dim, 1, true) == FAILURE)
2442 return FAILURE;
2443
2444 if (dim_rank_check (dim, array, 0) == FAILURE)
2445 return FAILURE;
2446 }
2447
2448 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2449 return FAILURE;
2450 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2451 "with KIND argument at %L",
2452 gfc_current_intrinsic, &kind->where) == FAILURE)
2453 return FAILURE;
2454
2455
2456 return SUCCESS;
2457 }
2458
2459
2460 try
2461 gfc_check_sizeof (gfc_expr *arg __attribute__((unused)))
2462 {
2463 return SUCCESS;
2464 }
2465
2466
2467 try
2468 gfc_check_sleep_sub (gfc_expr *seconds)
2469 {
2470 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2471 return FAILURE;
2472
2473 if (scalar_check (seconds, 0) == FAILURE)
2474 return FAILURE;
2475
2476 return SUCCESS;
2477 }
2478
2479
2480 try
2481 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2482 {
2483 if (source->rank >= GFC_MAX_DIMENSIONS)
2484 {
2485 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2486 "than rank %d", gfc_current_intrinsic_arg[0],
2487 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2488
2489 return FAILURE;
2490 }
2491
2492 if (dim == NULL)
2493 return FAILURE;
2494
2495 if (dim_check (dim, 1, false) == FAILURE)
2496 return FAILURE;
2497
2498 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2499 return FAILURE;
2500
2501 if (scalar_check (ncopies, 2) == FAILURE)
2502 return FAILURE;
2503
2504 return SUCCESS;
2505 }
2506
2507
2508 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2509 functions). */
2510
2511 try
2512 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2513 {
2514 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2515 return FAILURE;
2516
2517 if (scalar_check (unit, 0) == FAILURE)
2518 return FAILURE;
2519
2520 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2521 return FAILURE;
2522
2523 if (status == NULL)
2524 return SUCCESS;
2525
2526 if (type_check (status, 2, BT_INTEGER) == FAILURE
2527 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2528 || scalar_check (status, 2) == FAILURE)
2529 return FAILURE;
2530
2531 return SUCCESS;
2532 }
2533
2534
2535 try
2536 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2537 {
2538 return gfc_check_fgetputc_sub (unit, c, NULL);
2539 }
2540
2541
2542 try
2543 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2544 {
2545 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2546 return FAILURE;
2547
2548 if (status == NULL)
2549 return SUCCESS;
2550
2551 if (type_check (status, 1, BT_INTEGER) == FAILURE
2552 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2553 || scalar_check (status, 1) == FAILURE)
2554 return FAILURE;
2555
2556 return SUCCESS;
2557 }
2558
2559
2560 try
2561 gfc_check_fgetput (gfc_expr *c)
2562 {
2563 return gfc_check_fgetput_sub (c, NULL);
2564 }
2565
2566
2567 try
2568 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2569 {
2570 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2571 return FAILURE;
2572
2573 if (scalar_check (unit, 0) == FAILURE)
2574 return FAILURE;
2575
2576 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2577 return FAILURE;
2578
2579 if (scalar_check (offset, 1) == FAILURE)
2580 return FAILURE;
2581
2582 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2583 return FAILURE;
2584
2585 if (scalar_check (whence, 2) == FAILURE)
2586 return FAILURE;
2587
2588 if (status == NULL)
2589 return SUCCESS;
2590
2591 if (type_check (status, 3, BT_INTEGER) == FAILURE)
2592 return FAILURE;
2593
2594 if (kind_value_check (status, 3, 4) == FAILURE)
2595 return FAILURE;
2596
2597 if (scalar_check (status, 3) == FAILURE)
2598 return FAILURE;
2599
2600 return SUCCESS;
2601 }
2602
2603
2604
2605 try
2606 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2607 {
2608 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2609 return FAILURE;
2610
2611 if (scalar_check (unit, 0) == FAILURE)
2612 return FAILURE;
2613
2614 if (type_check (array, 1, BT_INTEGER) == FAILURE
2615 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2616 return FAILURE;
2617
2618 if (array_check (array, 1) == FAILURE)
2619 return FAILURE;
2620
2621 return SUCCESS;
2622 }
2623
2624
2625 try
2626 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2627 {
2628 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2629 return FAILURE;
2630
2631 if (scalar_check (unit, 0) == FAILURE)
2632 return FAILURE;
2633
2634 if (type_check (array, 1, BT_INTEGER) == FAILURE
2635 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2636 return FAILURE;
2637
2638 if (array_check (array, 1) == FAILURE)
2639 return FAILURE;
2640
2641 if (status == NULL)
2642 return SUCCESS;
2643
2644 if (type_check (status, 2, BT_INTEGER) == FAILURE
2645 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2646 return FAILURE;
2647
2648 if (scalar_check (status, 2) == FAILURE)
2649 return FAILURE;
2650
2651 return SUCCESS;
2652 }
2653
2654
2655 try
2656 gfc_check_ftell (gfc_expr *unit)
2657 {
2658 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2659 return FAILURE;
2660
2661 if (scalar_check (unit, 0) == FAILURE)
2662 return FAILURE;
2663
2664 return SUCCESS;
2665 }
2666
2667
2668 try
2669 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2670 {
2671 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2672 return FAILURE;
2673
2674 if (scalar_check (unit, 0) == FAILURE)
2675 return FAILURE;
2676
2677 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2678 return FAILURE;
2679
2680 if (scalar_check (offset, 1) == FAILURE)
2681 return FAILURE;
2682
2683 return SUCCESS;
2684 }
2685
2686
2687 try
2688 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2689 {
2690 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2691 return FAILURE;
2692
2693 if (type_check (array, 1, BT_INTEGER) == FAILURE
2694 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2695 return FAILURE;
2696
2697 if (array_check (array, 1) == FAILURE)
2698 return FAILURE;
2699
2700 return SUCCESS;
2701 }
2702
2703
2704 try
2705 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2706 {
2707 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2708 return FAILURE;
2709
2710 if (type_check (array, 1, BT_INTEGER) == FAILURE
2711 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2712 return FAILURE;
2713
2714 if (array_check (array, 1) == FAILURE)
2715 return FAILURE;
2716
2717 if (status == NULL)
2718 return SUCCESS;
2719
2720 if (type_check (status, 2, BT_INTEGER) == FAILURE
2721 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2722 return FAILURE;
2723
2724 if (scalar_check (status, 2) == FAILURE)
2725 return FAILURE;
2726
2727 return SUCCESS;
2728 }
2729
2730
2731 try
2732 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2733 gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2734 {
2735 if (mold->ts.type == BT_HOLLERITH)
2736 {
2737 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
2738 &mold->where, gfc_basic_typename (BT_HOLLERITH));
2739 return FAILURE;
2740 }
2741
2742 if (size != NULL)
2743 {
2744 if (type_check (size, 2, BT_INTEGER) == FAILURE)
2745 return FAILURE;
2746
2747 if (scalar_check (size, 2) == FAILURE)
2748 return FAILURE;
2749
2750 if (nonoptional_check (size, 2) == FAILURE)
2751 return FAILURE;
2752 }
2753
2754 return SUCCESS;
2755 }
2756
2757
2758 try
2759 gfc_check_transpose (gfc_expr *matrix)
2760 {
2761 if (rank_check (matrix, 0, 2) == FAILURE)
2762 return FAILURE;
2763
2764 return SUCCESS;
2765 }
2766
2767
2768 try
2769 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2770 {
2771 if (array_check (array, 0) == FAILURE)
2772 return FAILURE;
2773
2774 if (dim != NULL)
2775 {
2776 if (dim_check (dim, 1, false) == FAILURE)
2777 return FAILURE;
2778
2779 if (dim_rank_check (dim, array, 0) == FAILURE)
2780 return FAILURE;
2781 }
2782
2783 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2784 return FAILURE;
2785 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2786 "with KIND argument at %L",
2787 gfc_current_intrinsic, &kind->where) == FAILURE)
2788 return FAILURE;
2789
2790 return SUCCESS;
2791 }
2792
2793
2794 try
2795 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2796 {
2797 if (rank_check (vector, 0, 1) == FAILURE)
2798 return FAILURE;
2799
2800 if (array_check (mask, 1) == FAILURE)
2801 return FAILURE;
2802
2803 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2804 return FAILURE;
2805
2806 if (same_type_check (vector, 0, field, 2) == FAILURE)
2807 return FAILURE;
2808
2809 return SUCCESS;
2810 }
2811
2812
2813 try
2814 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2815 {
2816 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2817 return FAILURE;
2818
2819 if (same_type_check (x, 0, y, 1) == FAILURE)
2820 return FAILURE;
2821
2822 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2823 return FAILURE;
2824
2825 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2826 return FAILURE;
2827 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2828 "with KIND argument at %L",
2829 gfc_current_intrinsic, &kind->where) == FAILURE)
2830 return FAILURE;
2831
2832 return SUCCESS;
2833 }
2834
2835
2836 try
2837 gfc_check_trim (gfc_expr *x)
2838 {
2839 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2840 return FAILURE;
2841
2842 if (scalar_check (x, 0) == FAILURE)
2843 return FAILURE;
2844
2845 return SUCCESS;
2846 }
2847
2848
2849 try
2850 gfc_check_ttynam (gfc_expr *unit)
2851 {
2852 if (scalar_check (unit, 0) == FAILURE)
2853 return FAILURE;
2854
2855 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2856 return FAILURE;
2857
2858 return SUCCESS;
2859 }
2860
2861
2862 /* Common check function for the half a dozen intrinsics that have a
2863 single real argument. */
2864
2865 try
2866 gfc_check_x (gfc_expr *x)
2867 {
2868 if (type_check (x, 0, BT_REAL) == FAILURE)
2869 return FAILURE;
2870
2871 return SUCCESS;
2872 }
2873
2874
2875 /************* Check functions for intrinsic subroutines *************/
2876
2877 try
2878 gfc_check_cpu_time (gfc_expr *time)
2879 {
2880 if (scalar_check (time, 0) == FAILURE)
2881 return FAILURE;
2882
2883 if (type_check (time, 0, BT_REAL) == FAILURE)
2884 return FAILURE;
2885
2886 if (variable_check (time, 0) == FAILURE)
2887 return FAILURE;
2888
2889 return SUCCESS;
2890 }
2891
2892
2893 try
2894 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2895 gfc_expr *zone, gfc_expr *values)
2896 {
2897 if (date != NULL)
2898 {
2899 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2900 return FAILURE;
2901 if (scalar_check (date, 0) == FAILURE)
2902 return FAILURE;
2903 if (variable_check (date, 0) == FAILURE)
2904 return FAILURE;
2905 }
2906
2907 if (time != NULL)
2908 {
2909 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2910 return FAILURE;
2911 if (scalar_check (time, 1) == FAILURE)
2912 return FAILURE;
2913 if (variable_check (time, 1) == FAILURE)
2914 return FAILURE;
2915 }
2916
2917 if (zone != NULL)
2918 {
2919 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2920 return FAILURE;
2921 if (scalar_check (zone, 2) == FAILURE)
2922 return FAILURE;
2923 if (variable_check (zone, 2) == FAILURE)
2924 return FAILURE;
2925 }
2926
2927 if (values != NULL)
2928 {
2929 if (type_check (values, 3, BT_INTEGER) == FAILURE)
2930 return FAILURE;
2931 if (array_check (values, 3) == FAILURE)
2932 return FAILURE;
2933 if (rank_check (values, 3, 1) == FAILURE)
2934 return FAILURE;
2935 if (variable_check (values, 3) == FAILURE)
2936 return FAILURE;
2937 }
2938
2939 return SUCCESS;
2940 }
2941
2942
2943 try
2944 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2945 gfc_expr *to, gfc_expr *topos)
2946 {
2947 if (type_check (from, 0, BT_INTEGER) == FAILURE)
2948 return FAILURE;
2949
2950 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2951 return FAILURE;
2952
2953 if (type_check (len, 2, BT_INTEGER) == FAILURE)
2954 return FAILURE;
2955
2956 if (same_type_check (from, 0, to, 3) == FAILURE)
2957 return FAILURE;
2958
2959 if (variable_check (to, 3) == FAILURE)
2960 return FAILURE;
2961
2962 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2963 return FAILURE;
2964
2965 return SUCCESS;
2966 }
2967
2968
2969 try
2970 gfc_check_random_number (gfc_expr *harvest)
2971 {
2972 if (type_check (harvest, 0, BT_REAL) == FAILURE)
2973 return FAILURE;
2974
2975 if (variable_check (harvest, 0) == FAILURE)
2976 return FAILURE;
2977
2978 return SUCCESS;
2979 }
2980
2981
2982 try
2983 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2984 {
2985 unsigned int nargs = 0;
2986 locus *where = NULL;
2987
2988 if (size != NULL)
2989 {
2990 if (size->expr_type != EXPR_VARIABLE
2991 || !size->symtree->n.sym->attr.optional)
2992 nargs++;
2993
2994 if (scalar_check (size, 0) == FAILURE)
2995 return FAILURE;
2996
2997 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2998 return FAILURE;
2999
3000 if (variable_check (size, 0) == FAILURE)
3001 return FAILURE;
3002
3003 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3004 return FAILURE;
3005 }
3006
3007 if (put != NULL)
3008 {
3009 if (put->expr_type != EXPR_VARIABLE
3010 || !put->symtree->n.sym->attr.optional)
3011 {
3012 nargs++;
3013 where = &put->where;
3014 }
3015
3016 if (array_check (put, 1) == FAILURE)
3017 return FAILURE;
3018
3019 if (rank_check (put, 1, 1) == FAILURE)
3020 return FAILURE;
3021
3022 if (type_check (put, 1, BT_INTEGER) == FAILURE)
3023 return FAILURE;
3024
3025 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3026 return FAILURE;
3027 }
3028
3029 if (get != NULL)
3030 {
3031 if (get->expr_type != EXPR_VARIABLE
3032 || !get->symtree->n.sym->attr.optional)
3033 {
3034 nargs++;
3035 where = &get->where;
3036 }
3037
3038 if (array_check (get, 2) == FAILURE)
3039 return FAILURE;
3040
3041 if (rank_check (get, 2, 1) == FAILURE)
3042 return FAILURE;
3043
3044 if (type_check (get, 2, BT_INTEGER) == FAILURE)
3045 return FAILURE;
3046
3047 if (variable_check (get, 2) == FAILURE)
3048 return FAILURE;
3049
3050 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3051 return FAILURE;
3052 }
3053
3054 /* RANDOM_SEED may not have more than one non-optional argument. */
3055 if (nargs > 1)
3056 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3057
3058 return SUCCESS;
3059 }
3060
3061
3062 try
3063 gfc_check_second_sub (gfc_expr *time)
3064 {
3065 if (scalar_check (time, 0) == FAILURE)
3066 return FAILURE;
3067
3068 if (type_check (time, 0, BT_REAL) == FAILURE)
3069 return FAILURE;
3070
3071 if (kind_value_check(time, 0, 4) == FAILURE)
3072 return FAILURE;
3073
3074 return SUCCESS;
3075 }
3076
3077
3078 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
3079 count, count_rate, and count_max are all optional arguments */
3080
3081 try
3082 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3083 gfc_expr *count_max)
3084 {
3085 if (count != NULL)
3086 {
3087 if (scalar_check (count, 0) == FAILURE)
3088 return FAILURE;
3089
3090 if (type_check (count, 0, BT_INTEGER) == FAILURE)
3091 return FAILURE;
3092
3093 if (variable_check (count, 0) == FAILURE)
3094 return FAILURE;
3095 }
3096
3097 if (count_rate != NULL)
3098 {
3099 if (scalar_check (count_rate, 1) == FAILURE)
3100 return FAILURE;
3101
3102 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3103 return FAILURE;
3104
3105 if (variable_check (count_rate, 1) == FAILURE)
3106 return FAILURE;
3107
3108 if (count != NULL
3109 && same_type_check (count, 0, count_rate, 1) == FAILURE)
3110 return FAILURE;
3111
3112 }
3113
3114 if (count_max != NULL)
3115 {
3116 if (scalar_check (count_max, 2) == FAILURE)
3117 return FAILURE;
3118
3119 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3120 return FAILURE;
3121
3122 if (variable_check (count_max, 2) == FAILURE)
3123 return FAILURE;
3124
3125 if (count != NULL
3126 && same_type_check (count, 0, count_max, 2) == FAILURE)
3127 return FAILURE;
3128
3129 if (count_rate != NULL
3130 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3131 return FAILURE;
3132 }
3133
3134 return SUCCESS;
3135 }
3136
3137
3138 try
3139 gfc_check_irand (gfc_expr *x)
3140 {
3141 if (x == NULL)
3142 return SUCCESS;
3143
3144 if (scalar_check (x, 0) == FAILURE)
3145 return FAILURE;
3146
3147 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3148 return FAILURE;
3149
3150 if (kind_value_check(x, 0, 4) == FAILURE)
3151 return FAILURE;
3152
3153 return SUCCESS;
3154 }
3155
3156
3157 try
3158 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3159 {
3160 if (scalar_check (seconds, 0) == FAILURE)
3161 return FAILURE;
3162
3163 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3164 return FAILURE;
3165
3166 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3167 {
3168 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3169 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3170 gfc_current_intrinsic, &handler->where);
3171 return FAILURE;
3172 }
3173
3174 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3175 return FAILURE;
3176
3177 if (status == NULL)
3178 return SUCCESS;
3179
3180 if (scalar_check (status, 2) == FAILURE)
3181 return FAILURE;
3182
3183 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3184 return FAILURE;
3185
3186 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3187 return FAILURE;
3188
3189 return SUCCESS;
3190 }
3191
3192
3193 try
3194 gfc_check_rand (gfc_expr *x)
3195 {
3196 if (x == NULL)
3197 return SUCCESS;
3198
3199 if (scalar_check (x, 0) == FAILURE)
3200 return FAILURE;
3201
3202 if (type_check (x, 0, BT_INTEGER) == FAILURE)
3203 return FAILURE;
3204
3205 if (kind_value_check(x, 0, 4) == FAILURE)
3206 return FAILURE;
3207
3208 return SUCCESS;
3209 }
3210
3211
3212 try
3213 gfc_check_srand (gfc_expr *x)
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_ctime_sub (gfc_expr *time, gfc_expr *result)
3230 {
3231 if (scalar_check (time, 0) == FAILURE)
3232 return FAILURE;
3233
3234 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3235 return FAILURE;
3236
3237 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3238 return FAILURE;
3239
3240 return SUCCESS;
3241 }
3242
3243
3244 try
3245 gfc_check_dtime_etime (gfc_expr *x)
3246 {
3247 if (array_check (x, 0) == FAILURE)
3248 return FAILURE;
3249
3250 if (rank_check (x, 0, 1) == FAILURE)
3251 return FAILURE;
3252
3253 if (variable_check (x, 0) == FAILURE)
3254 return FAILURE;
3255
3256 if (type_check (x, 0, BT_REAL) == FAILURE)
3257 return FAILURE;
3258
3259 if (kind_value_check(x, 0, 4) == FAILURE)
3260 return FAILURE;
3261
3262 return SUCCESS;
3263 }
3264
3265
3266 try
3267 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3268 {
3269 if (array_check (values, 0) == FAILURE)
3270 return FAILURE;
3271
3272 if (rank_check (values, 0, 1) == FAILURE)
3273 return FAILURE;
3274
3275 if (variable_check (values, 0) == FAILURE)
3276 return FAILURE;
3277
3278 if (type_check (values, 0, BT_REAL) == FAILURE)
3279 return FAILURE;
3280
3281 if (kind_value_check(values, 0, 4) == FAILURE)
3282 return FAILURE;
3283
3284 if (scalar_check (time, 1) == FAILURE)
3285 return FAILURE;
3286
3287 if (type_check (time, 1, BT_REAL) == FAILURE)
3288 return FAILURE;
3289
3290 if (kind_value_check(time, 1, 4) == FAILURE)
3291 return FAILURE;
3292
3293 return SUCCESS;
3294 }
3295
3296
3297 try
3298 gfc_check_fdate_sub (gfc_expr *date)
3299 {
3300 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3301 return FAILURE;
3302
3303 return SUCCESS;
3304 }
3305
3306
3307 try
3308 gfc_check_gerror (gfc_expr *msg)
3309 {
3310 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3311 return FAILURE;
3312
3313 return SUCCESS;
3314 }
3315
3316
3317 try
3318 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3319 {
3320 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3321 return FAILURE;
3322
3323 if (status == NULL)
3324 return SUCCESS;
3325
3326 if (scalar_check (status, 1) == FAILURE)
3327 return FAILURE;
3328
3329 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3330 return FAILURE;
3331
3332 return SUCCESS;
3333 }
3334
3335
3336 try
3337 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
3338 {
3339 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
3340 return FAILURE;
3341
3342 if (pos->ts.kind > gfc_default_integer_kind)
3343 {
3344 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3345 "not wider than the default kind (%d)",
3346 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3347 &pos->where, gfc_default_integer_kind);
3348 return FAILURE;
3349 }
3350
3351 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
3352 return FAILURE;
3353
3354 return SUCCESS;
3355 }
3356
3357
3358 try
3359 gfc_check_getlog (gfc_expr *msg)
3360 {
3361 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3362 return FAILURE;
3363
3364 return SUCCESS;
3365 }
3366
3367
3368 try
3369 gfc_check_exit (gfc_expr *status)
3370 {
3371 if (status == NULL)
3372 return SUCCESS;
3373
3374 if (type_check (status, 0, BT_INTEGER) == FAILURE)
3375 return FAILURE;
3376
3377 if (scalar_check (status, 0) == FAILURE)
3378 return FAILURE;
3379
3380 return SUCCESS;
3381 }
3382
3383
3384 try
3385 gfc_check_flush (gfc_expr *unit)
3386 {
3387 if (unit == NULL)
3388 return SUCCESS;
3389
3390 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3391 return FAILURE;
3392
3393 if (scalar_check (unit, 0) == FAILURE)
3394 return FAILURE;
3395
3396 return SUCCESS;
3397 }
3398
3399
3400 try
3401 gfc_check_free (gfc_expr *i)
3402 {
3403 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3404 return FAILURE;
3405
3406 if (scalar_check (i, 0) == FAILURE)
3407 return FAILURE;
3408
3409 return SUCCESS;
3410 }
3411
3412
3413 try
3414 gfc_check_hostnm (gfc_expr *name)
3415 {
3416 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3417 return FAILURE;
3418
3419 return SUCCESS;
3420 }
3421
3422
3423 try
3424 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3425 {
3426 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3427 return FAILURE;
3428
3429 if (status == NULL)
3430 return SUCCESS;
3431
3432 if (scalar_check (status, 1) == FAILURE)
3433 return FAILURE;
3434
3435 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3436 return FAILURE;
3437
3438 return SUCCESS;
3439 }
3440
3441
3442 try
3443 gfc_check_itime_idate (gfc_expr *values)
3444 {
3445 if (array_check (values, 0) == FAILURE)
3446 return FAILURE;
3447
3448 if (rank_check (values, 0, 1) == FAILURE)
3449 return FAILURE;
3450
3451 if (variable_check (values, 0) == FAILURE)
3452 return FAILURE;
3453
3454 if (type_check (values, 0, BT_INTEGER) == FAILURE)
3455 return FAILURE;
3456
3457 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3458 return FAILURE;
3459
3460 return SUCCESS;
3461 }
3462
3463
3464 try
3465 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3466 {
3467 if (type_check (time, 0, BT_INTEGER) == FAILURE)
3468 return FAILURE;
3469
3470 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3471 return FAILURE;
3472
3473 if (scalar_check (time, 0) == FAILURE)
3474 return FAILURE;
3475
3476 if (array_check (values, 1) == FAILURE)
3477 return FAILURE;
3478
3479 if (rank_check (values, 1, 1) == FAILURE)
3480 return FAILURE;
3481
3482 if (variable_check (values, 1) == FAILURE)
3483 return FAILURE;
3484
3485 if (type_check (values, 1, BT_INTEGER) == FAILURE)
3486 return FAILURE;
3487
3488 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3489 return FAILURE;
3490
3491 return SUCCESS;
3492 }
3493
3494
3495 try
3496 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3497 {
3498 if (scalar_check (unit, 0) == FAILURE)
3499 return FAILURE;
3500
3501 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3502 return FAILURE;
3503
3504 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3505 return FAILURE;
3506
3507 return SUCCESS;
3508 }
3509
3510
3511 try
3512 gfc_check_isatty (gfc_expr *unit)
3513 {
3514 if (unit == NULL)
3515 return FAILURE;
3516
3517 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3518 return FAILURE;
3519
3520 if (scalar_check (unit, 0) == FAILURE)
3521 return FAILURE;
3522
3523 return SUCCESS;
3524 }
3525
3526
3527 try
3528 gfc_check_isnan (gfc_expr *x)
3529 {
3530 if (type_check (x, 0, BT_REAL) == FAILURE)
3531 return FAILURE;
3532
3533 return SUCCESS;
3534 }
3535
3536
3537 try
3538 gfc_check_perror (gfc_expr *string)
3539 {
3540 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3541 return FAILURE;
3542
3543 return SUCCESS;
3544 }
3545
3546
3547 try
3548 gfc_check_umask (gfc_expr *mask)
3549 {
3550 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3551 return FAILURE;
3552
3553 if (scalar_check (mask, 0) == FAILURE)
3554 return FAILURE;
3555
3556 return SUCCESS;
3557 }
3558
3559
3560 try
3561 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3562 {
3563 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3564 return FAILURE;
3565
3566 if (scalar_check (mask, 0) == FAILURE)
3567 return FAILURE;
3568
3569 if (old == NULL)
3570 return SUCCESS;
3571
3572 if (scalar_check (old, 1) == FAILURE)
3573 return FAILURE;
3574
3575 if (type_check (old, 1, BT_INTEGER) == FAILURE)
3576 return FAILURE;
3577
3578 return SUCCESS;
3579 }
3580
3581
3582 try
3583 gfc_check_unlink (gfc_expr *name)
3584 {
3585 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3586 return FAILURE;
3587
3588 return SUCCESS;
3589 }
3590
3591
3592 try
3593 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3594 {
3595 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3596 return FAILURE;
3597
3598 if (status == NULL)
3599 return SUCCESS;
3600
3601 if (scalar_check (status, 1) == FAILURE)
3602 return FAILURE;
3603
3604 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3605 return FAILURE;
3606
3607 return SUCCESS;
3608 }
3609
3610
3611 try
3612 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3613 {
3614 if (scalar_check (number, 0) == FAILURE)
3615 return FAILURE;
3616
3617 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3618 return FAILURE;
3619
3620 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3621 {
3622 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3623 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3624 gfc_current_intrinsic, &handler->where);
3625 return FAILURE;
3626 }
3627
3628 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3629 return FAILURE;
3630
3631 return SUCCESS;
3632 }
3633
3634
3635 try
3636 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3637 {
3638 if (scalar_check (number, 0) == FAILURE)
3639 return FAILURE;
3640
3641 if (type_check (number, 0, BT_INTEGER) == FAILURE)
3642 return FAILURE;
3643
3644 if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3645 {
3646 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3647 "or PROCEDURE", gfc_current_intrinsic_arg[1],
3648 gfc_current_intrinsic, &handler->where);
3649 return FAILURE;
3650 }
3651
3652 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3653 return FAILURE;
3654
3655 if (status == NULL)
3656 return SUCCESS;
3657
3658 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3659 return FAILURE;
3660
3661 if (scalar_check (status, 2) == FAILURE)
3662 return FAILURE;
3663
3664 return SUCCESS;
3665 }
3666
3667
3668 try
3669 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3670 {
3671 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3672 return FAILURE;
3673
3674 if (scalar_check (status, 1) == FAILURE)
3675 return FAILURE;
3676
3677 if (type_check (status, 1, BT_INTEGER) == FAILURE)
3678 return FAILURE;
3679
3680 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3681 return FAILURE;
3682
3683 return SUCCESS;
3684 }
3685
3686
3687 /* This is used for the GNU intrinsics AND, OR and XOR. */
3688 try
3689 gfc_check_and (gfc_expr *i, gfc_expr *j)
3690 {
3691 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3692 {
3693 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3694 "or LOGICAL", gfc_current_intrinsic_arg[0],
3695 gfc_current_intrinsic, &i->where);
3696 return FAILURE;
3697 }
3698
3699 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3700 {
3701 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3702 "or LOGICAL", gfc_current_intrinsic_arg[1],
3703 gfc_current_intrinsic, &j->where);
3704 return FAILURE;
3705 }
3706
3707 if (i->ts.type != j->ts.type)
3708 {
3709 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3710 "have the same type", gfc_current_intrinsic_arg[0],
3711 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3712 &j->where);
3713 return FAILURE;
3714 }
3715
3716 if (scalar_check (i, 0) == FAILURE)
3717 return FAILURE;
3718
3719 if (scalar_check (j, 1) == FAILURE)
3720 return FAILURE;
3721
3722 return SUCCESS;
3723 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org