?  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
blob34b3a68057ca66fd13aaef422b1bd3cd43e39cc1
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 if (size->expr_type == EXPR_CONSTANT)
1971 {
1972 gfc_extract_int (size, &i3);
1973 if (i3 <= 0)
1974 {
1975 gfc_error ("SIZE at %L must be positive", &size->where);
1976 return FAILURE;
1977 }
1978
1979 if (shift->expr_type == EXPR_CONSTANT)
1980 {
1981 gfc_extract_int (shift, &i2);
1982 if (i2 < 0)
1983 i2 = -i2;
1984
1985 if (i2 > i3)
1986 {
1987 gfc_error ("The absolute value of SHIFT at %L must be less "
1988 "than or equal to SIZE at %L", &shift->where,
1989 &size->where);
1990 return FAILURE;
1991 }
1992 }
1993 }
1994 }
1995 else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
1996 return FAILURE;
1997
1998 return SUCCESS;
1999 }
2000
2001
2002 gfc_try
2003 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
2004 {
2005 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2006 return FAILURE;
2007
2008 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2009 return FAILURE;
2010
2011 return SUCCESS;
2012 }
2013
2014
2015 gfc_try
2016 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
2017 {
2018 if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2019 return FAILURE;
2020
2021 if (scalar_check (pid, 0) == FAILURE)
2022 return FAILURE;
2023
2024 if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2025 return FAILURE;
2026
2027 if (scalar_check (sig, 1) == FAILURE)
2028 return FAILURE;
2029
2030 if (status == NULL)
2031 return SUCCESS;
2032
2033 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2034 return FAILURE;
2035
2036 if (scalar_check (status, 2) == FAILURE)
2037 return FAILURE;
2038
2039 return SUCCESS;
2040 }
2041
2042
2043 gfc_try
2044 gfc_check_kind (gfc_expr *x)
2045 {
2046 if (x->ts.type == BT_DERIVED)
2047 {
2048 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2049 "non-derived type", gfc_current_intrinsic_arg[0]->name,
2050 gfc_current_intrinsic, &x->where);
2051 return FAILURE;
2052 }
2053
2054 return SUCCESS;
2055 }
2056
2057
2058 gfc_try
2059 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2060 {
2061 if (array_check (array, 0) == FAILURE)
2062 return FAILURE;
2063
2064 if (dim_check (dim, 1, false) == FAILURE)
2065 return FAILURE;
2066
2067 if (dim_rank_check (dim, array, 1) == FAILURE)
2068 return FAILURE;
2069
2070 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2071 return FAILURE;
2072 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2073 "with KIND argument at %L",
2074 gfc_current_intrinsic, &kind->where) == FAILURE)
2075 return FAILURE;
2076
2077 return SUCCESS;
2078 }
2079
2080
2081 gfc_try
2082 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
2083 {
2084 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2085 {
2086 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2087 return FAILURE;
2088 }
2089
2090 if (coarray_check (coarray, 0) == FAILURE)
2091 return FAILURE;
2092
2093 if (dim != NULL)
2094 {
2095 if (dim_check (dim, 1, false) == FAILURE)
2096 return FAILURE;
2097
2098 if (dim_corank_check (dim, coarray) == FAILURE)
2099 return FAILURE;
2100 }
2101
2102 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2103 return FAILURE;
2104
2105 return SUCCESS;
2106 }
2107
2108
2109 gfc_try
2110 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
2111 {
2112 if (type_check (s, 0, BT_CHARACTER) == FAILURE)
2113 return FAILURE;
2114
2115 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2116 return FAILURE;
2117 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2118 "with KIND argument at %L",
2119 gfc_current_intrinsic, &kind->where) == FAILURE)
2120 return FAILURE;
2121
2122 return SUCCESS;
2123 }
2124
2125
2126 gfc_try
2127 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
2128 {
2129 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2130 return FAILURE;
2131 if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
2132 return FAILURE;
2133
2134 if (type_check (b, 1, BT_CHARACTER) == FAILURE)
2135 return FAILURE;
2136 if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
2137 return FAILURE;
2138
2139 return SUCCESS;
2140 }
2141
2142
2143 gfc_try
2144 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
2145 {
2146 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2147 return FAILURE;
2148 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2149 return FAILURE;
2150
2151 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2152 return FAILURE;
2153 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2154 return FAILURE;
2155
2156 return SUCCESS;
2157 }
2158
2159
2160 gfc_try
2161 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2162 {
2163 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2164 return FAILURE;
2165 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2166 return FAILURE;
2167
2168 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2169 return FAILURE;
2170 if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
2171 return FAILURE;
2172
2173 if (status == NULL)
2174 return SUCCESS;
2175
2176 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2177 return FAILURE;
2178
2179 if (scalar_check (status, 2) == FAILURE)
2180 return FAILURE;
2181
2182 return SUCCESS;
2183 }
2184
2185
2186 gfc_try
2187 gfc_check_loc (gfc_expr *expr)
2188 {
2189 return variable_check (expr, 0, true);
2190 }
2191
2192
2193 gfc_try
2194 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
2195 {
2196 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2197 return FAILURE;
2198 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2199 return FAILURE;
2200
2201 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2202 return FAILURE;
2203 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2204 return FAILURE;
2205
2206 return SUCCESS;
2207 }
2208
2209
2210 gfc_try
2211 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2212 {
2213 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2214 return FAILURE;
2215 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2216 return FAILURE;
2217
2218 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2219 return FAILURE;
2220 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2221 return FAILURE;
2222
2223 if (status == NULL)
2224 return SUCCESS;
2225
2226 if (type_check (status, 2, BT_INTEGER) == FAILURE)
2227 return FAILURE;
2228
2229 if (scalar_check (status, 2) == FAILURE)
2230 return FAILURE;
2231
2232 return SUCCESS;
2233 }
2234
2235
2236 gfc_try
2237 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
2238 {
2239 if (type_check (a, 0, BT_LOGICAL) == FAILURE)
2240 return FAILURE;
2241 if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
2242 return FAILURE;
2243
2244 return SUCCESS;
2245 }
2246
2247
2248 /* Min/max family. */
2249
2250 static gfc_try
2251 min_max_args (gfc_actual_arglist *arg)
2252 {
2253 if (arg == NULL || arg->next == NULL)
2254 {
2255 gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2256 gfc_current_intrinsic, gfc_current_intrinsic_where);
2257 return FAILURE;
2258 }
2259
2260 return SUCCESS;
2261 }
2262
2263
2264 static gfc_try
2265 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
2266 {
2267 gfc_actual_arglist *arg, *tmp;
2268
2269 gfc_expr *x;
2270 int m, n;
2271
2272 if (min_max_args (arglist) == FAILURE)
2273 return FAILURE;
2274
2275 for (arg = arglist, n=1; arg; arg = arg->next, n++)
2276 {
2277 x = arg->expr;
2278 if (x->ts.type != type || x->ts.kind != kind)
2279 {
2280 if (x->ts.type == type)
2281 {
2282 if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
2283 "kinds at %L", &x->where) == FAILURE)
2284 return FAILURE;
2285 }
2286 else
2287 {
2288 gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2289 "%s(%d)", n, gfc_current_intrinsic, &x->where,
2290 gfc_basic_typename (type), kind);
2291 return FAILURE;
2292 }
2293 }
2294
2295 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
2296 if (gfc_check_conformance (tmp->expr, x,
2297 "arguments 'a%d' and 'a%d' for "
2298 "intrinsic '%s'", m, n,
2299 gfc_current_intrinsic) == FAILURE)
2300 return FAILURE;
2301 }
2302
2303 return SUCCESS;
2304 }
2305
2306
2307 gfc_try
2308 gfc_check_min_max (gfc_actual_arglist *arg)
2309 {
2310 gfc_expr *x;
2311
2312 if (min_max_args (arg) == FAILURE)
2313 return FAILURE;
2314
2315 x = arg->expr;
2316
2317 if (x->ts.type == BT_CHARACTER)
2318 {
2319 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2320 "with CHARACTER argument at %L",
2321 gfc_current_intrinsic, &x->where) == FAILURE)
2322 return FAILURE;
2323 }
2324 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
2325 {
2326 gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2327 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
2328 return FAILURE;
2329 }
2330
2331 return check_rest (x->ts.type, x->ts.kind, arg);
2332 }
2333
2334
2335 gfc_try
2336 gfc_check_min_max_integer (gfc_actual_arglist *arg)
2337 {
2338 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
2339 }
2340
2341
2342 gfc_try
2343 gfc_check_min_max_real (gfc_actual_arglist *arg)
2344 {
2345 return check_rest (BT_REAL, gfc_default_real_kind, arg);
2346 }
2347
2348
2349 gfc_try
2350 gfc_check_min_max_double (gfc_actual_arglist *arg)
2351 {
2352 return check_rest (BT_REAL, gfc_default_double_kind, arg);
2353 }
2354
2355
2356 /* End of min/max family. */
2357
2358 gfc_try
2359 gfc_check_malloc (gfc_expr *size)
2360 {
2361 if (type_check (size, 0, BT_INTEGER) == FAILURE)
2362 return FAILURE;
2363
2364 if (scalar_check (size, 0) == FAILURE)
2365 return FAILURE;
2366
2367 return SUCCESS;
2368 }
2369
2370
2371 gfc_try
2372 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
2373 {
2374 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
2375 {
2376 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2377 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2378 gfc_current_intrinsic, &matrix_a->where);
2379 return FAILURE;
2380 }
2381
2382 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2383 {
2384 gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2385 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
2386 gfc_current_intrinsic, &matrix_b->where);
2387 return FAILURE;
2388 }
2389
2390 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2391 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2392 {
2393 gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2394 gfc_current_intrinsic, &matrix_a->where,
2395 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2396 return FAILURE;
2397 }
2398
2399 switch (matrix_a->rank)
2400 {
2401 case 1:
2402 if (rank_check (matrix_b, 1, 2) == FAILURE)
2403 return FAILURE;
2404 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
2405 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2406 {
2407 gfc_error ("Different shape on dimension 1 for arguments '%s' "
2408 "and '%s' at %L for intrinsic matmul",
2409 gfc_current_intrinsic_arg[0]->name,
2410 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2411 return FAILURE;
2412 }
2413 break;
2414
2415 case 2:
2416 if (matrix_b->rank != 2)
2417 {
2418 if (rank_check (matrix_b, 1, 1) == FAILURE)
2419 return FAILURE;
2420 }
2421 /* matrix_b has rank 1 or 2 here. Common check for the cases
2422 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2423 - matrix_a has shape (n,m) and matrix_b has shape (m). */
2424 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2425 {
2426 gfc_error ("Different shape on dimension 2 for argument '%s' and "
2427 "dimension 1 for argument '%s' at %L for intrinsic "
2428 "matmul", gfc_current_intrinsic_arg[0]->name,
2429 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2430 return FAILURE;
2431 }
2432 break;
2433
2434 default:
2435 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2436 "1 or 2", gfc_current_intrinsic_arg[0]->name,
2437 gfc_current_intrinsic, &matrix_a->where);
2438 return FAILURE;
2439 }
2440
2441 return SUCCESS;
2442 }
2443
2444
2445 /* Whoever came up with this interface was probably on something.
2446 The possibilities for the occupation of the second and third
2447 parameters are:
2448
2449 Arg #2 Arg #3
2450 NULL NULL
2451 DIM NULL
2452 MASK NULL
2453 NULL MASK minloc(array, mask=m)
2454 DIM MASK
2455
2456 I.e. in the case of minloc(array,mask), mask will be in the second
2457 position of the argument list and we'll have to fix that up. */
2458
2459 gfc_try
2460 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2461 {
2462 gfc_expr *a, *m, *d;
2463
2464 a = ap->expr;
2465 if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
2466 return FAILURE;
2467
2468 d = ap->next->expr;
2469 m = ap->next->next->expr;
2470
2471 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2472 && ap->next->name == NULL)
2473 {
2474 m = d;
2475 d = NULL;
2476 ap->next->expr = NULL;
2477 ap->next->next->expr = m;
2478 }
2479
2480 if (dim_check (d, 1, false) == FAILURE)
2481 return FAILURE;
2482
2483 if (dim_rank_check (d, a, 0) == FAILURE)
2484 return FAILURE;
2485
2486 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2487 return FAILURE;
2488
2489 if (m != NULL
2490 && gfc_check_conformance (a, m,
2491 "arguments '%s' and '%s' for intrinsic %s",
2492 gfc_current_intrinsic_arg[0]->name,
2493 gfc_current_intrinsic_arg[2]->name,
2494 gfc_current_intrinsic ) == FAILURE)
2495 return FAILURE;
2496
2497 return SUCCESS;
2498 }
2499
2500
2501 /* Similar to minloc/maxloc, the argument list might need to be
2502 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
2503 difference is that MINLOC/MAXLOC take an additional KIND argument.
2504 The possibilities are:
2505
2506 Arg #2 Arg #3
2507 NULL NULL
2508 DIM NULL
2509 MASK NULL
2510 NULL MASK minval(array, mask=m)
2511 DIM MASK
2512
2513 I.e. in the case of minval(array,mask), mask will be in the second
2514 position of the argument list and we'll have to fix that up. */
2515
2516 static gfc_try
2517 check_reduction (gfc_actual_arglist *ap)
2518 {
2519 gfc_expr *a, *m, *d;
2520
2521 a = ap->expr;
2522 d = ap->next->expr;
2523 m = ap->next->next->expr;
2524
2525 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2526 && ap->next->name == NULL)
2527 {
2528 m = d;
2529 d = NULL;
2530 ap->next->expr = NULL;
2531 ap->next->next->expr = m;
2532 }
2533
2534 if (dim_check (d, 1, false) == FAILURE)
2535 return FAILURE;
2536
2537 if (dim_rank_check (d, a, 0) == FAILURE)
2538 return FAILURE;
2539
2540 if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2541 return FAILURE;
2542
2543 if (m != NULL
2544 && gfc_check_conformance (a, m,
2545 "arguments '%s' and '%s' for intrinsic %s",
2546 gfc_current_intrinsic_arg[0]->name,
2547 gfc_current_intrinsic_arg[2]->name,
2548 gfc_current_intrinsic) == FAILURE)
2549 return FAILURE;
2550
2551 return SUCCESS;
2552 }
2553
2554
2555 gfc_try
2556 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2557 {
2558 if (int_or_real_check (ap->expr, 0) == FAILURE
2559 || array_check (ap->expr, 0) == FAILURE)
2560 return FAILURE;
2561
2562 return check_reduction (ap);
2563 }
2564
2565
2566 gfc_try
2567 gfc_check_product_sum (gfc_actual_arglist *ap)
2568 {
2569 if (numeric_check (ap->expr, 0) == FAILURE
2570 || array_check (ap->expr, 0) == FAILURE)
2571 return FAILURE;
2572
2573 return check_reduction (ap);
2574 }
2575
2576
2577 /* For IANY, IALL and IPARITY. */
2578
2579 gfc_try
2580 gfc_check_mask (gfc_expr *i, gfc_expr *kind)
2581 {
2582 int k;
2583
2584 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2585 return FAILURE;
2586
2587 if (nonnegative_check ("I", i) == FAILURE)
2588 return FAILURE;
2589
2590 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2591 return FAILURE;
2592
2593 if (kind)
2594 gfc_extract_int (kind, &k);
2595 else
2596 k = gfc_default_integer_kind;
2597
2598 if (less_than_bitsizekind ("I", i, k) == FAILURE)
2599 return FAILURE;
2600
2601 return SUCCESS;
2602 }
2603
2604
2605 gfc_try
2606 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
2607 {
2608 if (ap->expr->ts.type != BT_INTEGER)
2609 {
2610 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2611 gfc_current_intrinsic_arg[0]->name,
2612 gfc_current_intrinsic, &ap->expr->where);
2613 return FAILURE;
2614 }
2615
2616 if (array_check (ap->expr, 0) == FAILURE)
2617 return FAILURE;
2618
2619 return check_reduction (ap);
2620 }
2621
2622
2623 gfc_try
2624 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2625 {
2626 if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2627 return FAILURE;
2628
2629 if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2630 return FAILURE;
2631
2632 if (tsource->ts.type == BT_CHARACTER)
2633 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2634
2635 return SUCCESS;
2636 }
2637
2638
2639 gfc_try
2640 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
2641 {
2642 if (type_check (i, 0, BT_INTEGER) == FAILURE)
2643 return FAILURE;
2644
2645 if (type_check (j, 1, BT_INTEGER) == FAILURE)
2646 return FAILURE;
2647
2648 if (type_check (mask, 2, BT_INTEGER) == FAILURE)
2649 return FAILURE;
2650
2651 if (same_type_check (i, 0, j, 1) == FAILURE)
2652 return FAILURE;
2653
2654 if (same_type_check (i, 0, mask, 2) == FAILURE)
2655 return FAILURE;
2656
2657 return SUCCESS;
2658 }
2659
2660
2661 gfc_try
2662 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2663 {
2664 if (variable_check (from, 0, false) == FAILURE)
2665 return FAILURE;
2666 if (allocatable_check (from, 0) == FAILURE)
2667 return FAILURE;
2668
2669 if (variable_check (to, 1, false) == FAILURE)
2670 return FAILURE;
2671 if (allocatable_check (to, 1) == FAILURE)
2672 return FAILURE;
2673
2674 if (same_type_check (to, 1, from, 0) == FAILURE)
2675 return FAILURE;
2676
2677 if (to->rank != from->rank)
2678 {
2679 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2680 "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
2681 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2682 &to->where, from->rank, to->rank);
2683 return FAILURE;
2684 }
2685
2686 if (to->ts.kind != from->ts.kind)
2687 {
2688 gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2689 "be of the same kind %d/%d",
2690 gfc_current_intrinsic_arg[0]->name,
2691 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2692 &to->where, from->ts.kind, to->ts.kind);
2693 return FAILURE;
2694 }
2695
2696 /* CLASS arguments: Make sure the vtab is present. */
2697 if (to->ts.type == BT_CLASS)
2698 gfc_find_derived_vtab (from->ts.u.derived);
2699
2700 return SUCCESS;
2701 }
2702
2703
2704 gfc_try
2705 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2706 {
2707 if (type_check (x, 0, BT_REAL) == FAILURE)
2708 return FAILURE;
2709
2710 if (type_check (s, 1, BT_REAL) == FAILURE)
2711 return FAILURE;
2712
2713 return SUCCESS;
2714 }
2715
2716
2717 gfc_try
2718 gfc_check_new_line (gfc_expr *a)
2719 {
2720 if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2721 return FAILURE;
2722
2723 return SUCCESS;
2724 }
2725
2726
2727 gfc_try
2728 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
2729 {
2730 if (type_check (array, 0, BT_REAL) == FAILURE)
2731 return FAILURE;
2732
2733 if (array_check (array, 0) == FAILURE)
2734 return FAILURE;
2735
2736 if (dim_rank_check (dim, array, false) == FAILURE)
2737 return FAILURE;
2738
2739 return SUCCESS;
2740 }
2741
2742 gfc_try
2743 gfc_check_null (gfc_expr *mold)
2744 {
2745 symbol_attribute attr;
2746
2747 if (mold == NULL)
2748 return SUCCESS;
2749
2750 if (variable_check (mold, 0, true) == FAILURE)
2751 return FAILURE;
2752
2753 attr = gfc_variable_attr (mold, NULL);
2754
2755 if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
2756 {
2757 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2758 "ALLOCATABLE or procedure pointer",
2759 gfc_current_intrinsic_arg[0]->name,
2760 gfc_current_intrinsic, &mold->where);
2761 return FAILURE;
2762 }
2763
2764 if (attr.allocatable
2765 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with "
2766 "allocatable MOLD at %L", &mold->where) == FAILURE)
2767 return FAILURE;
2768
2769 /* F2008, C1242. */
2770 if (gfc_is_coindexed (mold))
2771 {
2772 gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2773 "conindexed", gfc_current_intrinsic_arg[0]->name,
2774 gfc_current_intrinsic, &mold->where);
2775 return FAILURE;
2776 }
2777
2778 return SUCCESS;
2779 }
2780
2781
2782 gfc_try
2783 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2784 {
2785 if (array_check (array, 0) == FAILURE)
2786 return FAILURE;
2787
2788 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2789 return FAILURE;
2790
2791 if (gfc_check_conformance (array, mask,
2792 "arguments '%s' and '%s' for intrinsic '%s'",
2793 gfc_current_intrinsic_arg[0]->name,
2794 gfc_current_intrinsic_arg[1]->name,
2795 gfc_current_intrinsic) == FAILURE)
2796 return FAILURE;
2797
2798 if (vector != NULL)
2799 {
2800 mpz_t array_size, vector_size;
2801 bool have_array_size, have_vector_size;
2802
2803 if (same_type_check (array, 0, vector, 2) == FAILURE)
2804 return FAILURE;
2805
2806 if (rank_check (vector, 2, 1) == FAILURE)
2807 return FAILURE;
2808
2809 /* VECTOR requires at least as many elements as MASK
2810 has .TRUE. values. */
2811 have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2812 have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2813
2814 if (have_vector_size
2815 && (mask->expr_type == EXPR_ARRAY
2816 || (mask->expr_type == EXPR_CONSTANT
2817 && have_array_size)))
2818 {
2819 int mask_true_values = 0;
2820
2821 if (mask->expr_type == EXPR_ARRAY)
2822 {
2823 gfc_constructor *mask_ctor;
2824 mask_ctor = gfc_constructor_first (mask->value.constructor);
2825 while (mask_ctor)
2826 {
2827 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2828 {
2829 mask_true_values = 0;
2830 break;
2831 }
2832
2833 if (mask_ctor->expr->value.logical)
2834 mask_true_values++;
2835
2836 mask_ctor = gfc_constructor_next (mask_ctor);
2837 }
2838 }
2839 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2840 mask_true_values = mpz_get_si (array_size);
2841
2842 if (mpz_get_si (vector_size) < mask_true_values)
2843 {
2844 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2845 "provide at least as many elements as there "
2846 "are .TRUE. values in '%s' (%ld/%d)",
2847 gfc_current_intrinsic_arg[2]->name,
2848 gfc_current_intrinsic, &vector->where,
2849 gfc_current_intrinsic_arg[1]->name,
2850 mpz_get_si (vector_size), mask_true_values);
2851 return FAILURE;
2852 }
2853 }
2854
2855 if (have_array_size)
2856 mpz_clear (array_size);
2857 if (have_vector_size)
2858 mpz_clear (vector_size);
2859 }
2860
2861 return SUCCESS;
2862 }
2863
2864
2865 gfc_try
2866 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
2867 {
2868 if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
2869 return FAILURE;
2870
2871 if (array_check (mask, 0) == FAILURE)
2872 return FAILURE;
2873
2874 if (dim_rank_check (dim, mask, false) == FAILURE)
2875 return FAILURE;
2876
2877 return SUCCESS;
2878 }
2879
2880
2881 gfc_try
2882 gfc_check_precision (gfc_expr *x)
2883 {
2884 if (real_or_complex_check (x, 0) == FAILURE)
2885 return FAILURE;
2886
2887 return SUCCESS;
2888 }
2889
2890
2891 gfc_try
2892 gfc_check_present (gfc_expr *a)
2893 {
2894 gfc_symbol *sym;
2895
2896 if (variable_check (a, 0, true) == FAILURE)
2897 return FAILURE;
2898
2899 sym = a->symtree->n.sym;
2900 if (!sym->attr.dummy)
2901 {
2902 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2903 "dummy variable", gfc_current_intrinsic_arg[0]->name,
2904 gfc_current_intrinsic, &a->where);
2905 return FAILURE;
2906 }
2907
2908 if (!sym->attr.optional)
2909 {
2910 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2911 "an OPTIONAL dummy variable",
2912 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2913 &a->where);
2914 return FAILURE;
2915 }
2916
2917 /* 13.14.82 PRESENT(A)
2918 ......
2919 Argument. A shall be the name of an optional dummy argument that is
2920 accessible in the subprogram in which the PRESENT function reference
2921 appears... */
2922
2923 if (a->ref != NULL
2924 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2925 && (a->ref->u.ar.type == AR_FULL
2926 || (a->ref->u.ar.type == AR_ELEMENT
2927 && a->ref->u.ar.as->rank == 0))))
2928 {
2929 gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2930 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
2931 gfc_current_intrinsic, &a->where, sym->name);
2932 return FAILURE;
2933 }
2934
2935 return SUCCESS;
2936 }
2937
2938
2939 gfc_try
2940 gfc_check_radix (gfc_expr *x)
2941 {
2942 if (int_or_real_check (x, 0) == FAILURE)
2943 return FAILURE;
2944
2945 return SUCCESS;
2946 }
2947
2948
2949 gfc_try
2950 gfc_check_range (gfc_expr *x)
2951 {
2952 if (numeric_check (x, 0) == FAILURE)
2953 return FAILURE;
2954
2955 return SUCCESS;
2956 }
2957
2958
2959 gfc_try
2960 gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
2961 {
2962 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
2963 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
2964
2965 bool is_variable = true;
2966
2967 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
2968 if (a->expr_type == EXPR_FUNCTION)
2969 is_variable = a->value.function.esym
2970 ? a->value.function.esym->result->attr.pointer
2971 : a->symtree->n.sym->result->attr.pointer;
2972
2973 if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
2974 || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
2975 || !is_variable)
2976 {
2977 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
2978 "object", &a->where);
2979 return FAILURE;
2980 }
2981
2982 return SUCCESS;
2983 }
2984
2985
2986 /* real, float, sngl. */
2987 gfc_try
2988 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2989 {
2990 if (numeric_check (a, 0) == FAILURE)
2991 return FAILURE;
2992
2993 if (kind_check (kind, 1, BT_REAL) == FAILURE)
2994 return FAILURE;
2995
2996 return SUCCESS;
2997 }
2998
2999
3000 gfc_try
3001 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
3002 {
3003 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3004 return FAILURE;
3005 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3006 return FAILURE;
3007
3008 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3009 return FAILURE;
3010 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3011 return FAILURE;
3012
3013 return SUCCESS;
3014 }
3015
3016
3017 gfc_try
3018 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3019 {
3020 if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3021 return FAILURE;
3022 if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3023 return FAILURE;
3024
3025 if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3026 return FAILURE;
3027 if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3028 return FAILURE;
3029
3030 if (status == NULL)
3031 return SUCCESS;
3032
3033 if (type_check (status, 2, BT_INTEGER) == FAILURE)
3034 return FAILURE;
3035
3036 if (scalar_check (status, 2) == FAILURE)
3037 return FAILURE;
3038
3039 return SUCCESS;
3040 }
3041
3042
3043 gfc_try
3044 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
3045 {
3046 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3047 return FAILURE;
3048
3049 if (scalar_check (x, 0) == FAILURE)
3050 return FAILURE;
3051
3052 if (type_check (y, 0, BT_INTEGER) == FAILURE)
3053 return FAILURE;
3054
3055 if (scalar_check (y, 1) == FAILURE)
3056 return FAILURE;
3057
3058 return SUCCESS;
3059 }
3060
3061
3062 gfc_try
3063 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
3064 gfc_expr *pad, gfc_expr *order)
3065 {
3066 mpz_t size;
3067 mpz_t nelems;
3068 int shape_size;
3069
3070 if (array_check (source, 0) == FAILURE)
3071 return FAILURE;
3072
3073 if (rank_check (shape, 1, 1) == FAILURE)
3074 return FAILURE;
3075
3076 if (type_check (shape, 1, BT_INTEGER) == FAILURE)
3077 return FAILURE;
3078
3079 if (gfc_array_size (shape, &size) != SUCCESS)
3080 {
3081 gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3082 "array of constant size", &shape->where);
3083 return FAILURE;
3084 }
3085
3086 shape_size = mpz_get_ui (size);
3087 mpz_clear (size);
3088
3089 if (shape_size <= 0)
3090 {
3091 gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3092 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3093 &shape->where);
3094 return FAILURE;
3095 }
3096 else if (shape_size > GFC_MAX_DIMENSIONS)
3097 {
3098 gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3099 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
3100 return FAILURE;
3101 }
3102 else if (shape->expr_type == EXPR_ARRAY)
3103 {
3104 gfc_expr *e;
3105 int i, extent;
3106 for (i = 0; i < shape_size; ++i)
3107 {
3108 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
3109 if (e->expr_type != EXPR_CONSTANT)
3110 continue;
3111
3112 gfc_extract_int (e, &extent);
3113 if (extent < 0)
3114 {
3115 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3116 "negative element (%d)",
3117 gfc_current_intrinsic_arg[1]->name,
3118 gfc_current_intrinsic, &e->where, extent);
3119 return FAILURE;
3120 }
3121 }
3122 }
3123
3124 if (pad != NULL)
3125 {
3126 if (same_type_check (source, 0, pad, 2) == FAILURE)
3127 return FAILURE;
3128
3129 if (array_check (pad, 2) == FAILURE)
3130 return FAILURE;
3131 }
3132
3133 if (order != NULL)
3134 {
3135 if (array_check (order, 3) == FAILURE)
3136 return FAILURE;
3137
3138 if (type_check (order, 3, BT_INTEGER) == FAILURE)
3139 return FAILURE;
3140
3141 if (order->expr_type == EXPR_ARRAY)
3142 {
3143 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
3144 gfc_expr *e;
3145
3146 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
3147 perm[i] = 0;
3148
3149 gfc_array_size (order, &size);
3150 order_size = mpz_get_ui (size);
3151 mpz_clear (size);
3152
3153 if (order_size != shape_size)
3154 {
3155 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3156 "has wrong number of elements (%d/%d)",
3157 gfc_current_intrinsic_arg[3]->name,
3158 gfc_current_intrinsic, &order->where,
3159 order_size, shape_size);
3160 return FAILURE;
3161 }
3162
3163 for (i = 1; i <= order_size; ++i)
3164 {
3165 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
3166 if (e->expr_type != EXPR_CONSTANT)
3167 continue;
3168
3169 gfc_extract_int (e, &dim);
3170
3171 if (dim < 1 || dim > order_size)
3172 {
3173 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3174 "has out-of-range dimension (%d)",
3175 gfc_current_intrinsic_arg[3]->name,
3176 gfc_current_intrinsic, &e->where, dim);
3177 return FAILURE;
3178 }
3179
3180 if (perm[dim-1] != 0)
3181 {
3182 gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3183 "invalid permutation of dimensions (dimension "
3184 "'%d' duplicated)",
3185 gfc_current_intrinsic_arg[3]->name,
3186 gfc_current_intrinsic, &e->where, dim);
3187 return FAILURE;
3188 }
3189
3190 perm[dim-1] = 1;
3191 }
3192 }
3193 }
3194
3195 if (pad == NULL && shape->expr_type == EXPR_ARRAY
3196 && gfc_is_constant_expr (shape)
3197 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
3198 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
3199 {
3200 /* Check the match in size between source and destination. */
3201 if (gfc_array_size (source, &nelems) == SUCCESS)
3202 {
3203 gfc_constructor *c;
3204 bool test;
3205
3206
3207 mpz_init_set_ui (size, 1);
3208 for (c = gfc_constructor_first (shape->value.constructor);
3209 c; c = gfc_constructor_next (c))
3210 mpz_mul (size, size, c->expr->value.integer);
3211
3212 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
3213 mpz_clear (nelems);
3214 mpz_clear (size);
3215
3216 if (test)
3217 {
3218 gfc_error ("Without padding, there are not enough elements "
3219 "in the intrinsic RESHAPE source at %L to match "
3220 "the shape", &source->where);
3221 return FAILURE;
3222 }
3223 }
3224 }
3225
3226 return SUCCESS;
3227 }
3228
3229
3230 gfc_try
3231 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
3232 {
3233
3234 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
3235 {
3236 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3237 "must be of a derived type",
3238 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3239 &a->where);
3240 return FAILURE;
3241 }
3242
3243 if (!gfc_type_is_extensible (a->ts.u.derived))
3244 {
3245 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3246 "must be of an extensible type",
3247 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3248 &a->where);
3249 return FAILURE;
3250 }
3251
3252 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
3253 {
3254 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3255 "must be of a derived type",
3256 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3257 &b->where);
3258 return FAILURE;
3259 }
3260
3261 if (!gfc_type_is_extensible (b->ts.u.derived))
3262 {
3263 gfc_error ("'%s' argument of '%s' intrinsic at %L "
3264 "must be of an extensible type",
3265 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3266 &b->where);
3267 return FAILURE;
3268 }
3269
3270 return SUCCESS;
3271 }
3272
3273
3274 gfc_try
3275 gfc_check_scale (gfc_expr *x, gfc_expr *i)
3276 {
3277 if (type_check (x, 0, BT_REAL) == FAILURE)
3278 return FAILURE;
3279
3280 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3281 return FAILURE;
3282
3283 return SUCCESS;
3284 }
3285
3286
3287 gfc_try
3288 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3289 {
3290 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3291 return FAILURE;
3292
3293 if (type_check (y, 1, BT_CHARACTER) == FAILURE)
3294 return FAILURE;
3295
3296 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3297 return FAILURE;
3298
3299 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3300 return FAILURE;
3301 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3302 "with KIND argument at %L",
3303 gfc_current_intrinsic, &kind->where) == FAILURE)
3304 return FAILURE;
3305
3306 if (same_type_check (x, 0, y, 1) == FAILURE)
3307 return FAILURE;
3308
3309 return SUCCESS;
3310 }
3311
3312
3313 gfc_try
3314 gfc_check_secnds (gfc_expr *r)
3315 {
3316 if (type_check (r, 0, BT_REAL) == FAILURE)
3317 return FAILURE;
3318
3319 if (kind_value_check (r, 0, 4) == FAILURE)
3320 return FAILURE;
3321
3322 if (scalar_check (r, 0) == FAILURE)
3323 return FAILURE;
3324
3325 return SUCCESS;
3326 }
3327
3328
3329 gfc_try
3330 gfc_check_selected_char_kind (gfc_expr *name)
3331 {
3332 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3333 return FAILURE;
3334
3335 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3336 return FAILURE;
3337
3338 if (scalar_check (name, 0) == FAILURE)
3339 return FAILURE;
3340
3341 return SUCCESS;
3342 }
3343
3344
3345 gfc_try
3346 gfc_check_selected_int_kind (gfc_expr *r)
3347 {
3348 if (type_check (r, 0, BT_INTEGER) == FAILURE)
3349 return FAILURE;
3350
3351 if (scalar_check (r, 0) == FAILURE)
3352 return FAILURE;
3353
3354 return SUCCESS;
3355 }
3356
3357
3358 gfc_try
3359 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
3360 {
3361 if (p == NULL && r == NULL
3362 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
3363 " neither 'P' nor 'R' argument at %L",
3364 gfc_current_intrinsic_where) == FAILURE)
3365 return FAILURE;
3366
3367 if (p)
3368 {
3369 if (type_check (p, 0, BT_INTEGER) == FAILURE)
3370 return FAILURE;
3371
3372 if (scalar_check (p, 0) == FAILURE)
3373 return FAILURE;
3374 }
3375
3376 if (r)
3377 {
3378 if (type_check (r, 1, BT_INTEGER) == FAILURE)
3379 return FAILURE;
3380
3381 if (scalar_check (r, 1) == FAILURE)
3382 return FAILURE;
3383 }
3384
3385 if (radix)
3386 {
3387 if (type_check (radix, 1, BT_INTEGER) == FAILURE)
3388 return FAILURE;
3389
3390 if (scalar_check (radix, 1) == FAILURE)
3391 return FAILURE;
3392
3393 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
3394 "RADIX argument at %L", gfc_current_intrinsic,
3395 &radix->where) == FAILURE)
3396 return FAILURE;
3397 }
3398
3399 return SUCCESS;
3400 }
3401
3402
3403 gfc_try
3404 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
3405 {
3406 if (type_check (x, 0, BT_REAL) == FAILURE)
3407 return FAILURE;
3408
3409 if (type_check (i, 1, BT_INTEGER) == FAILURE)
3410 return FAILURE;
3411
3412 return SUCCESS;
3413 }
3414
3415
3416 gfc_try
3417 gfc_check_shape (gfc_expr *source, gfc_expr *kind)
3418 {
3419 gfc_array_ref *ar;
3420
3421 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3422 return SUCCESS;
3423
3424 ar = gfc_find_array_ref (source);
3425
3426 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
3427 {
3428 gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3429 "an assumed size array", &source->where);
3430 return FAILURE;
3431 }
3432
3433 if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
3434 return FAILURE;
3435 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3436 "with KIND argument at %L",
3437 gfc_current_intrinsic, &kind->where) == FAILURE)
3438 return FAILURE;
3439
3440 return SUCCESS;
3441 }
3442
3443
3444 gfc_try
3445 gfc_check_shift (gfc_expr *i, gfc_expr *shift)
3446 {
3447 if (type_check (i, 0, BT_INTEGER) == FAILURE)
3448 return FAILURE;
3449
3450 if (type_check (shift, 0, BT_INTEGER) == FAILURE)
3451 return FAILURE;
3452
3453 if (nonnegative_check ("SHIFT", shift) == FAILURE)
3454 return FAILURE;
3455
3456 if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
3457 return FAILURE;
3458
3459 return SUCCESS;
3460 }
3461
3462
3463 gfc_try
3464 gfc_check_sign (gfc_expr *a, gfc_expr *b)
3465 {
3466 if (int_or_real_check (a, 0) == FAILURE)
3467 return FAILURE;
3468
3469 if (same_type_check (a, 0, b, 1) == FAILURE)
3470 return FAILURE;
3471
3472 return SUCCESS;
3473 }
3474
3475
3476 gfc_try
3477 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3478 {
3479 if (array_check (array, 0) == FAILURE)
3480 return FAILURE;
3481
3482 if (dim_check (dim, 1, true) == FAILURE)
3483 return FAILURE;
3484
3485 if (dim_rank_check (dim, array, 0) == FAILURE)
3486 return FAILURE;
3487
3488 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3489 return FAILURE;
3490 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3491 "with KIND argument at %L",
3492 gfc_current_intrinsic, &kind->where) == FAILURE)
3493 return FAILURE;
3494
3495
3496 return SUCCESS;
3497 }
3498
3499
3500 gfc_try
3501 gfc_check_sizeof (gfc_expr *arg)
3502 {
3503 if (arg->ts.type == BT_PROCEDURE)
3504 {
3505 gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
3506 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3507 &arg->where);
3508 return FAILURE;
3509 }
3510 return SUCCESS;
3511 }
3512
3513
3514 gfc_try
3515 gfc_check_c_sizeof (gfc_expr *arg)
3516 {
3517 if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
3518 {
3519 gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3520 "interoperable data entity",
3521 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3522 &arg->where);
3523 return FAILURE;
3524 }
3525 return SUCCESS;
3526 }
3527
3528
3529 gfc_try
3530 gfc_check_sleep_sub (gfc_expr *seconds)
3531 {
3532 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3533 return FAILURE;
3534
3535 if (scalar_check (seconds, 0) == FAILURE)
3536 return FAILURE;
3537
3538 return SUCCESS;
3539 }
3540
3541 gfc_try
3542 gfc_check_sngl (gfc_expr *a)
3543 {
3544 if (type_check (a, 0, BT_REAL) == FAILURE)
3545 return FAILURE;
3546
3547 if ((a->ts.kind != gfc_default_double_kind)
3548 && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision "
3549 "REAL argument to %s intrinsic at %L",
3550 gfc_current_intrinsic, &a->where) == FAILURE)
3551 return FAILURE;
3552
3553 return SUCCESS;
3554 }
3555
3556 gfc_try
3557 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
3558 {
3559 if (source->rank >= GFC_MAX_DIMENSIONS)
3560 {
3561 gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3562 "than rank %d", gfc_current_intrinsic_arg[0]->name,
3563 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
3564
3565 return FAILURE;
3566 }
3567
3568 if (dim == NULL)
3569 return FAILURE;
3570
3571 if (dim_check (dim, 1, false) == FAILURE)
3572 return FAILURE;
3573
3574 /* dim_rank_check() does not apply here. */
3575 if (dim
3576 && dim->expr_type == EXPR_CONSTANT
3577 && (mpz_cmp_ui (dim->value.integer, 1) < 0
3578 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
3579 {
3580 gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3581 "dimension index", gfc_current_intrinsic_arg[1]->name,
3582 gfc_current_intrinsic, &dim->where);
3583 return FAILURE;
3584 }
3585
3586 if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
3587 return FAILURE;
3588
3589 if (scalar_check (ncopies, 2) == FAILURE)
3590 return FAILURE;
3591
3592 return SUCCESS;
3593 }
3594
3595
3596 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3597 functions). */
3598
3599 gfc_try
3600 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3601 {
3602 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3603 return FAILURE;
3604
3605 if (scalar_check (unit, 0) == FAILURE)
3606 return FAILURE;
3607
3608 if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3609 return FAILURE;
3610 if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3611 return FAILURE;
3612
3613 if (status == NULL)
3614 return SUCCESS;
3615
3616 if (type_check (status, 2, BT_INTEGER) == FAILURE
3617 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3618 || scalar_check (status, 2) == FAILURE)
3619 return FAILURE;
3620
3621 return SUCCESS;
3622 }
3623
3624
3625 gfc_try
3626 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3627 {
3628 return gfc_check_fgetputc_sub (unit, c, NULL);
3629 }
3630
3631
3632 gfc_try
3633 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3634 {
3635 if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3636 return FAILURE;
3637 if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3638 return FAILURE;
3639
3640 if (status == NULL)
3641 return SUCCESS;
3642
3643 if (type_check (status, 1, BT_INTEGER) == FAILURE
3644 || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3645 || scalar_check (status, 1) == FAILURE)
3646 return FAILURE;
3647
3648 return SUCCESS;
3649 }
3650
3651
3652 gfc_try
3653 gfc_check_fgetput (gfc_expr *c)
3654 {
3655 return gfc_check_fgetput_sub (c, NULL);
3656 }
3657
3658
3659 gfc_try
3660 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3661 {
3662 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3663 return FAILURE;
3664
3665 if (scalar_check (unit, 0) == FAILURE)
3666 return FAILURE;
3667
3668 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3669 return FAILURE;
3670
3671 if (scalar_check (offset, 1) == FAILURE)
3672 return FAILURE;
3673
3674 if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3675 return FAILURE;
3676
3677 if (scalar_check (whence, 2) == FAILURE)
3678 return FAILURE;
3679
3680 if (status == NULL)
3681 return SUCCESS;
3682
3683 if (type_check (status, 3, BT_INTEGER) == FAILURE)
3684 return FAILURE;
3685
3686 if (kind_value_check (status, 3, 4) == FAILURE)
3687 return FAILURE;
3688
3689 if (scalar_check (status, 3) == FAILURE)
3690 return FAILURE;
3691
3692 return SUCCESS;
3693 }
3694
3695
3696
3697 gfc_try
3698 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
3699 {
3700 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3701 return FAILURE;
3702
3703 if (scalar_check (unit, 0) == FAILURE)
3704 return FAILURE;
3705
3706 if (type_check (array, 1, BT_INTEGER) == FAILURE
3707 || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
3708 return FAILURE;
3709
3710 if (array_check (array, 1) == FAILURE)
3711 return FAILURE;
3712
3713 return SUCCESS;
3714 }
3715
3716
3717 gfc_try
3718 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3719 {
3720 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3721 return FAILURE;
3722
3723 if (scalar_check (unit, 0) == FAILURE)
3724 return FAILURE;
3725
3726 if (type_check (array, 1, BT_INTEGER) == FAILURE
3727 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3728 return FAILURE;
3729
3730 if (array_check (array, 1) == FAILURE)
3731 return FAILURE;
3732
3733 if (status == NULL)
3734 return SUCCESS;
3735
3736 if (type_check (status, 2, BT_INTEGER) == FAILURE
3737 || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3738 return FAILURE;
3739
3740 if (scalar_check (status, 2) == FAILURE)
3741 return FAILURE;
3742
3743 return SUCCESS;
3744 }
3745
3746
3747 gfc_try
3748 gfc_check_ftell (gfc_expr *unit)
3749 {
3750 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3751 return FAILURE;
3752
3753 if (scalar_check (unit, 0) == FAILURE)
3754 return FAILURE;
3755
3756 return SUCCESS;
3757 }
3758
3759
3760 gfc_try
3761 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3762 {
3763 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3764 return FAILURE;
3765
3766 if (scalar_check (unit, 0) == FAILURE)
3767 return FAILURE;
3768
3769 if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3770 return FAILURE;
3771
3772 if (scalar_check (offset, 1) == FAILURE)
3773 return FAILURE;
3774
3775 return SUCCESS;
3776 }
3777
3778
3779 gfc_try
3780 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3781 {
3782 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3783 return FAILURE;
3784 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3785 return FAILURE;
3786
3787 if (type_check (array, 1, BT_INTEGER) == FAILURE
3788 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3789 return FAILURE;
3790
3791 if (array_check (array, 1) == FAILURE)
3792 return FAILURE;
3793
3794 return SUCCESS;
3795 }
3796
3797
3798 gfc_try
3799 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3800 {
3801 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3802 return FAILURE;
3803 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3804 return FAILURE;
3805
3806 if (type_check (array, 1, BT_INTEGER) == FAILURE
3807 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3808 return FAILURE;
3809
3810 if (array_check (array, 1) == FAILURE)
3811 return FAILURE;
3812
3813 if (status == NULL)
3814 return SUCCESS;
3815
3816 if (type_check (status, 2, BT_INTEGER) == FAILURE
3817 || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3818 return FAILURE;
3819
3820 if (scalar_check (status, 2) == FAILURE)
3821 return FAILURE;
3822
3823 return SUCCESS;
3824 }
3825
3826
3827 gfc_try
3828 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3829 {
3830 mpz_t nelems;
3831
3832 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3833 {
3834 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3835 return FAILURE;
3836 }
3837
3838 if (coarray_check (coarray, 0) == FAILURE)
3839 return FAILURE;
3840
3841 if (sub->rank != 1)
3842 {
3843 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3844 gfc_current_intrinsic_arg[1]->name, &sub->where);
3845 return FAILURE;
3846 }
3847
3848 if (gfc_array_size (sub, &nelems) == SUCCESS)
3849 {
3850 int corank = gfc_get_corank (coarray);
3851
3852 if (mpz_cmp_ui (nelems, corank) != 0)
3853 {
3854 gfc_error ("The number of array elements of the SUB argument to "
3855 "IMAGE_INDEX at %L shall be %d (corank) not %d",
3856 &sub->where, corank, (int) mpz_get_si (nelems));
3857 mpz_clear (nelems);
3858 return FAILURE;
3859 }
3860 mpz_clear (nelems);
3861 }
3862
3863 return SUCCESS;
3864 }
3865
3866
3867 gfc_try
3868 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3869 {
3870 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3871 {
3872 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3873 return FAILURE;
3874 }
3875
3876 if (dim != NULL && coarray == NULL)
3877 {
3878 gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3879 "intrinsic at %L", &dim->where);
3880 return FAILURE;
3881 }
3882
3883 if (coarray == NULL)
3884 return SUCCESS;
3885
3886 if (coarray_check (coarray, 0) == FAILURE)
3887 return FAILURE;
3888
3889 if (dim != NULL)
3890 {
3891 if (dim_check (dim, 1, false) == FAILURE)
3892 return FAILURE;
3893
3894 if (dim_corank_check (dim, coarray) == FAILURE)
3895 return FAILURE;
3896 }
3897
3898 return SUCCESS;
3899 }
3900
3901 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
3902 by gfc_simplify_transfer. Return FAILURE if we cannot do so. */
3903
3904 gfc_try
3905 gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
3906 size_t *source_size, size_t *result_size,
3907 size_t *result_length_p)
3908
3909 {
3910 size_t result_elt_size;
3911 mpz_t tmp;
3912 gfc_expr *mold_element;
3913
3914 if (source->expr_type == EXPR_FUNCTION)
3915 return FAILURE;
3916
3917 /* Calculate the size of the source. */
3918 if (source->expr_type == EXPR_ARRAY
3919 && gfc_array_size (source, &tmp) == FAILURE)
3920 return FAILURE;
3921
3922 *source_size = gfc_target_expr_size (source);
3923
3924 mold_element = mold->expr_type == EXPR_ARRAY
3925 ? gfc_constructor_first (mold->value.constructor)->expr
3926 : mold;
3927
3928 /* Determine the size of the element. */
3929 result_elt_size = gfc_target_expr_size (mold_element);
3930 if (result_elt_size == 0)
3931 return FAILURE;
3932
3933 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
3934 {
3935 int result_length;
3936
3937 if (size)
3938 result_length = (size_t)mpz_get_ui (size->value.integer);
3939 else
3940 {
3941 result_length = *source_size / result_elt_size;
3942 if (result_length * result_elt_size < *source_size)
3943 result_length += 1;
3944 }
3945
3946 *result_size = result_length * result_elt_size;
3947 if (result_length_p)
3948 *result_length_p = result_length;
3949 }
3950 else
3951 *result_size = result_elt_size;
3952
3953 return SUCCESS;
3954 }
3955
3956
3957 gfc_try
3958 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
3959 {
3960 size_t source_size;
3961 size_t result_size;
3962
3963 if (mold->ts.type == BT_HOLLERITH)
3964 {
3965 gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3966 &mold->where, gfc_basic_typename (BT_HOLLERITH));
3967 return FAILURE;
3968 }
3969
3970 if (size != NULL)
3971 {
3972 if (type_check (size, 2, BT_INTEGER) == FAILURE)
3973 return FAILURE;
3974
3975 if (scalar_check (size, 2) == FAILURE)
3976 return FAILURE;
3977
3978 if (nonoptional_check (size, 2) == FAILURE)
3979 return FAILURE;
3980 }
3981
3982 if (!gfc_option.warn_surprising)
3983 return SUCCESS;
3984
3985 /* If we can't calculate the sizes, we cannot check any more.
3986 Return SUCCESS for that case. */
3987
3988 if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
3989 &result_size, NULL) == FAILURE)
3990 return SUCCESS;
3991
3992 if (source_size < result_size)
3993 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
3994 "source size %ld < result size %ld", &source->where,
3995 (long) source_size, (long) result_size);
3996
3997 return SUCCESS;
3998 }
3999
4000
4001 gfc_try
4002 gfc_check_transpose (gfc_expr *matrix)
4003 {
4004 if (rank_check (matrix, 0, 2) == FAILURE)
4005 return FAILURE;
4006
4007 return SUCCESS;
4008 }
4009
4010
4011 gfc_try
4012 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4013 {
4014 if (array_check (array, 0) == FAILURE)
4015 return FAILURE;
4016
4017 if (dim_check (dim, 1, false) == FAILURE)
4018 return FAILURE;
4019
4020 if (dim_rank_check (dim, array, 0) == FAILURE)
4021 return FAILURE;
4022
4023 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4024 return FAILURE;
4025 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4026 "with KIND argument at %L",
4027 gfc_current_intrinsic, &kind->where) == FAILURE)
4028 return FAILURE;
4029
4030 return SUCCESS;
4031 }
4032
4033
4034 gfc_try
4035 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
4036 {
4037 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4038 {
4039 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4040 return FAILURE;
4041 }
4042
4043 if (coarray_check (coarray, 0) == FAILURE)
4044 return FAILURE;
4045
4046 if (dim != NULL)
4047 {
4048 if (dim_check (dim, 1, false) == FAILURE)
4049 return FAILURE;
4050
4051 if (dim_corank_check (dim, coarray) == FAILURE)
4052 return FAILURE;
4053 }
4054
4055 if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4056 return FAILURE;
4057
4058 return SUCCESS;
4059 }
4060
4061
4062 gfc_try
4063 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
4064 {
4065 mpz_t vector_size;
4066
4067 if (rank_check (vector, 0, 1) == FAILURE)
4068 return FAILURE;
4069
4070 if (array_check (mask, 1) == FAILURE)
4071 return FAILURE;
4072
4073 if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
4074 return FAILURE;
4075
4076 if (same_type_check (vector, 0, field, 2) == FAILURE)
4077 return FAILURE;
4078
4079 if (mask->expr_type == EXPR_ARRAY
4080 && gfc_array_size (vector, &vector_size) == SUCCESS)
4081 {
4082 int mask_true_count = 0;
4083 gfc_constructor *mask_ctor;
4084 mask_ctor = gfc_constructor_first (mask->value.constructor);
4085 while (mask_ctor)
4086 {
4087 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4088 {
4089 mask_true_count = 0;
4090 break;
4091 }
4092
4093 if (mask_ctor->expr->value.logical)
4094 mask_true_count++;
4095
4096 mask_ctor = gfc_constructor_next (mask_ctor);
4097 }
4098
4099 if (mpz_get_si (vector_size) < mask_true_count)
4100 {
4101 gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4102 "provide at least as many elements as there "
4103 "are .TRUE. values in '%s' (%ld/%d)",
4104 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4105 &vector->where, gfc_current_intrinsic_arg[1]->name,
4106 mpz_get_si (vector_size), mask_true_count);
4107 return FAILURE;
4108 }
4109
4110 mpz_clear (vector_size);
4111 }
4112
4113 if (mask->rank != field->rank && field->rank != 0)
4114 {
4115 gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4116 "the same rank as '%s' or be a scalar",
4117 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4118 &field->where, gfc_current_intrinsic_arg[1]->name);
4119 return FAILURE;
4120 }
4121
4122 if (mask->rank == field->rank)
4123 {
4124 int i;
4125 for (i = 0; i < field->rank; i++)
4126 if (! identical_dimen_shape (mask, i, field, i))
4127 {
4128 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4129 "must have identical shape.",
4130 gfc_current_intrinsic_arg[2]->name,
4131 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4132 &field->where);
4133 }
4134 }
4135
4136 return SUCCESS;
4137 }
4138
4139
4140 gfc_try
4141 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4142 {
4143 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4144 return FAILURE;
4145
4146 if (same_type_check (x, 0, y, 1) == FAILURE)
4147 return FAILURE;
4148
4149 if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
4150 return FAILURE;
4151
4152 if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
4153 return FAILURE;
4154 if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4155 "with KIND argument at %L",
4156 gfc_current_intrinsic, &kind->where) == FAILURE)
4157 return FAILURE;
4158
4159 return SUCCESS;
4160 }
4161
4162
4163 gfc_try
4164 gfc_check_trim (gfc_expr *x)
4165 {
4166 if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4167 return FAILURE;
4168
4169 if (scalar_check (x, 0) == FAILURE)
4170 return FAILURE;
4171
4172 return SUCCESS;
4173 }
4174
4175
4176 gfc_try
4177 gfc_check_ttynam (gfc_expr *unit)
4178 {
4179 if (scalar_check (unit, 0) == FAILURE)
4180 return FAILURE;
4181
4182 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4183 return FAILURE;
4184
4185 return SUCCESS;
4186 }
4187
4188
4189 /* Common check function for the half a dozen intrinsics that have a
4190 single real argument. */
4191
4192 gfc_try
4193 gfc_check_x (gfc_expr *x)
4194 {
4195 if (type_check (x, 0, BT_REAL) == FAILURE)
4196 return FAILURE;
4197
4198 return SUCCESS;
4199 }
4200
4201
4202 /************* Check functions for intrinsic subroutines *************/
4203
4204 gfc_try
4205 gfc_check_cpu_time (gfc_expr *time)
4206 {
4207 if (scalar_check (time, 0) == FAILURE)
4208 return FAILURE;
4209
4210 if (type_check (time, 0, BT_REAL) == FAILURE)
4211 return FAILURE;
4212
4213 if (variable_check (time, 0, false) == FAILURE)
4214 return FAILURE;
4215
4216 return SUCCESS;
4217 }
4218
4219
4220 gfc_try
4221 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
4222 gfc_expr *zone, gfc_expr *values)
4223 {
4224 if (date != NULL)
4225 {
4226 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4227 return FAILURE;
4228 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4229 return FAILURE;
4230 if (scalar_check (date, 0) == FAILURE)
4231 return FAILURE;
4232 if (variable_check (date, 0, false) == FAILURE)
4233 return FAILURE;
4234 }
4235
4236 if (time != NULL)
4237 {
4238 if (type_check (time, 1, BT_CHARACTER) == FAILURE)
4239 return FAILURE;
4240 if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
4241 return FAILURE;
4242 if (scalar_check (time, 1) == FAILURE)
4243 return FAILURE;
4244 if (variable_check (time, 1, false) == FAILURE)
4245 return FAILURE;
4246 }
4247
4248 if (zone != NULL)
4249 {
4250 if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
4251 return FAILURE;
4252 if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
4253 return FAILURE;
4254 if (scalar_check (zone, 2) == FAILURE)
4255 return FAILURE;
4256 if (variable_check (zone, 2, false) == FAILURE)
4257 return FAILURE;
4258 }
4259
4260 if (values != NULL)
4261 {
4262 if (type_check (values, 3, BT_INTEGER) == FAILURE)
4263 return FAILURE;
4264 if (array_check (values, 3) == FAILURE)
4265 return FAILURE;
4266 if (rank_check (values, 3, 1) == FAILURE)
4267 return FAILURE;
4268 if (variable_check (values, 3, false) == FAILURE)
4269 return FAILURE;
4270 }
4271
4272 return SUCCESS;
4273 }
4274
4275
4276 gfc_try
4277 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
4278 gfc_expr *to, gfc_expr *topos)
4279 {
4280 if (type_check (from, 0, BT_INTEGER) == FAILURE)
4281 return FAILURE;
4282
4283 if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
4284 return FAILURE;
4285
4286 if (type_check (len, 2, BT_INTEGER) == FAILURE)
4287 return FAILURE;
4288
4289 if (same_type_check (from, 0, to, 3) == FAILURE)
4290 return FAILURE;
4291
4292 if (variable_check (to, 3, false) == FAILURE)
4293 return FAILURE;
4294
4295 if (type_check (topos, 4, BT_INTEGER) == FAILURE)
4296 return FAILURE;
4297
4298 if (nonnegative_check ("frompos", frompos) == FAILURE)
4299 return FAILURE;
4300
4301 if (nonnegative_check ("topos", topos) == FAILURE)
4302 return FAILURE;
4303
4304 if (nonnegative_check ("len", len) == FAILURE)
4305 return FAILURE;
4306
4307 if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
4308 == FAILURE)
4309 return FAILURE;
4310
4311 if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
4312 return FAILURE;
4313
4314 return SUCCESS;
4315 }
4316
4317
4318 gfc_try
4319 gfc_check_random_number (gfc_expr *harvest)
4320 {
4321 if (type_check (harvest, 0, BT_REAL) == FAILURE)
4322 return FAILURE;
4323
4324 if (variable_check (harvest, 0, false) == FAILURE)
4325 return FAILURE;
4326
4327 return SUCCESS;
4328 }
4329
4330
4331 gfc_try
4332 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
4333 {
4334 unsigned int nargs = 0, kiss_size;
4335 locus *where = NULL;
4336 mpz_t put_size, get_size;
4337 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
4338
4339 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
4340
4341 /* Keep the number of bytes in sync with kiss_size in
4342 libgfortran/intrinsics/random.c. */
4343 kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
4344
4345 if (size != NULL)
4346 {
4347 if (size->expr_type != EXPR_VARIABLE
4348 || !size->symtree->n.sym->attr.optional)
4349 nargs++;
4350
4351 if (scalar_check (size, 0) == FAILURE)
4352 return FAILURE;
4353
4354 if (type_check (size, 0, BT_INTEGER) == FAILURE)
4355 return FAILURE;
4356
4357 if (variable_check (size, 0, false) == FAILURE)
4358 return FAILURE;
4359
4360 if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
4361 return FAILURE;
4362 }
4363
4364 if (put != NULL)
4365 {
4366 if (put->expr_type != EXPR_VARIABLE
4367 || !put->symtree->n.sym->attr.optional)
4368 {
4369 nargs++;
4370 where = &put->where;
4371 }
4372
4373 if (array_check (put, 1) == FAILURE)
4374 return FAILURE;
4375
4376 if (rank_check (put, 1, 1) == FAILURE)
4377 return FAILURE;
4378
4379 if (type_check (put, 1, BT_INTEGER) == FAILURE)
4380 return FAILURE;
4381
4382 if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
4383 return FAILURE;
4384
4385 if (gfc_array_size (put, &put_size) == SUCCESS
4386 && mpz_get_ui (put_size) < kiss_size)
4387 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4388 "too small (%i/%i)",
4389 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4390 where, (int) mpz_get_ui (put_size), kiss_size);
4391 }
4392
4393 if (get != NULL)
4394 {
4395 if (get->expr_type != EXPR_VARIABLE
4396 || !get->symtree->n.sym->attr.optional)
4397 {
4398 nargs++;
4399 where = &get->where;
4400 }
4401
4402 if (array_check (get, 2) == FAILURE)
4403 return FAILURE;
4404
4405 if (rank_check (get, 2, 1) == FAILURE)
4406 return FAILURE;
4407
4408 if (type_check (get, 2, BT_INTEGER) == FAILURE)
4409 return FAILURE;
4410
4411 if (variable_check (get, 2, false) == FAILURE)
4412 return FAILURE;
4413
4414 if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
4415 return FAILURE;
4416
4417 if (gfc_array_size (get, &get_size) == SUCCESS
4418 && mpz_get_ui (get_size) < kiss_size)
4419 gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4420 "too small (%i/%i)",
4421 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4422 where, (int) mpz_get_ui (get_size), kiss_size);
4423 }
4424
4425 /* RANDOM_SEED may not have more than one non-optional argument. */
4426 if (nargs > 1)
4427 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
4428
4429 return SUCCESS;
4430 }
4431
4432
4433 gfc_try
4434 gfc_check_second_sub (gfc_expr *time)
4435 {
4436 if (scalar_check (time, 0) == FAILURE)
4437 return FAILURE;
4438
4439 if (type_check (time, 0, BT_REAL) == FAILURE)
4440 return FAILURE;
4441
4442 if (kind_value_check(time, 0, 4) == FAILURE)
4443 return FAILURE;
4444
4445 return SUCCESS;
4446 }
4447
4448
4449 /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
4450 count, count_rate, and count_max are all optional arguments */
4451
4452 gfc_try
4453 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
4454 gfc_expr *count_max)
4455 {
4456 if (count != NULL)
4457 {
4458 if (scalar_check (count, 0) == FAILURE)
4459 return FAILURE;
4460
4461 if (type_check (count, 0, BT_INTEGER) == FAILURE)
4462 return FAILURE;
4463
4464 if (variable_check (count, 0, false) == FAILURE)
4465 return FAILURE;
4466 }
4467
4468 if (count_rate != NULL)
4469 {
4470 if (scalar_check (count_rate, 1) == FAILURE)
4471 return FAILURE;
4472
4473 if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
4474 return FAILURE;
4475
4476 if (variable_check (count_rate, 1, false) == FAILURE)
4477 return FAILURE;
4478
4479 if (count != NULL
4480 && same_type_check (count, 0, count_rate, 1) == FAILURE)
4481 return FAILURE;
4482
4483 }
4484
4485 if (count_max != NULL)
4486 {
4487 if (scalar_check (count_max, 2) == FAILURE)
4488 return FAILURE;
4489
4490 if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
4491 return FAILURE;
4492
4493 if (variable_check (count_max, 2, false) == FAILURE)
4494 return FAILURE;
4495
4496 if (count != NULL
4497 && same_type_check (count, 0, count_max, 2) == FAILURE)
4498 return FAILURE;
4499
4500 if (count_rate != NULL
4501 && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
4502 return FAILURE;
4503 }
4504
4505 return SUCCESS;
4506 }
4507
4508
4509 gfc_try
4510 gfc_check_irand (gfc_expr *x)
4511 {
4512 if (x == NULL)
4513 return SUCCESS;
4514
4515 if (scalar_check (x, 0) == FAILURE)
4516 return FAILURE;
4517
4518 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4519 return FAILURE;
4520
4521 if (kind_value_check(x, 0, 4) == FAILURE)
4522 return FAILURE;
4523
4524 return SUCCESS;
4525 }
4526
4527
4528 gfc_try
4529 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
4530 {
4531 if (scalar_check (seconds, 0) == FAILURE)
4532 return FAILURE;
4533 if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
4534 return FAILURE;
4535
4536 if (int_or_proc_check (handler, 1) == FAILURE)
4537 return FAILURE;
4538 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4539 return FAILURE;
4540
4541 if (status == NULL)
4542 return SUCCESS;
4543
4544 if (scalar_check (status, 2) == FAILURE)
4545 return FAILURE;
4546 if (type_check (status, 2, BT_INTEGER) == FAILURE)
4547 return FAILURE;
4548 if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
4549 return FAILURE;
4550
4551 return SUCCESS;
4552 }
4553
4554
4555 gfc_try
4556 gfc_check_rand (gfc_expr *x)
4557 {
4558 if (x == NULL)
4559 return SUCCESS;
4560
4561 if (scalar_check (x, 0) == FAILURE)
4562 return FAILURE;
4563
4564 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4565 return FAILURE;
4566
4567 if (kind_value_check(x, 0, 4) == FAILURE)
4568 return FAILURE;
4569
4570 return SUCCESS;
4571 }
4572
4573
4574 gfc_try
4575 gfc_check_srand (gfc_expr *x)
4576 {
4577 if (scalar_check (x, 0) == FAILURE)
4578 return FAILURE;
4579
4580 if (type_check (x, 0, BT_INTEGER) == FAILURE)
4581 return FAILURE;
4582
4583 if (kind_value_check(x, 0, 4) == FAILURE)
4584 return FAILURE;
4585
4586 return SUCCESS;
4587 }
4588
4589
4590 gfc_try
4591 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
4592 {
4593 if (scalar_check (time, 0) == FAILURE)
4594 return FAILURE;
4595 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4596 return FAILURE;
4597
4598 if (type_check (result, 1, BT_CHARACTER) == FAILURE)
4599 return FAILURE;
4600 if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
4601 return FAILURE;
4602
4603 return SUCCESS;
4604 }
4605
4606
4607 gfc_try
4608 gfc_check_dtime_etime (gfc_expr *x)
4609 {
4610 if (array_check (x, 0) == FAILURE)
4611 return FAILURE;
4612
4613 if (rank_check (x, 0, 1) == FAILURE)
4614 return FAILURE;
4615
4616 if (variable_check (x, 0, false) == FAILURE)
4617 return FAILURE;
4618
4619 if (type_check (x, 0, BT_REAL) == FAILURE)
4620 return FAILURE;
4621
4622 if (kind_value_check(x, 0, 4) == FAILURE)
4623 return FAILURE;
4624
4625 return SUCCESS;
4626 }
4627
4628
4629 gfc_try
4630 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
4631 {
4632 if (array_check (values, 0) == FAILURE)
4633 return FAILURE;
4634
4635 if (rank_check (values, 0, 1) == FAILURE)
4636 return FAILURE;
4637
4638 if (variable_check (values, 0, false) == FAILURE)
4639 return FAILURE;
4640
4641 if (type_check (values, 0, BT_REAL) == FAILURE)
4642 return FAILURE;
4643
4644 if (kind_value_check(values, 0, 4) == FAILURE)
4645 return FAILURE;
4646
4647 if (scalar_check (time, 1) == FAILURE)
4648 return FAILURE;
4649
4650 if (type_check (time, 1, BT_REAL) == FAILURE)
4651 return FAILURE;
4652
4653 if (kind_value_check(time, 1, 4) == FAILURE)
4654 return FAILURE;
4655
4656 return SUCCESS;
4657 }
4658
4659
4660 gfc_try
4661 gfc_check_fdate_sub (gfc_expr *date)
4662 {
4663 if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4664 return FAILURE;
4665 if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4666 return FAILURE;
4667
4668 return SUCCESS;
4669 }
4670
4671
4672 gfc_try
4673 gfc_check_gerror (gfc_expr *msg)
4674 {
4675 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4676 return FAILURE;
4677 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4678 return FAILURE;
4679
4680 return SUCCESS;
4681 }
4682
4683
4684 gfc_try
4685 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4686 {
4687 if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4688 return FAILURE;
4689 if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4690 return FAILURE;
4691
4692 if (status == NULL)
4693 return SUCCESS;
4694
4695 if (scalar_check (status, 1) == FAILURE)
4696 return FAILURE;
4697
4698 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4699 return FAILURE;
4700
4701 return SUCCESS;
4702 }
4703
4704
4705 gfc_try
4706 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4707 {
4708 if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4709 return FAILURE;
4710
4711 if (pos->ts.kind > gfc_default_integer_kind)
4712 {
4713 gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4714 "not wider than the default kind (%d)",
4715 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4716 &pos->where, gfc_default_integer_kind);
4717 return FAILURE;
4718 }
4719
4720 if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4721 return FAILURE;
4722 if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4723 return FAILURE;
4724
4725 return SUCCESS;
4726 }
4727
4728
4729 gfc_try
4730 gfc_check_getlog (gfc_expr *msg)
4731 {
4732 if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4733 return FAILURE;
4734 if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4735 return FAILURE;
4736
4737 return SUCCESS;
4738 }
4739
4740
4741 gfc_try
4742 gfc_check_exit (gfc_expr *status)
4743 {
4744 if (status == NULL)
4745 return SUCCESS;
4746
4747 if (type_check (status, 0, BT_INTEGER) == FAILURE)
4748 return FAILURE;
4749
4750 if (scalar_check (status, 0) == FAILURE)
4751 return FAILURE;
4752
4753 return SUCCESS;
4754 }
4755
4756
4757 gfc_try
4758 gfc_check_flush (gfc_expr *unit)
4759 {
4760 if (unit == NULL)
4761 return SUCCESS;
4762
4763 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4764 return FAILURE;
4765
4766 if (scalar_check (unit, 0) == FAILURE)
4767 return FAILURE;
4768
4769 return SUCCESS;
4770 }
4771
4772
4773 gfc_try
4774 gfc_check_free (gfc_expr *i)
4775 {
4776 if (type_check (i, 0, BT_INTEGER) == FAILURE)
4777 return FAILURE;
4778
4779 if (scalar_check (i, 0) == FAILURE)
4780 return FAILURE;
4781
4782 return SUCCESS;
4783 }
4784
4785
4786 gfc_try
4787 gfc_check_hostnm (gfc_expr *name)
4788 {
4789 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4790 return FAILURE;
4791 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4792 return FAILURE;
4793
4794 return SUCCESS;
4795 }
4796
4797
4798 gfc_try
4799 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4800 {
4801 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4802 return FAILURE;
4803 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4804 return FAILURE;
4805
4806 if (status == NULL)
4807 return SUCCESS;
4808
4809 if (scalar_check (status, 1) == FAILURE)
4810 return FAILURE;
4811
4812 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4813 return FAILURE;
4814
4815 return SUCCESS;
4816 }
4817
4818
4819 gfc_try
4820 gfc_check_itime_idate (gfc_expr *values)
4821 {
4822 if (array_check (values, 0) == FAILURE)
4823 return FAILURE;
4824
4825 if (rank_check (values, 0, 1) == FAILURE)
4826 return FAILURE;
4827
4828 if (variable_check (values, 0, false) == FAILURE)
4829 return FAILURE;
4830
4831 if (type_check (values, 0, BT_INTEGER) == FAILURE)
4832 return FAILURE;
4833
4834 if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4835 return FAILURE;
4836
4837 return SUCCESS;
4838 }
4839
4840
4841 gfc_try
4842 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4843 {
4844 if (type_check (time, 0, BT_INTEGER) == FAILURE)
4845 return FAILURE;
4846
4847 if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4848 return FAILURE;
4849
4850 if (scalar_check (time, 0) == FAILURE)
4851 return FAILURE;
4852
4853 if (array_check (values, 1) == FAILURE)
4854 return FAILURE;
4855
4856 if (rank_check (values, 1, 1) == FAILURE)
4857 return FAILURE;
4858
4859 if (variable_check (values, 1, false) == FAILURE)
4860 return FAILURE;
4861
4862 if (type_check (values, 1, BT_INTEGER) == FAILURE)
4863 return FAILURE;
4864
4865 if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4866 return FAILURE;
4867
4868 return SUCCESS;
4869 }
4870
4871
4872 gfc_try
4873 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4874 {
4875 if (scalar_check (unit, 0) == FAILURE)
4876 return FAILURE;
4877
4878 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4879 return FAILURE;
4880
4881 if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4882 return FAILURE;
4883 if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4884 return FAILURE;
4885
4886 return SUCCESS;
4887 }
4888
4889
4890 gfc_try
4891 gfc_check_isatty (gfc_expr *unit)
4892 {
4893 if (unit == NULL)
4894 return FAILURE;
4895
4896 if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4897 return FAILURE;
4898
4899 if (scalar_check (unit, 0) == FAILURE)
4900 return FAILURE;
4901
4902 return SUCCESS;
4903 }
4904
4905
4906 gfc_try
4907 gfc_check_isnan (gfc_expr *x)
4908 {
4909 if (type_check (x, 0, BT_REAL) == FAILURE)
4910 return FAILURE;
4911
4912 return SUCCESS;
4913 }
4914
4915
4916 gfc_try
4917 gfc_check_perror (gfc_expr *string)
4918 {
4919 if (type_check (string, 0, BT_CHARACTER) == FAILURE)
4920 return FAILURE;
4921 if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
4922 return FAILURE;
4923
4924 return SUCCESS;
4925 }
4926
4927
4928 gfc_try
4929 gfc_check_umask (gfc_expr *mask)
4930 {
4931 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4932 return FAILURE;
4933
4934 if (scalar_check (mask, 0) == FAILURE)
4935 return FAILURE;
4936
4937 return SUCCESS;
4938 }
4939
4940
4941 gfc_try
4942 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
4943 {
4944 if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4945 return FAILURE;
4946
4947 if (scalar_check (mask, 0) == FAILURE)
4948 return FAILURE;
4949
4950 if (old == NULL)
4951 return SUCCESS;
4952
4953 if (scalar_check (old, 1) == FAILURE)
4954 return FAILURE;
4955
4956 if (type_check (old, 1, BT_INTEGER) == FAILURE)
4957 return FAILURE;
4958
4959 return SUCCESS;
4960 }
4961
4962
4963 gfc_try
4964 gfc_check_unlink (gfc_expr *name)
4965 {
4966 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4967 return FAILURE;
4968 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4969 return FAILURE;
4970
4971 return SUCCESS;
4972 }
4973
4974
4975 gfc_try
4976 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
4977 {
4978 if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4979 return FAILURE;
4980 if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4981 return FAILURE;
4982
4983 if (status == NULL)
4984 return SUCCESS;
4985
4986 if (scalar_check (status, 1) == FAILURE)
4987 return FAILURE;
4988
4989 if (type_check (status, 1, BT_INTEGER) == FAILURE)
4990 return FAILURE;
4991
4992 return SUCCESS;
4993 }
4994
4995
4996 gfc_try
4997 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
4998 {
4999 if (scalar_check (number, 0) == FAILURE)
5000 return FAILURE;
5001 if (type_check (number, 0, BT_INTEGER) == FAILURE)
5002 return FAILURE;
5003
5004 if (int_or_proc_check (handler, 1) == FAILURE)
5005 return FAILURE;
5006 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5007 return FAILURE;
5008
5009 return SUCCESS;
5010 }
5011
5012
5013 gfc_try
5014 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
5015 {
5016 if (scalar_check (number, 0) == FAILURE)
5017 return FAILURE;
5018 if (type_check (number, 0, BT_INTEGER) == FAILURE)
5019 return FAILURE;
5020
5021 if (int_or_proc_check (handler, 1) == FAILURE)
5022 return FAILURE;
5023 if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5024 return FAILURE;
5025
5026 if (status == NULL)
5027 return SUCCESS;
5028
5029 if (type_check (status, 2, BT_INTEGER) == FAILURE)
5030 return FAILURE;
5031 if (scalar_check (status, 2) == FAILURE)
5032 return FAILURE;
5033
5034 return SUCCESS;
5035 }
5036
5037
5038 gfc_try
5039 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
5040 {
5041 if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
5042 return FAILURE;
5043 if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
5044 return FAILURE;
5045
5046 if (scalar_check (status, 1) == FAILURE)
5047 return FAILURE;
5048
5049 if (type_check (status, 1, BT_INTEGER) == FAILURE)
5050 return FAILURE;
5051
5052 if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
5053 return FAILURE;
5054
5055 return SUCCESS;
5056 }
5057
5058
5059 /* This is used for the GNU intrinsics AND, OR and XOR. */
5060 gfc_try
5061 gfc_check_and (gfc_expr *i, gfc_expr *j)
5062 {
5063 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
5064 {
5065 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5066 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
5067 gfc_current_intrinsic, &i->where);
5068 return FAILURE;
5069 }
5070
5071 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
5072 {
5073 gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5074 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
5075 gfc_current_intrinsic, &j->where);
5076 return FAILURE;
5077 }
5078
5079 if (i->ts.type != j->ts.type)
5080 {
5081 gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5082 "have the same type", gfc_current_intrinsic_arg[0]->name,
5083 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5084 &j->where);
5085 return FAILURE;
5086 }
5087
5088 if (scalar_check (i, 0) == FAILURE)
5089 return FAILURE;
5090
5091 if (scalar_check (j, 1) == FAILURE)
5092 return FAILURE;
5093
5094 return SUCCESS;
5095 }
5096
5097
5098 gfc_try
5099 gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
5100 {
5101 if (kind == NULL)
5102 return SUCCESS;
5103
5104 if (type_check (kind, 1, BT_INTEGER) == FAILURE)
5105 return FAILURE;
5106
5107 if (scalar_check (kind, 1) == FAILURE)
5108 return FAILURE;
5109
5110 if (kind->expr_type != EXPR_CONSTANT)
5111 {
5112 gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5113 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5114 &kind->where);
5115 return FAILURE;
5116 }
5117
5118 return SUCCESS;
5119 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org