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