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