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