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