OSDN Git Service

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