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