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