OSDN Git Service

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