OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [check.c] - Blame information for rev 724

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.