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