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