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