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