OSDN Git Service

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