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