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