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