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