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