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

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [fortran/] [check.c] - Blame information for rev 12

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 12 jlechner 
/* Check functions
2 
   Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 
   Contributed by Andy Vaught & Katherine Holcomb
4 
 
5 
This file is part of GCC.
6 
 
7 
GCC is free software; you can redistribute it and/or modify it under
8 
the terms of the GNU General Public License as published by the Free
9 
Software Foundation; either version 2, or (at your option) any later
10 
version.
11 
 
12 
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 
WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 
for more details.
16 
 
17 
You should have received a copy of the GNU General Public License
18 
along with GCC; see the file COPYING.  If not, write to the Free
19 
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
20 
02110-1301, USA.  */
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 
 
35 
 
36 
/* Check the type of an expression.  */
37 
 
38 
static try
39 
type_check (gfc_expr * e, int n, bt type)
40 
{
41 
  if (e->ts.type == type)
42 
    return SUCCESS;
43 
 
44 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
45 
             gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
46 
             gfc_basic_typename (type));
47 
 
48 
  return FAILURE;
49 
}
50 
 
51 
 
52 
/* Check that the expression is a numeric type.  */
53 
 
54 
static try
55 
numeric_check (gfc_expr * e, int n)
56 
{
57 
  if (gfc_numeric_ts (&e->ts))
58 
    return SUCCESS;
59 
 
60 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
61 
             gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
62 
 
63 
  return FAILURE;
64 
}
65 
 
66 
 
67 
/* Check that an expression is integer or real.  */
68 
 
69 
static try
70 
int_or_real_check (gfc_expr * e, int n)
71 
{
72 
  if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
73 
    {
74 
      gfc_error (
75 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
76 
        gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
77 
      return FAILURE;
78 
    }
79 
 
80 
  return SUCCESS;
81 
}
82 
 
83 
 
84 
/* Check that an expression is real or complex.  */
85 
 
86 
static try
87 
real_or_complex_check (gfc_expr * e, int n)
88 
{
89 
  if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
90 
    {
91 
      gfc_error (
92 
        "'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
93 
        gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
94 
      return FAILURE;
95 
    }
96 
 
97 
  return SUCCESS;
98 
}
99 
 
100 
 
101 
/* Check that the expression is an optional constant integer
102 
   and that it specifies a valid kind for that type.  */
103 
 
104 
static try
105 
kind_check (gfc_expr * k, int n, bt type)
106 
{
107 
  int kind;
108 
 
109 
  if (k == NULL)
110 
    return SUCCESS;
111 
 
112 
  if (type_check (k, n, BT_INTEGER) == FAILURE)
113 
    return FAILURE;
114 
 
115 
  if (k->expr_type != EXPR_CONSTANT)
116 
    {
117 
      gfc_error (
118 
        "'%s' argument of '%s' intrinsic at %L must be a constant",
119 
        gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
120 
      return FAILURE;
121 
    }
122 
 
123 
  if (gfc_extract_int (k, &kind) != NULL
124 
      || gfc_validate_kind (type, kind, true) < 0)
125 
    {
126 
      gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
127 
                 &k->where);
128 
      return FAILURE;
129 
    }
130 
 
131 
  return SUCCESS;
132 
}
133 
 
134 
 
135 
/* Make sure the expression is a double precision real.  */
136 
 
137 
static try
138 
double_check (gfc_expr * d, int n)
139 
{
140 
  if (type_check (d, n, BT_REAL) == FAILURE)
141 
    return FAILURE;
142 
 
143 
  if (d->ts.kind != gfc_default_double_kind)
144 
    {
145 
      gfc_error (
146 
        "'%s' argument of '%s' intrinsic at %L must be double precision",
147 
        gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
148 
      return FAILURE;
149 
    }
150 
 
151 
  return SUCCESS;
152 
}
153 
 
154 
 
155 
/* Make sure the expression is a logical array.  */
156 
 
157 
static try
158 
logical_array_check (gfc_expr * array, int n)
159 
{
160 
  if (array->ts.type != BT_LOGICAL || array->rank == 0)
161 
    {
162 
      gfc_error (
163 
        "'%s' argument of '%s' intrinsic at %L must be a logical array",
164 
        gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
165 
      return FAILURE;
166 
    }
167 
 
168 
  return SUCCESS;
169 
}
170 
 
171 
 
172 
/* Make sure an expression is an array.  */
173 
 
174 
static try
175 
array_check (gfc_expr * e, int n)
176 
{
177 
  if (e->rank != 0)
178 
    return SUCCESS;
179 
 
180 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
181 
             gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
182 
 
183 
  return FAILURE;
184 
}
185 
 
186 
 
187 
/* Make sure an expression is a scalar.  */
188 
 
189 
static try
190 
scalar_check (gfc_expr * e, int n)
191 
{
192 
  if (e->rank == 0)
193 
    return SUCCESS;
194 
 
195 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
196 
             gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
197 
 
198 
  return FAILURE;
199 
}
200 
 
201 
 
202 
/* Make sure two expression have the same type.  */
203 
 
204 
static try
205 
same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
206 
{
207 
  if (gfc_compare_types (&e->ts, &f->ts))
208 
    return SUCCESS;
209 
 
210 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
211 
             "and kind as '%s'", gfc_current_intrinsic_arg[m],
212 
             gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
213 
  return FAILURE;
214 
}
215 
 
216 
 
217 
/* Make sure that an expression has a certain (nonzero) rank.  */
218 
 
219 
static try
220 
rank_check (gfc_expr * e, int n, int rank)
221 
{
222 
  if (e->rank == rank)
223 
    return SUCCESS;
224 
 
225 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
226 
             gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
227 
             &e->where, rank);
228 
  return FAILURE;
229 
}
230 
 
231 
 
232 
/* Make sure a variable expression is not an optional dummy argument.  */
233 
 
234 
static try
235 
nonoptional_check (gfc_expr * e, int n)
236 
{
237 
  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
238 
    {
239 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
240 
                 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
241 
                 &e->where);
242 
 
243 
    }
244 
 
245 
  /* TODO: Recursive check on nonoptional variables?  */
246 
 
247 
  return SUCCESS;
248 
}
249 
 
250 
 
251 
/* Check that an expression has a particular kind.  */
252 
 
253 
static try
254 
kind_value_check (gfc_expr * e, int n, int k)
255 
{
256 
  if (e->ts.kind == k)
257 
    return SUCCESS;
258 
 
259 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
260 
             gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
261 
             &e->where, k);
262 
  return FAILURE;
263 
}
264 
 
265 
 
266 
/* Make sure an expression is a variable.  */
267 
 
268 
static try
269 
variable_check (gfc_expr * e, int n)
270 
{
271 
  if ((e->expr_type == EXPR_VARIABLE
272 
       && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
273 
      || (e->expr_type == EXPR_FUNCTION
274 
          && e->symtree->n.sym->result == e->symtree->n.sym))
275 
    return SUCCESS;
276 
 
277 
  if (e->expr_type == EXPR_VARIABLE
278 
      && e->symtree->n.sym->attr.intent == INTENT_IN)
279 
    {
280 
      gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
281 
                 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
282 
                 &e->where);
283 
      return FAILURE;
284 
    }
285 
 
286 
  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
287 
             gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
288 
 
289 
  return FAILURE;
290 
}
291 
 
292 
 
293 
/* Check the common DIM parameter for correctness.  */
294 
 
295 
static try
296 
dim_check (gfc_expr * dim, int n, int optional)
297 
{
298 
  if (optional && dim == NULL)
299 
    return SUCCESS;
300 
 
301 
  if (dim == NULL)
302 
    {
303 
      gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
304 
                 gfc_current_intrinsic, gfc_current_intrinsic_where);
305 
      return FAILURE;
306 
    }
307 
 
308 
  if (type_check (dim, n, BT_INTEGER) == FAILURE)
309 
    return FAILURE;
310 
 
311 
  if (scalar_check (dim, n) == FAILURE)
312 
    return FAILURE;
313 
 
314 
  if (nonoptional_check (dim, n) == FAILURE)
315 
    return FAILURE;
316 
 
317 
  return SUCCESS;
318 
}
319 
 
320 
/* Compare the size of a along dimension ai with the size of b along
321 
   dimension bi, returning 0 if they are known not to be identical,
322 
   and 1 if they are identical, or if this cannot be determined.  */
323 
 
324 
static int
325 
identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
326 
{
327 
  mpz_t a_size, b_size;
328 
  int ret;
329 
 
330 
  gcc_assert (a->rank > ai);
331 
  gcc_assert (b->rank > bi);
332 
 
333 
  ret = 1;
334 
 
335 
  if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
336 
    {
337 
      if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
338 
        {
339 
          if (mpz_cmp (a_size, b_size) != 0)
340 
            ret = 0;
341 
 
342 
          mpz_clear (b_size);
343 
        }
344 
      mpz_clear (a_size);
345 
    }
346 
  return ret;
347 
}
348 
 
349 
/* If a DIM parameter is a constant, make sure that it is greater than
350 
   zero and less than or equal to the rank of the given array.  If
351 
   allow_assumed is zero then dim must be less than the rank of the array
352 
   for assumed size arrays.  */
353 
 
354 
static try
355 
dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
356 
{
357 
  gfc_array_ref *ar;
358 
  int rank;
359 
 
360 
  if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
361 
    return SUCCESS;
362 
 
363 
  ar = gfc_find_array_ref (array);
364 
  rank = array->rank;
365 
  if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
366 
    rank--;
367 
 
368 
  if (mpz_cmp_ui (dim->value.integer, 1) < 0
369 
      || mpz_cmp_ui (dim->value.integer, rank) > 0)
370 
    {
371 
      gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
372 
                 "dimension index", gfc_current_intrinsic, &dim->where);
373 
 
374 
      return FAILURE;
375 
    }
376 
 
377 
  return SUCCESS;
378 
}
379 
 
380 
/***** Check functions *****/
381 
 
382 
/* Check subroutine suitable for intrinsics taking a real argument and
383 
   a kind argument for the result.  */
384 
 
385 
static try
386 
check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
387 
{
388 
  if (type_check (a, 0, BT_REAL) == FAILURE)
389 
    return FAILURE;
390 
  if (kind_check (kind, 1, type) == FAILURE)
391 
    return FAILURE;
392 
 
393 
  return SUCCESS;
394 
}
395 
 
396 
/* Check subroutine suitable for ceiling, floor and nint.  */
397 
 
398 
try
399 
gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
400 
{
401 
  return check_a_kind (a, kind, BT_INTEGER);
402 
}
403 
 
404 
/* Check subroutine suitable for aint, anint.  */
405 
 
406 
try
407 
gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
408 
{
409 
  return check_a_kind (a, kind, BT_REAL);
410 
}
411 
 
412 
try
413 
gfc_check_abs (gfc_expr * a)
414 
{
415 
  if (numeric_check (a, 0) == FAILURE)
416 
    return FAILURE;
417 
 
418 
  return SUCCESS;
419 
}
420 
 
421 
try
422 
gfc_check_achar (gfc_expr * a)
423 
{
424 
 
425 
  if (type_check (a, 0, BT_INTEGER) == FAILURE)
426 
    return FAILURE;
427 
 
428 
  return SUCCESS;
429 
}
430 
 
431 
 
432 
try
433 
gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
434 
{
435 
  if (logical_array_check (mask, 0) == FAILURE)
436 
    return FAILURE;
437 
 
438 
  if (dim_check (dim, 1, 1) == FAILURE)
439 
    return FAILURE;
440 
 
441 
  return SUCCESS;
442 
}
443 
 
444 
 
445 
try
446 
gfc_check_allocated (gfc_expr * array)
447 
{
448 
  if (variable_check (array, 0) == FAILURE)
449 
    return FAILURE;
450 
 
451 
  if (array_check (array, 0) == FAILURE)
452 
    return FAILURE;
453 
 
454 
  if (!array->symtree->n.sym->attr.allocatable)
455 
    {
456 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
457 
                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
458 
                 &array->where);
459 
      return FAILURE;
460 
    }
461 
 
462 
  return SUCCESS;
463 
}
464 
 
465 
 
466 
/* Common check function where the first argument must be real or
467 
   integer and the second argument must be the same as the first.  */
468 
 
469 
try
470 
gfc_check_a_p (gfc_expr * a, gfc_expr * p)
471 
{
472 
  if (int_or_real_check (a, 0) == FAILURE)
473 
    return FAILURE;
474 
 
475 
  if (a->ts.type != p->ts.type)
476 
    {
477 
      gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
478 
                "have the same type", gfc_current_intrinsic_arg[0],
479 
                gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
480 
                &p->where);
481 
      return FAILURE;
482 
    }
483 
 
484 
  if (a->ts.kind != p->ts.kind)
485 
    {
486 
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
487 
                          &p->where) == FAILURE)
488 
       return FAILURE;
489 
    }
490 
 
491 
  return SUCCESS;
492 
}
493 
 
494 
 
495 
try
496 
gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
497 
{
498 
  symbol_attribute attr;
499 
  int i;
500 
  try t;
501 
 
502 
  if (pointer->expr_type == EXPR_VARIABLE)
503 
    attr = gfc_variable_attr (pointer, NULL);
504 
  else if (pointer->expr_type == EXPR_FUNCTION)
505 
    attr = pointer->symtree->n.sym->attr;
506 
  else
507 
    gcc_assert (0); /* Pointer must be a variable or a function.  */
508 
 
509 
  if (!attr.pointer)
510 
    {
511 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
512 
                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
513 
                 &pointer->where);
514 
      return FAILURE;
515 
    }
516 
 
517 
  /* Target argument is optional.  */
518 
  if (target == NULL)
519 
    return SUCCESS;
520 
 
521 
  if (target->expr_type == EXPR_NULL)
522 
    {
523 
      gfc_error ("NULL pointer at %L is not permitted as actual argument "
524 
                 "of '%s' intrinsic function",
525 
                 &target->where, gfc_current_intrinsic);
526 
      return FAILURE;
527 
    }
528 
 
529 
  if (target->expr_type == EXPR_VARIABLE)
530 
    attr = gfc_variable_attr (target, NULL);
531 
  else if (target->expr_type == EXPR_FUNCTION)
532 
    attr = target->symtree->n.sym->attr;
533 
  else
534 
    gcc_assert (0); /* Target must be a variable or a function.  */
535 
 
536 
  if (!attr.pointer && !attr.target)
537 
    {
538 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
539 
                 "or a TARGET", gfc_current_intrinsic_arg[1],
540 
                 gfc_current_intrinsic, &target->where);
541 
      return FAILURE;
542 
    }
543 
 
544 
  t = SUCCESS;
545 
  if (same_type_check (pointer, 0, target, 1) == FAILURE)
546 
    t = FAILURE;
547 
  if (rank_check (target, 0, pointer->rank) == FAILURE)
548 
    t = FAILURE;
549 
  if (target->rank > 0)
550 
    {
551 
      for (i = 0; i < target->rank; i++)
552 
        if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
553 
          {
554 
            gfc_error ("Array section with a vector subscript at %L shall not "
555 
                       "be the target of a pointer",
556 
                       &target->where);
557 
            t = FAILURE;
558 
            break;
559 
          }
560 
    }
561 
  return t;
562 
}
563 
 
564 
 
565 
try
566 
gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
567 
{
568 
  if (type_check (y, 0, BT_REAL) == FAILURE)
569 
    return FAILURE;
570 
  if (same_type_check (y, 0, x, 1) == FAILURE)
571 
    return FAILURE;
572 
 
573 
  return SUCCESS;
574 
}
575 
 
576 
 
577 
/* BESJN and BESYN functions.  */
578 
 
579 
try
580 
gfc_check_besn (gfc_expr * n, gfc_expr * x)
581 
{
582 
  if (scalar_check (n, 0) == FAILURE)
583 
    return FAILURE;
584 
 
585 
  if (type_check (n, 0, BT_INTEGER) == FAILURE)
586 
    return FAILURE;
587 
 
588 
  if (scalar_check (x, 1) == FAILURE)
589 
    return FAILURE;
590 
 
591 
  if (type_check (x, 1, BT_REAL) == FAILURE)
592 
    return FAILURE;
593 
 
594 
  return SUCCESS;
595 
}
596 
 
597 
 
598 
try
599 
gfc_check_btest (gfc_expr * i, gfc_expr * pos)
600 
{
601 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
602 
    return FAILURE;
603 
  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
604 
    return FAILURE;
605 
 
606 
  return SUCCESS;
607 
}
608 
 
609 
 
610 
try
611 
gfc_check_char (gfc_expr * i, gfc_expr * kind)
612 
{
613 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
614 
    return FAILURE;
615 
  if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
616 
    return FAILURE;
617 
 
618 
  return SUCCESS;
619 
}
620 
 
621 
 
622 
try
623 
gfc_check_chdir (gfc_expr * dir)
624 
{
625 
  if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
626 
    return FAILURE;
627 
 
628 
  return SUCCESS;
629 
}
630 
 
631 
 
632 
try
633 
gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
634 
{
635 
  if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
636 
    return FAILURE;
637 
 
638 
  if (status == NULL)
639 
    return SUCCESS;
640 
 
641 
  if (type_check (status, 1, BT_INTEGER) == FAILURE)
642 
    return FAILURE;
643 
 
644 
  if (scalar_check (status, 1) == FAILURE)
645 
    return FAILURE;
646 
 
647 
  return SUCCESS;
648 
}
649 
 
650 
 
651 
try
652 
gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
653 
{
654 
  if (numeric_check (x, 0) == FAILURE)
655 
    return FAILURE;
656 
 
657 
  if (y != NULL)
658 
    {
659 
      if (numeric_check (y, 1) == FAILURE)
660 
        return FAILURE;
661 
 
662 
      if (x->ts.type == BT_COMPLEX)
663 
        {
664 
          gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
665 
                     "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
666 
                     gfc_current_intrinsic, &y->where);
667 
          return FAILURE;
668 
        }
669 
    }
670 
 
671 
  if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
672 
    return FAILURE;
673 
 
674 
  return SUCCESS;
675 
}
676 
 
677 
 
678 
try
679 
gfc_check_complex (gfc_expr * x, gfc_expr * y)
680 
{
681 
  if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
682 
    {
683 
      gfc_error (
684 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
685 
        gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
686 
      return FAILURE;
687 
    }
688 
  if (scalar_check (x, 0) == FAILURE)
689 
    return FAILURE;
690 
 
691 
  if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
692 
    {
693 
      gfc_error (
694 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
695 
        gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
696 
      return FAILURE;
697 
    }
698 
  if (scalar_check (y, 1) == FAILURE)
699 
    return FAILURE;
700 
 
701 
  return SUCCESS;
702 
}
703 
 
704 
 
705 
try
706 
gfc_check_count (gfc_expr * mask, gfc_expr * dim)
707 
{
708 
  if (logical_array_check (mask, 0) == FAILURE)
709 
    return FAILURE;
710 
  if (dim_check (dim, 1, 1) == FAILURE)
711 
    return FAILURE;
712 
 
713 
  return SUCCESS;
714 
}
715 
 
716 
 
717 
try
718 
gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
719 
{
720 
  if (array_check (array, 0) == FAILURE)
721 
    return FAILURE;
722 
 
723 
  if (array->rank == 1)
724 
    {
725 
      if (scalar_check (shift, 1) == FAILURE)
726 
        return FAILURE;
727 
    }
728 
  else
729 
    {
730 
      /* TODO: more requirements on shift parameter.  */
731 
    }
732 
 
733 
  if (dim_check (dim, 2, 1) == FAILURE)
734 
    return FAILURE;
735 
 
736 
  return SUCCESS;
737 
}
738 
 
739 
 
740 
try
741 
gfc_check_ctime (gfc_expr * time)
742 
{
743 
  if (scalar_check (time, 0) == FAILURE)
744 
    return FAILURE;
745 
 
746 
  if (type_check (time, 0, BT_INTEGER) == FAILURE)
747 
    return FAILURE;
748 
 
749 
  return SUCCESS;
750 
}
751 
 
752 
 
753 
try
754 
gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
755 
{
756 
  if (numeric_check (x, 0) == FAILURE)
757 
    return FAILURE;
758 
 
759 
  if (y != NULL)
760 
    {
761 
      if (numeric_check (y, 1) == FAILURE)
762 
        return FAILURE;
763 
 
764 
      if (x->ts.type == BT_COMPLEX)
765 
        {
766 
          gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
767 
                     "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
768 
                     gfc_current_intrinsic, &y->where);
769 
          return FAILURE;
770 
        }
771 
    }
772 
 
773 
  return SUCCESS;
774 
}
775 
 
776 
 
777 
try
778 
gfc_check_dble (gfc_expr * x)
779 
{
780 
  if (numeric_check (x, 0) == FAILURE)
781 
    return FAILURE;
782 
 
783 
  return SUCCESS;
784 
}
785 
 
786 
 
787 
try
788 
gfc_check_digits (gfc_expr * x)
789 
{
790 
  if (int_or_real_check (x, 0) == FAILURE)
791 
    return FAILURE;
792 
 
793 
  return SUCCESS;
794 
}
795 
 
796 
 
797 
try
798 
gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
799 
{
800 
  switch (vector_a->ts.type)
801 
    {
802 
    case BT_LOGICAL:
803 
      if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
804 
        return FAILURE;
805 
      break;
806 
 
807 
    case BT_INTEGER:
808 
    case BT_REAL:
809 
    case BT_COMPLEX:
810 
      if (numeric_check (vector_b, 1) == FAILURE)
811 
        return FAILURE;
812 
      break;
813 
 
814 
    default:
815 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
816 
                 "or LOGICAL", gfc_current_intrinsic_arg[0],
817 
                 gfc_current_intrinsic, &vector_a->where);
818 
      return FAILURE;
819 
    }
820 
 
821 
  if (rank_check (vector_a, 0, 1) == FAILURE)
822 
    return FAILURE;
823 
 
824 
  if (rank_check (vector_b, 1, 1) == FAILURE)
825 
    return FAILURE;
826 
 
827 
  if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
828 
    {
829 
      gfc_error ("different shape for arguments '%s' and '%s' "
830 
                 "at %L for intrinsic 'dot_product'",
831 
                 gfc_current_intrinsic_arg[0],
832 
                 gfc_current_intrinsic_arg[1],
833 
                 &vector_a->where);
834 
      return FAILURE;
835 
    }
836 
 
837 
  return SUCCESS;
838 
}
839 
 
840 
 
841 
try
842 
gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
843 
                   gfc_expr * dim)
844 
{
845 
  if (array_check (array, 0) == FAILURE)
846 
    return FAILURE;
847 
 
848 
  if (type_check (shift, 1, BT_INTEGER) == FAILURE)
849 
    return FAILURE;
850 
 
851 
  if (array->rank == 1)
852 
    {
853 
      if (scalar_check (shift, 2) == FAILURE)
854 
        return FAILURE;
855 
    }
856 
  else
857 
    {
858 
      /* TODO: more weird restrictions on shift.  */
859 
    }
860 
 
861 
  if (boundary != NULL)
862 
    {
863 
      if (same_type_check (array, 0, boundary, 2) == FAILURE)
864 
        return FAILURE;
865 
 
866 
      /* TODO: more restrictions on boundary.  */
867 
    }
868 
 
869 
  if (dim_check (dim, 1, 1) == FAILURE)
870 
    return FAILURE;
871 
 
872 
  return SUCCESS;
873 
}
874 
 
875 
 
876 
/* A single complex argument.  */
877 
 
878 
try
879 
gfc_check_fn_c (gfc_expr * a)
880 
{
881 
  if (type_check (a, 0, BT_COMPLEX) == FAILURE)
882 
    return FAILURE;
883 
 
884 
  return SUCCESS;
885 
}
886 
 
887 
 
888 
/* A single real argument.  */
889 
 
890 
try
891 
gfc_check_fn_r (gfc_expr * a)
892 
{
893 
  if (type_check (a, 0, BT_REAL) == FAILURE)
894 
    return FAILURE;
895 
 
896 
  return SUCCESS;
897 
}
898 
 
899 
 
900 
/* A single real or complex argument.  */
901 
 
902 
try
903 
gfc_check_fn_rc (gfc_expr * a)
904 
{
905 
  if (real_or_complex_check (a, 0) == FAILURE)
906 
    return FAILURE;
907 
 
908 
  return SUCCESS;
909 
}
910 
 
911 
 
912 
try
913 
gfc_check_fnum (gfc_expr * unit)
914 
{
915 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
916 
    return FAILURE;
917 
 
918 
  if (scalar_check (unit, 0) == FAILURE)
919 
    return FAILURE;
920 
 
921 
  return SUCCESS;
922 
}
923 
 
924 
 
925 
/* This is used for the g77 one-argument Bessel functions, and the
926 
   error function.  */
927 
 
928 
try
929 
gfc_check_g77_math1 (gfc_expr * x)
930 
{
931 
  if (scalar_check (x, 0) == FAILURE)
932 
    return FAILURE;
933 
 
934 
  if (type_check (x, 0, BT_REAL) == FAILURE)
935 
    return FAILURE;
936 
 
937 
  return SUCCESS;
938 
}
939 
 
940 
 
941 
try
942 
gfc_check_huge (gfc_expr * x)
943 
{
944 
  if (int_or_real_check (x, 0) == FAILURE)
945 
    return FAILURE;
946 
 
947 
  return SUCCESS;
948 
}
949 
 
950 
 
951 
/* Check that the single argument is an integer.  */
952 
 
953 
try
954 
gfc_check_i (gfc_expr * i)
955 
{
956 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
957 
    return FAILURE;
958 
 
959 
  return SUCCESS;
960 
}
961 
 
962 
 
963 
try
964 
gfc_check_iand (gfc_expr * i, gfc_expr * j)
965 
{
966 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
967 
    return FAILURE;
968 
 
969 
  if (type_check (j, 1, BT_INTEGER) == FAILURE)
970 
    return FAILURE;
971 
 
972 
  if (i->ts.kind != j->ts.kind)
973 
    {
974 
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
975 
                          &i->where) == FAILURE)
976 
        return FAILURE;
977 
    }
978 
 
979 
  return SUCCESS;
980 
}
981 
 
982 
 
983 
try
984 
gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
985 
{
986 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
987 
    return FAILURE;
988 
 
989 
  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
990 
    return FAILURE;
991 
 
992 
  return SUCCESS;
993 
}
994 
 
995 
 
996 
try
997 
gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
998 
{
999 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
1000 
    return FAILURE;
1001 
 
1002 
  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1003 
    return FAILURE;
1004 
 
1005 
  if (type_check (len, 2, BT_INTEGER) == FAILURE)
1006 
    return FAILURE;
1007 
 
1008 
  return SUCCESS;
1009 
}
1010 
 
1011 
 
1012 
try
1013 
gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
1014 
{
1015 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
1016 
    return FAILURE;
1017 
 
1018 
  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1019 
    return FAILURE;
1020 
 
1021 
  return SUCCESS;
1022 
}
1023 
 
1024 
 
1025 
try
1026 
gfc_check_ichar_iachar (gfc_expr * c)
1027 
{
1028 
  int i;
1029 
 
1030 
  if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1031 
    return FAILURE;
1032 
 
1033 
  if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1034 
    {
1035 
      gfc_expr *start;
1036 
      gfc_expr *end;
1037 
      gfc_ref *ref;
1038 
 
1039 
      /* Substring references don't have the charlength set.  */
1040 
      ref = c->ref;
1041 
      while (ref && ref->type != REF_SUBSTRING)
1042 
        ref = ref->next;
1043 
 
1044 
      gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1045 
 
1046 
      if (!ref)
1047 
        {
1048 
          /* Check that the argument is length one.  Non-constant lengths
1049 
             can't be checked here, so assume thay are ok.  */
1050 
          if (c->ts.cl && c->ts.cl->length)
1051 
            {
1052 
              /* If we already have a length for this expression then use it.  */
1053 
              if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1054 
                return SUCCESS;
1055 
              i = mpz_get_si (c->ts.cl->length->value.integer);
1056 
            }
1057 
          else
1058 
            return SUCCESS;
1059 
        }
1060 
      else
1061 
        {
1062 
          start = ref->u.ss.start;
1063 
          end = ref->u.ss.end;
1064 
 
1065 
          gcc_assert (start);
1066 
          if (end == NULL || end->expr_type != EXPR_CONSTANT
1067 
              || start->expr_type != EXPR_CONSTANT)
1068 
            return SUCCESS;
1069 
 
1070 
          i = mpz_get_si (end->value.integer) + 1
1071 
              - mpz_get_si (start->value.integer);
1072 
        }
1073 
    }
1074 
  else
1075 
    return SUCCESS;
1076 
 
1077 
  if (i != 1)
1078 
    {
1079 
      gfc_error ("Argument of %s at %L must be of length one",
1080 
                 gfc_current_intrinsic, &c->where);
1081 
      return FAILURE;
1082 
    }
1083 
 
1084 
  return SUCCESS;
1085 
}
1086 
 
1087 
 
1088 
try
1089 
gfc_check_idnint (gfc_expr * a)
1090 
{
1091 
  if (double_check (a, 0) == FAILURE)
1092 
    return FAILURE;
1093 
 
1094 
  return SUCCESS;
1095 
}
1096 
 
1097 
 
1098 
try
1099 
gfc_check_ieor (gfc_expr * i, gfc_expr * j)
1100 
{
1101 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
1102 
    return FAILURE;
1103 
 
1104 
  if (type_check (j, 1, BT_INTEGER) == FAILURE)
1105 
    return FAILURE;
1106 
 
1107 
  if (i->ts.kind != j->ts.kind)
1108 
    {
1109 
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1110 
                          &i->where) == FAILURE)
1111 
        return FAILURE;
1112 
    }
1113 
 
1114 
  return SUCCESS;
1115 
}
1116 
 
1117 
 
1118 
try
1119 
gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
1120 
{
1121 
  if (type_check (string, 0, BT_CHARACTER) == FAILURE
1122 
      || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1123 
    return FAILURE;
1124 
 
1125 
 
1126 
  if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1127 
    return FAILURE;
1128 
 
1129 
  if (string->ts.kind != substring->ts.kind)
1130 
    {
1131 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1132 
                 "kind as '%s'", gfc_current_intrinsic_arg[1],
1133 
                 gfc_current_intrinsic, &substring->where,
1134 
                 gfc_current_intrinsic_arg[0]);
1135 
      return FAILURE;
1136 
    }
1137 
 
1138 
  return SUCCESS;
1139 
}
1140 
 
1141 
 
1142 
try
1143 
gfc_check_int (gfc_expr * x, gfc_expr * kind)
1144 
{
1145 
  if (numeric_check (x, 0) == FAILURE)
1146 
    return FAILURE;
1147 
 
1148 
  if (kind != NULL)
1149 
    {
1150 
      if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1151 
    return FAILURE;
1152 
 
1153 
      if (scalar_check (kind, 1) == FAILURE)
1154 
        return FAILURE;
1155 
    }
1156 
 
1157 
  return SUCCESS;
1158 
}
1159 
 
1160 
 
1161 
try
1162 
gfc_check_ior (gfc_expr * i, gfc_expr * j)
1163 
{
1164 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
1165 
    return FAILURE;
1166 
 
1167 
  if (type_check (j, 1, BT_INTEGER) == FAILURE)
1168 
    return FAILURE;
1169 
 
1170 
  if (i->ts.kind != j->ts.kind)
1171 
    {
1172 
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1173 
                          &i->where) == FAILURE)
1174 
    return FAILURE;
1175 
    }
1176 
 
1177 
  return SUCCESS;
1178 
}
1179 
 
1180 
 
1181 
try
1182 
gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
1183 
{
1184 
  if (type_check (i, 0, BT_INTEGER) == FAILURE
1185 
      || type_check (shift, 1, BT_INTEGER) == FAILURE)
1186 
    return FAILURE;
1187 
 
1188 
  return SUCCESS;
1189 
}
1190 
 
1191 
 
1192 
try
1193 
gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
1194 
{
1195 
  if (type_check (i, 0, BT_INTEGER) == FAILURE
1196 
      || type_check (shift, 1, BT_INTEGER) == FAILURE)
1197 
    return FAILURE;
1198 
 
1199 
  if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1200 
    return FAILURE;
1201 
 
1202 
  return SUCCESS;
1203 
}
1204 
 
1205 
 
1206 
try
1207 
gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
1208 
{
1209 
  if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1210 
    return FAILURE;
1211 
 
1212 
  if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1213 
    return FAILURE;
1214 
 
1215 
  return SUCCESS;
1216 
}
1217 
 
1218 
 
1219 
try
1220 
gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
1221 
{
1222 
  if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1223 
    return FAILURE;
1224 
 
1225 
  if (type_check (sig, 1, BT_INTEGER) == 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 
try
1242 
gfc_check_kind (gfc_expr * x)
1243 
{
1244 
  if (x->ts.type == BT_DERIVED)
1245 
    {
1246 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1247 
                 "non-derived type", gfc_current_intrinsic_arg[0],
1248 
                 gfc_current_intrinsic, &x->where);
1249 
      return FAILURE;
1250 
    }
1251 
 
1252 
  return SUCCESS;
1253 
}
1254 
 
1255 
 
1256 
try
1257 
gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1258 
{
1259 
  if (array_check (array, 0) == FAILURE)
1260 
    return FAILURE;
1261 
 
1262 
  if (dim != NULL)
1263 
    {
1264 
      if (dim_check (dim, 1, 1) == FAILURE)
1265 
        return FAILURE;
1266 
 
1267 
      if (dim_rank_check (dim, array, 1) == FAILURE)
1268 
        return FAILURE;
1269 
    }
1270 
  return SUCCESS;
1271 
}
1272 
 
1273 
 
1274 
try
1275 
gfc_check_link (gfc_expr * path1, gfc_expr * path2)
1276 
{
1277 
  if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1278 
    return FAILURE;
1279 
 
1280 
  if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1281 
    return FAILURE;
1282 
 
1283 
  return SUCCESS;
1284 
}
1285 
 
1286 
 
1287 
try
1288 
gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1289 
{
1290 
  if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1291 
    return FAILURE;
1292 
 
1293 
  if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1294 
    return FAILURE;
1295 
 
1296 
  if (status == NULL)
1297 
    return SUCCESS;
1298 
 
1299 
  if (type_check (status, 2, BT_INTEGER) == FAILURE)
1300 
    return FAILURE;
1301 
 
1302 
  if (scalar_check (status, 2) == FAILURE)
1303 
    return FAILURE;
1304 
 
1305 
  return SUCCESS;
1306 
}
1307 
 
1308 
try
1309 
gfc_check_loc (gfc_expr *expr)
1310 
{
1311 
  return variable_check (expr, 0);
1312 
}
1313 
 
1314 
 
1315 
try
1316 
gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
1317 
{
1318 
  if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1319 
    return FAILURE;
1320 
 
1321 
  if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1322 
    return FAILURE;
1323 
 
1324 
  return SUCCESS;
1325 
}
1326 
 
1327 
 
1328 
try
1329 
gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1330 
{
1331 
  if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1332 
    return FAILURE;
1333 
 
1334 
  if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1335 
    return FAILURE;
1336 
 
1337 
  if (status == NULL)
1338 
    return SUCCESS;
1339 
 
1340 
  if (type_check (status, 2, BT_INTEGER) == FAILURE)
1341 
    return FAILURE;
1342 
 
1343 
  if (scalar_check (status, 2) == FAILURE)
1344 
    return FAILURE;
1345 
 
1346 
  return SUCCESS;
1347 
}
1348 
 
1349 
 
1350 
try
1351 
gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1352 
{
1353 
  if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1354 
    return FAILURE;
1355 
  if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1356 
    return FAILURE;
1357 
 
1358 
  return SUCCESS;
1359 
}
1360 
 
1361 
 
1362 
/* Min/max family.  */
1363 
 
1364 
static try
1365 
min_max_args (gfc_actual_arglist * arg)
1366 
{
1367 
  if (arg == NULL || arg->next == NULL)
1368 
    {
1369 
      gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1370 
                 gfc_current_intrinsic, gfc_current_intrinsic_where);
1371 
      return FAILURE;
1372 
    }
1373 
 
1374 
  return SUCCESS;
1375 
}
1376 
 
1377 
 
1378 
static try
1379 
check_rest (bt type, int kind, gfc_actual_arglist * arg)
1380 
{
1381 
  gfc_expr *x;
1382 
  int n;
1383 
 
1384 
  if (min_max_args (arg) == FAILURE)
1385 
    return FAILURE;
1386 
 
1387 
  n = 1;
1388 
 
1389 
  for (; arg; arg = arg->next, n++)
1390 
    {
1391 
      x = arg->expr;
1392 
      if (x->ts.type != type || x->ts.kind != kind)
1393 
        {
1394 
          if (x->ts.type == type)
1395 
            {
1396 
              if (gfc_notify_std (GFC_STD_GNU,
1397 
                    "Extension: Different type kinds at %L", &x->where)
1398 
                  == FAILURE)
1399 
                return FAILURE;
1400 
            }
1401 
          else
1402 
            {
1403 
              gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1404 
                         n, gfc_current_intrinsic, &x->where,
1405 
                         gfc_basic_typename (type), kind);
1406 
              return FAILURE;
1407 
            }
1408 
        }
1409 
    }
1410 
 
1411 
  return SUCCESS;
1412 
}
1413 
 
1414 
 
1415 
try
1416 
gfc_check_min_max (gfc_actual_arglist * arg)
1417 
{
1418 
  gfc_expr *x;
1419 
 
1420 
  if (min_max_args (arg) == FAILURE)
1421 
    return FAILURE;
1422 
 
1423 
  x = arg->expr;
1424 
 
1425 
  if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1426 
    {
1427 
      gfc_error
1428 
        ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1429 
         gfc_current_intrinsic, &x->where);
1430 
      return FAILURE;
1431 
    }
1432 
 
1433 
  return check_rest (x->ts.type, x->ts.kind, arg);
1434 
}
1435 
 
1436 
 
1437 
try
1438 
gfc_check_min_max_integer (gfc_actual_arglist * arg)
1439 
{
1440 
  return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1441 
}
1442 
 
1443 
 
1444 
try
1445 
gfc_check_min_max_real (gfc_actual_arglist * arg)
1446 
{
1447 
  return check_rest (BT_REAL, gfc_default_real_kind, arg);
1448 
}
1449 
 
1450 
 
1451 
try
1452 
gfc_check_min_max_double (gfc_actual_arglist * arg)
1453 
{
1454 
  return check_rest (BT_REAL, gfc_default_double_kind, arg);
1455 
}
1456 
 
1457 
/* End of min/max family.  */
1458 
 
1459 
try
1460 
gfc_check_malloc (gfc_expr * size)
1461 
{
1462 
  if (type_check (size, 0, BT_INTEGER) == FAILURE)
1463 
    return FAILURE;
1464 
 
1465 
  if (scalar_check (size, 0) == FAILURE)
1466 
    return FAILURE;
1467 
 
1468 
  return SUCCESS;
1469 
}
1470 
 
1471 
 
1472 
try
1473 
gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1474 
{
1475 
  if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1476 
    {
1477 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1478 
                 "or LOGICAL", gfc_current_intrinsic_arg[0],
1479 
                 gfc_current_intrinsic, &matrix_a->where);
1480 
      return FAILURE;
1481 
    }
1482 
 
1483 
  if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1484 
    {
1485 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1486 
                 "or LOGICAL", gfc_current_intrinsic_arg[1],
1487 
                 gfc_current_intrinsic, &matrix_b->where);
1488 
      return FAILURE;
1489 
    }
1490 
 
1491 
  switch (matrix_a->rank)
1492 
    {
1493 
    case 1:
1494 
      if (rank_check (matrix_b, 1, 2) == FAILURE)
1495 
        return FAILURE;
1496 
      /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
1497 
      if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1498 
        {
1499 
          gfc_error ("different shape on dimension 1 for arguments '%s' "
1500 
                     "and '%s' at %L for intrinsic matmul",
1501 
                     gfc_current_intrinsic_arg[0],
1502 
                     gfc_current_intrinsic_arg[1],
1503 
                     &matrix_a->where);
1504 
          return FAILURE;
1505 
        }
1506 
      break;
1507 
 
1508 
    case 2:
1509 
      if (matrix_b->rank != 2)
1510 
        {
1511 
          if (rank_check (matrix_b, 1, 1) == FAILURE)
1512 
            return FAILURE;
1513 
        }
1514 
      /* matrix_b has rank 1 or 2 here. Common check for the cases
1515 
         - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1516 
         - matrix_a has shape (n,m) and matrix_b has shape (m).  */
1517 
      if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1518 
        {
1519 
          gfc_error ("different shape on dimension 2 for argument '%s' and "
1520 
                     "dimension 1 for argument '%s' at %L for intrinsic "
1521 
                     "matmul", gfc_current_intrinsic_arg[0],
1522 
                     gfc_current_intrinsic_arg[1], &matrix_a->where);
1523 
          return FAILURE;
1524 
        }
1525 
      break;
1526 
 
1527 
    default:
1528 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1529 
                 "1 or 2", gfc_current_intrinsic_arg[0],
1530 
                 gfc_current_intrinsic, &matrix_a->where);
1531 
      return FAILURE;
1532 
    }
1533 
 
1534 
  return SUCCESS;
1535 
}
1536 
 
1537 
 
1538 
/* Whoever came up with this interface was probably on something.
1539 
   The possibilities for the occupation of the second and third
1540 
   parameters are:
1541 
 
1542 
         Arg #2     Arg #3
1543 
         NULL       NULL
1544 
         DIM        NULL
1545 
         MASK       NULL
1546 
         NULL       MASK             minloc(array, mask=m)
1547 
         DIM        MASK
1548 
 
1549 
   I.e. in the case of minloc(array,mask), mask will be in the second
1550 
   position of the argument list and we'll have to fix that up.  */
1551 
 
1552 
try
1553 
gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1554 
{
1555 
  gfc_expr *a, *m, *d;
1556 
 
1557 
  a = ap->expr;
1558 
  if (int_or_real_check (a, 0) == FAILURE
1559 
      || array_check (a, 0) == FAILURE)
1560 
    return FAILURE;
1561 
 
1562 
  d = ap->next->expr;
1563 
  m = ap->next->next->expr;
1564 
 
1565 
  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1566 
      && ap->next->name == NULL)
1567 
    {
1568 
      m = d;
1569 
      d = NULL;
1570 
 
1571 
      ap->next->expr = NULL;
1572 
      ap->next->next->expr = m;
1573 
    }
1574 
 
1575 
  if (dim_check (d, 1, 1) == FAILURE)
1576 
    return FAILURE;
1577 
 
1578 
  if (d && dim_rank_check (d, a, 0) == FAILURE)
1579 
    return FAILURE;
1580 
 
1581 
  if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1582 
    return FAILURE;
1583 
 
1584 
  if (m != NULL)
1585 
    {
1586 
      char buffer[80];
1587 
      snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1588 
               gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1589 
               gfc_current_intrinsic);
1590 
      if (gfc_check_conformance (buffer, a, m) == FAILURE)
1591 
        return FAILURE;
1592 
    }
1593 
 
1594 
  return SUCCESS;
1595 
}
1596 
 
1597 
 
1598 
/* Similar to minloc/maxloc, the argument list might need to be
1599 
   reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1600 
   difference is that MINLOC/MAXLOC take an additional KIND argument.
1601 
   The possibilities are:
1602 
 
1603 
         Arg #2     Arg #3
1604 
         NULL       NULL
1605 
         DIM        NULL
1606 
         MASK       NULL
1607 
         NULL       MASK             minval(array, mask=m)
1608 
         DIM        MASK
1609 
 
1610 
   I.e. in the case of minval(array,mask), mask will be in the second
1611 
   position of the argument list and we'll have to fix that up.  */
1612 
 
1613 
static try
1614 
check_reduction (gfc_actual_arglist * ap)
1615 
{
1616 
  gfc_expr *a, *m, *d;
1617 
 
1618 
  a = ap->expr;
1619 
  d = ap->next->expr;
1620 
  m = ap->next->next->expr;
1621 
 
1622 
  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1623 
      && ap->next->name == NULL)
1624 
    {
1625 
      m = d;
1626 
      d = NULL;
1627 
 
1628 
      ap->next->expr = NULL;
1629 
      ap->next->next->expr = m;
1630 
    }
1631 
 
1632 
  if (dim_check (d, 1, 1) == FAILURE)
1633 
    return FAILURE;
1634 
 
1635 
  if (d && dim_rank_check (d, a, 0) == FAILURE)
1636 
    return FAILURE;
1637 
 
1638 
  if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1639 
    return FAILURE;
1640 
 
1641 
  if (m != NULL)
1642 
    {
1643 
      char buffer[80];
1644 
      snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1645 
               gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1646 
               gfc_current_intrinsic);
1647 
      if (gfc_check_conformance (buffer, a, m) == FAILURE)
1648 
        return FAILURE;
1649 
    }
1650 
 
1651 
  return SUCCESS;
1652 
}
1653 
 
1654 
 
1655 
try
1656 
gfc_check_minval_maxval (gfc_actual_arglist * ap)
1657 
{
1658 
  if (int_or_real_check (ap->expr, 0) == FAILURE
1659 
      || array_check (ap->expr, 0) == FAILURE)
1660 
    return FAILURE;
1661 
 
1662 
  return check_reduction (ap);
1663 
}
1664 
 
1665 
 
1666 
try
1667 
gfc_check_product_sum (gfc_actual_arglist * ap)
1668 
{
1669 
  if (numeric_check (ap->expr, 0) == FAILURE
1670 
      || array_check (ap->expr, 0) == FAILURE)
1671 
    return FAILURE;
1672 
 
1673 
  return check_reduction (ap);
1674 
}
1675 
 
1676 
 
1677 
try
1678 
gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1679 
{
1680 
  char buffer[80];
1681 
 
1682 
  if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1683 
    return FAILURE;
1684 
 
1685 
  if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1686 
    return FAILURE;
1687 
 
1688 
  snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1689 
           gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1690 
           gfc_current_intrinsic);
1691 
  if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
1692 
    return FAILURE;
1693 
 
1694 
  snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1695 
           gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1696 
           gfc_current_intrinsic);
1697 
  if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
1698 
    return FAILURE;
1699 
 
1700 
  return SUCCESS;
1701 
}
1702 
 
1703 
 
1704 
try
1705 
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1706 
{
1707 
  if (type_check (x, 0, BT_REAL) == FAILURE)
1708 
    return FAILURE;
1709 
 
1710 
  if (type_check (s, 1, BT_REAL) == FAILURE)
1711 
    return FAILURE;
1712 
 
1713 
  return SUCCESS;
1714 
}
1715 
 
1716 
 
1717 
try
1718 
gfc_check_null (gfc_expr * mold)
1719 
{
1720 
  symbol_attribute attr;
1721 
 
1722 
  if (mold == NULL)
1723 
    return SUCCESS;
1724 
 
1725 
  if (variable_check (mold, 0) == FAILURE)
1726 
    return FAILURE;
1727 
 
1728 
  attr = gfc_variable_attr (mold, NULL);
1729 
 
1730 
  if (!attr.pointer)
1731 
    {
1732 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1733 
                 gfc_current_intrinsic_arg[0],
1734 
                 gfc_current_intrinsic, &mold->where);
1735 
      return FAILURE;
1736 
    }
1737 
 
1738 
  return SUCCESS;
1739 
}
1740 
 
1741 
 
1742 
try
1743 
gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1744 
{
1745 
  char buffer[80];
1746 
 
1747 
  if (array_check (array, 0) == FAILURE)
1748 
    return FAILURE;
1749 
 
1750 
  if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1751 
    return FAILURE;
1752 
 
1753 
  snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1754 
           gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1755 
           gfc_current_intrinsic);
1756 
  if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1757 
    return FAILURE;
1758 
 
1759 
  if (vector != NULL)
1760 
    {
1761 
      if (same_type_check (array, 0, vector, 2) == FAILURE)
1762 
        return FAILURE;
1763 
 
1764 
      if (rank_check (vector, 2, 1) == FAILURE)
1765 
        return FAILURE;
1766 
 
1767 
      /* TODO: More constraints here.  */
1768 
    }
1769 
 
1770 
  return SUCCESS;
1771 
}
1772 
 
1773 
 
1774 
try
1775 
gfc_check_precision (gfc_expr * x)
1776 
{
1777 
  if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1778 
    {
1779 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1780 
                 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1781 
                 gfc_current_intrinsic, &x->where);
1782 
      return FAILURE;
1783 
    }
1784 
 
1785 
  return SUCCESS;
1786 
}
1787 
 
1788 
 
1789 
try
1790 
gfc_check_present (gfc_expr * a)
1791 
{
1792 
  gfc_symbol *sym;
1793 
 
1794 
  if (variable_check (a, 0) == FAILURE)
1795 
    return FAILURE;
1796 
 
1797 
  sym = a->symtree->n.sym;
1798 
  if (!sym->attr.dummy)
1799 
    {
1800 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1801 
                 "dummy variable", gfc_current_intrinsic_arg[0],
1802 
                 gfc_current_intrinsic, &a->where);
1803 
      return FAILURE;
1804 
    }
1805 
 
1806 
  if (!sym->attr.optional)
1807 
    {
1808 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1809 
                 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1810 
                 gfc_current_intrinsic, &a->where);
1811 
      return FAILURE;
1812 
    }
1813 
 
1814 
  return SUCCESS;
1815 
}
1816 
 
1817 
 
1818 
try
1819 
gfc_check_radix (gfc_expr * x)
1820 
{
1821 
  if (int_or_real_check (x, 0) == FAILURE)
1822 
    return FAILURE;
1823 
 
1824 
  return SUCCESS;
1825 
}
1826 
 
1827 
 
1828 
try
1829 
gfc_check_range (gfc_expr * x)
1830 
{
1831 
  if (numeric_check (x, 0) == FAILURE)
1832 
    return FAILURE;
1833 
 
1834 
  return SUCCESS;
1835 
}
1836 
 
1837 
 
1838 
/* real, float, sngl.  */
1839 
try
1840 
gfc_check_real (gfc_expr * a, gfc_expr * kind)
1841 
{
1842 
  if (numeric_check (a, 0) == FAILURE)
1843 
    return FAILURE;
1844 
 
1845 
  if (kind_check (kind, 1, BT_REAL) == FAILURE)
1846 
    return FAILURE;
1847 
 
1848 
  return SUCCESS;
1849 
}
1850 
 
1851 
 
1852 
try
1853 
gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
1854 
{
1855 
  if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1856 
    return FAILURE;
1857 
 
1858 
  if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1859 
    return FAILURE;
1860 
 
1861 
  return SUCCESS;
1862 
}
1863 
 
1864 
 
1865 
try
1866 
gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1867 
{
1868 
  if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1869 
    return FAILURE;
1870 
 
1871 
  if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1872 
    return FAILURE;
1873 
 
1874 
  if (status == NULL)
1875 
    return SUCCESS;
1876 
 
1877 
  if (type_check (status, 2, BT_INTEGER) == FAILURE)
1878 
    return FAILURE;
1879 
 
1880 
  if (scalar_check (status, 2) == FAILURE)
1881 
    return FAILURE;
1882 
 
1883 
  return SUCCESS;
1884 
}
1885 
 
1886 
 
1887 
try
1888 
gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1889 
{
1890 
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1891 
    return FAILURE;
1892 
 
1893 
  if (scalar_check (x, 0) == FAILURE)
1894 
    return FAILURE;
1895 
 
1896 
  if (type_check (y, 0, BT_INTEGER) == FAILURE)
1897 
    return FAILURE;
1898 
 
1899 
  if (scalar_check (y, 1) == FAILURE)
1900 
    return FAILURE;
1901 
 
1902 
  return SUCCESS;
1903 
}
1904 
 
1905 
 
1906 
try
1907 
gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1908 
                   gfc_expr * pad, gfc_expr * order)
1909 
{
1910 
  mpz_t size;
1911 
  int m;
1912 
 
1913 
  if (array_check (source, 0) == FAILURE)
1914 
    return FAILURE;
1915 
 
1916 
  if (rank_check (shape, 1, 1) == FAILURE)
1917 
    return FAILURE;
1918 
 
1919 
  if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1920 
    return FAILURE;
1921 
 
1922 
  if (gfc_array_size (shape, &size) != SUCCESS)
1923 
    {
1924 
      gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1925 
                 "array of constant size", &shape->where);
1926 
      return FAILURE;
1927 
    }
1928 
 
1929 
  m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1930 
  mpz_clear (size);
1931 
 
1932 
  if (m > 0)
1933 
    {
1934 
      gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
1935 
                 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
1936 
      return FAILURE;
1937 
    }
1938 
 
1939 
  if (pad != NULL)
1940 
    {
1941 
      if (same_type_check (source, 0, pad, 2) == FAILURE)
1942 
        return FAILURE;
1943 
      if (array_check (pad, 2) == FAILURE)
1944 
        return FAILURE;
1945 
    }
1946 
 
1947 
  if (order != NULL && array_check (order, 3) == FAILURE)
1948 
    return FAILURE;
1949 
 
1950 
  return SUCCESS;
1951 
}
1952 
 
1953 
 
1954 
try
1955 
gfc_check_scale (gfc_expr * x, gfc_expr * i)
1956 
{
1957 
  if (type_check (x, 0, BT_REAL) == FAILURE)
1958 
    return FAILURE;
1959 
 
1960 
  if (type_check (i, 1, BT_INTEGER) == FAILURE)
1961 
    return FAILURE;
1962 
 
1963 
  return SUCCESS;
1964 
}
1965 
 
1966 
 
1967 
try
1968 
gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1969 
{
1970 
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1971 
    return FAILURE;
1972 
 
1973 
  if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1974 
    return FAILURE;
1975 
 
1976 
  if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1977 
    return FAILURE;
1978 
 
1979 
  if (same_type_check (x, 0, y, 1) == FAILURE)
1980 
    return FAILURE;
1981 
 
1982 
  return SUCCESS;
1983 
}
1984 
 
1985 
 
1986 
try
1987 
gfc_check_secnds (gfc_expr * r)
1988 
{
1989 
 
1990 
  if (type_check (r, 0, BT_REAL) == FAILURE)
1991 
    return FAILURE;
1992 
 
1993 
  if (kind_value_check (r, 0, 4) == FAILURE)
1994 
    return FAILURE;
1995 
 
1996 
  if (scalar_check (r, 0) == FAILURE)
1997 
    return FAILURE;
1998 
 
1999 
  return SUCCESS;
2000 
}
2001 
 
2002 
 
2003 
try
2004 
gfc_check_selected_int_kind (gfc_expr * r)
2005 
{
2006 
 
2007 
  if (type_check (r, 0, BT_INTEGER) == FAILURE)
2008 
    return FAILURE;
2009 
 
2010 
  if (scalar_check (r, 0) == FAILURE)
2011 
    return FAILURE;
2012 
 
2013 
  return SUCCESS;
2014 
}
2015 
 
2016 
 
2017 
try
2018 
gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
2019 
{
2020 
  if (p == NULL && r == NULL)
2021 
    {
2022 
      gfc_error ("Missing arguments to %s intrinsic at %L",
2023 
                 gfc_current_intrinsic, gfc_current_intrinsic_where);
2024 
 
2025 
      return FAILURE;
2026 
    }
2027 
 
2028 
  if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2029 
    return FAILURE;
2030 
 
2031 
  if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2032 
    return FAILURE;
2033 
 
2034 
  return SUCCESS;
2035 
}
2036 
 
2037 
 
2038 
try
2039 
gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
2040 
{
2041 
  if (type_check (x, 0, BT_REAL) == FAILURE)
2042 
    return FAILURE;
2043 
 
2044 
  if (type_check (i, 1, BT_INTEGER) == FAILURE)
2045 
    return FAILURE;
2046 
 
2047 
  return SUCCESS;
2048 
}
2049 
 
2050 
 
2051 
try
2052 
gfc_check_shape (gfc_expr * source)
2053 
{
2054 
  gfc_array_ref *ar;
2055 
 
2056 
  if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2057 
    return SUCCESS;
2058 
 
2059 
  ar = gfc_find_array_ref (source);
2060 
 
2061 
  if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2062 
    {
2063 
      gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2064 
                 "an assumed size array", &source->where);
2065 
      return FAILURE;
2066 
    }
2067 
 
2068 
  return SUCCESS;
2069 
}
2070 
 
2071 
 
2072 
try
2073 
gfc_check_sign (gfc_expr * a, gfc_expr * b)
2074 
{
2075 
  if (int_or_real_check (a, 0) == FAILURE)
2076 
    return FAILURE;
2077 
 
2078 
  if (same_type_check (a, 0, b, 1) == FAILURE)
2079 
    return FAILURE;
2080 
 
2081 
  return SUCCESS;
2082 
}
2083 
 
2084 
 
2085 
try
2086 
gfc_check_size (gfc_expr * array, gfc_expr * dim)
2087 
{
2088 
  if (array_check (array, 0) == FAILURE)
2089 
    return FAILURE;
2090 
 
2091 
  if (dim != NULL)
2092 
    {
2093 
      if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2094 
        return FAILURE;
2095 
 
2096 
      if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2097 
        return FAILURE;
2098 
 
2099 
      if (dim_rank_check (dim, array, 0) == FAILURE)
2100 
        return FAILURE;
2101 
    }
2102 
 
2103 
  return SUCCESS;
2104 
}
2105 
 
2106 
 
2107 
try
2108 
gfc_check_sleep_sub (gfc_expr * seconds)
2109 
{
2110 
  if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2111 
    return FAILURE;
2112 
 
2113 
  if (scalar_check (seconds, 0) == FAILURE)
2114 
    return FAILURE;
2115 
 
2116 
  return SUCCESS;
2117 
}
2118 
 
2119 
 
2120 
try
2121 
gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
2122 
{
2123 
  if (source->rank >= GFC_MAX_DIMENSIONS)
2124 
    {
2125 
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2126 
                 "than rank %d", gfc_current_intrinsic_arg[0],
2127 
                 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2128 
 
2129 
      return FAILURE;
2130 
    }
2131 
 
2132 
  if (dim_check (dim, 1, 0) == FAILURE)
2133 
    return FAILURE;
2134 
 
2135 
  if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2136 
    return FAILURE;
2137 
 
2138 
  if (scalar_check (ncopies, 2) == FAILURE)
2139 
    return FAILURE;
2140 
 
2141 
  return SUCCESS;
2142 
}
2143 
 
2144 
 
2145 
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2146 
   functions).  */
2147 
try
2148 
gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
2149 
{
2150 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2151 
    return FAILURE;
2152 
 
2153 
  if (scalar_check (unit, 0) == FAILURE)
2154 
    return FAILURE;
2155 
 
2156 
  if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2157 
    return FAILURE;
2158 
 
2159 
  if (status == NULL)
2160 
    return SUCCESS;
2161 
 
2162 
  if (type_check (status, 2, BT_INTEGER) == FAILURE
2163 
      || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2164 
      || scalar_check (status, 2) == FAILURE)
2165 
    return FAILURE;
2166 
 
2167 
  return SUCCESS;
2168 
}
2169 
 
2170 
 
2171 
try
2172 
gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
2173 
{
2174 
  return gfc_check_fgetputc_sub (unit, c, NULL);
2175 
}
2176 
 
2177 
 
2178 
try
2179 
gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
2180 
{
2181 
  if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2182 
    return FAILURE;
2183 
 
2184 
  if (status == NULL)
2185 
    return SUCCESS;
2186 
 
2187 
  if (type_check (status, 1, BT_INTEGER) == FAILURE
2188 
      || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2189 
      || scalar_check (status, 1) == FAILURE)
2190 
    return FAILURE;
2191 
 
2192 
  return SUCCESS;
2193 
}
2194 
 
2195 
 
2196 
try
2197 
gfc_check_fgetput (gfc_expr * c)
2198 
{
2199 
  return gfc_check_fgetput_sub (c, NULL);
2200 
}
2201 
 
2202 
 
2203 
try
2204 
gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2205 
{
2206 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2207 
    return FAILURE;
2208 
 
2209 
  if (scalar_check (unit, 0) == FAILURE)
2210 
    return FAILURE;
2211 
 
2212 
  if (type_check (array, 1, BT_INTEGER) == FAILURE
2213 
      || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2214 
    return FAILURE;
2215 
 
2216 
  if (array_check (array, 1) == FAILURE)
2217 
    return FAILURE;
2218 
 
2219 
  return SUCCESS;
2220 
}
2221 
 
2222 
 
2223 
try
2224 
gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2225 
{
2226 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2227 
    return FAILURE;
2228 
 
2229 
  if (scalar_check (unit, 0) == FAILURE)
2230 
    return FAILURE;
2231 
 
2232 
  if (type_check (array, 1, BT_INTEGER) == FAILURE
2233 
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2234 
    return FAILURE;
2235 
 
2236 
  if (array_check (array, 1) == FAILURE)
2237 
    return FAILURE;
2238 
 
2239 
  if (status == NULL)
2240 
    return SUCCESS;
2241 
 
2242 
  if (type_check (status, 2, BT_INTEGER) == FAILURE
2243 
      || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2244 
    return FAILURE;
2245 
 
2246 
  if (scalar_check (status, 2) == FAILURE)
2247 
    return FAILURE;
2248 
 
2249 
  return SUCCESS;
2250 
}
2251 
 
2252 
 
2253 
try
2254 
gfc_check_ftell (gfc_expr * unit)
2255 
{
2256 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2257 
    return FAILURE;
2258 
 
2259 
  if (scalar_check (unit, 0) == FAILURE)
2260 
    return FAILURE;
2261 
 
2262 
  return SUCCESS;
2263 
}
2264 
 
2265 
 
2266 
try
2267 
gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
2268 
{
2269 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2270 
    return FAILURE;
2271 
 
2272 
  if (scalar_check (unit, 0) == FAILURE)
2273 
    return FAILURE;
2274 
 
2275 
  if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2276 
    return FAILURE;
2277 
 
2278 
  if (scalar_check (offset, 1) == FAILURE)
2279 
    return FAILURE;
2280 
 
2281 
  return SUCCESS;
2282 
}
2283 
 
2284 
 
2285 
try
2286 
gfc_check_stat (gfc_expr * name, gfc_expr * array)
2287 
{
2288 
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2289 
    return FAILURE;
2290 
 
2291 
  if (type_check (array, 1, BT_INTEGER) == FAILURE
2292 
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2293 
    return FAILURE;
2294 
 
2295 
  if (array_check (array, 1) == FAILURE)
2296 
    return FAILURE;
2297 
 
2298 
  return SUCCESS;
2299 
}
2300 
 
2301 
 
2302 
try
2303 
gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2304 
{
2305 
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2306 
    return FAILURE;
2307 
 
2308 
  if (type_check (array, 1, BT_INTEGER) == FAILURE
2309 
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2310 
    return FAILURE;
2311 
 
2312 
  if (array_check (array, 1) == FAILURE)
2313 
    return FAILURE;
2314 
 
2315 
  if (status == NULL)
2316 
    return SUCCESS;
2317 
 
2318 
  if (type_check (status, 2, BT_INTEGER) == FAILURE
2319 
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2320 
    return FAILURE;
2321 
 
2322 
  if (scalar_check (status, 2) == FAILURE)
2323 
    return FAILURE;
2324 
 
2325 
  return SUCCESS;
2326 
}
2327 
 
2328 
 
2329 
try
2330 
gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2331 
                    gfc_expr * mold ATTRIBUTE_UNUSED,
2332 
                    gfc_expr * size)
2333 
{
2334 
  if (size != NULL)
2335 
    {
2336 
      if (type_check (size, 2, BT_INTEGER) == FAILURE)
2337 
        return FAILURE;
2338 
 
2339 
      if (scalar_check (size, 2) == FAILURE)
2340 
        return FAILURE;
2341 
 
2342 
      if (nonoptional_check (size, 2) == FAILURE)
2343 
        return FAILURE;
2344 
    }
2345 
 
2346 
  return SUCCESS;
2347 
}
2348 
 
2349 
 
2350 
try
2351 
gfc_check_transpose (gfc_expr * matrix)
2352 
{
2353 
  if (rank_check (matrix, 0, 2) == FAILURE)
2354 
    return FAILURE;
2355 
 
2356 
  return SUCCESS;
2357 
}
2358 
 
2359 
 
2360 
try
2361 
gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2362 
{
2363 
  if (array_check (array, 0) == FAILURE)
2364 
    return FAILURE;
2365 
 
2366 
  if (dim != NULL)
2367 
    {
2368 
      if (dim_check (dim, 1, 1) == FAILURE)
2369 
        return FAILURE;
2370 
 
2371 
      if (dim_rank_check (dim, array, 0) == FAILURE)
2372 
        return FAILURE;
2373 
    }
2374 
 
2375 
  return SUCCESS;
2376 
}
2377 
 
2378 
 
2379 
try
2380 
gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2381 
{
2382 
  if (rank_check (vector, 0, 1) == FAILURE)
2383 
    return FAILURE;
2384 
 
2385 
  if (array_check (mask, 1) == FAILURE)
2386 
    return FAILURE;
2387 
 
2388 
  if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2389 
    return FAILURE;
2390 
 
2391 
  if (same_type_check (vector, 0, field, 2) == FAILURE)
2392 
    return FAILURE;
2393 
 
2394 
  return SUCCESS;
2395 
}
2396 
 
2397 
 
2398 
try
2399 
gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2400 
{
2401 
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2402 
    return FAILURE;
2403 
 
2404 
  if (same_type_check (x, 0, y, 1) == FAILURE)
2405 
    return FAILURE;
2406 
 
2407 
  if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2408 
    return FAILURE;
2409 
 
2410 
  return SUCCESS;
2411 
}
2412 
 
2413 
 
2414 
try
2415 
gfc_check_trim (gfc_expr * x)
2416 
{
2417 
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2418 
    return FAILURE;
2419 
 
2420 
  if (scalar_check (x, 0) == FAILURE)
2421 
    return FAILURE;
2422 
 
2423 
   return SUCCESS;
2424 
}
2425 
 
2426 
 
2427 
try
2428 
gfc_check_ttynam (gfc_expr * unit)
2429 
{
2430 
  if (scalar_check (unit, 0) == FAILURE)
2431 
    return FAILURE;
2432 
 
2433 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2434 
    return FAILURE;
2435 
 
2436 
  return SUCCESS;
2437 
}
2438 
 
2439 
 
2440 
/* Common check function for the half a dozen intrinsics that have a
2441 
   single real argument.  */
2442 
 
2443 
try
2444 
gfc_check_x (gfc_expr * x)
2445 
{
2446 
  if (type_check (x, 0, BT_REAL) == FAILURE)
2447 
    return FAILURE;
2448 
 
2449 
  return SUCCESS;
2450 
}
2451 
 
2452 
 
2453 
/************* Check functions for intrinsic subroutines *************/
2454 
 
2455 
try
2456 
gfc_check_cpu_time (gfc_expr * time)
2457 
{
2458 
  if (scalar_check (time, 0) == FAILURE)
2459 
    return FAILURE;
2460 
 
2461 
  if (type_check (time, 0, BT_REAL) == FAILURE)
2462 
    return FAILURE;
2463 
 
2464 
  if (variable_check (time, 0) == FAILURE)
2465 
    return FAILURE;
2466 
 
2467 
  return SUCCESS;
2468 
}
2469 
 
2470 
 
2471 
try
2472 
gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2473 
                         gfc_expr * zone, gfc_expr * values)
2474 
{
2475 
  if (date != NULL)
2476 
    {
2477 
      if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2478 
        return FAILURE;
2479 
      if (scalar_check (date, 0) == FAILURE)
2480 
        return FAILURE;
2481 
      if (variable_check (date, 0) == FAILURE)
2482 
        return FAILURE;
2483 
    }
2484 
 
2485 
  if (time != NULL)
2486 
    {
2487 
      if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2488 
        return FAILURE;
2489 
      if (scalar_check (time, 1) == FAILURE)
2490 
        return FAILURE;
2491 
      if (variable_check (time, 1) == FAILURE)
2492 
        return FAILURE;
2493 
    }
2494 
 
2495 
  if (zone != NULL)
2496 
    {
2497 
      if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2498 
        return FAILURE;
2499 
      if (scalar_check (zone, 2) == FAILURE)
2500 
        return FAILURE;
2501 
      if (variable_check (zone, 2) == FAILURE)
2502 
        return FAILURE;
2503 
    }
2504 
 
2505 
  if (values != NULL)
2506 
    {
2507 
      if (type_check (values, 3, BT_INTEGER) == FAILURE)
2508 
        return FAILURE;
2509 
      if (array_check (values, 3) == FAILURE)
2510 
        return FAILURE;
2511 
      if (rank_check (values, 3, 1) == FAILURE)
2512 
        return FAILURE;
2513 
      if (variable_check (values, 3) == FAILURE)
2514 
        return FAILURE;
2515 
    }
2516 
 
2517 
  return SUCCESS;
2518 
}
2519 
 
2520 
 
2521 
try
2522 
gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2523 
                  gfc_expr * to, gfc_expr * topos)
2524 
{
2525 
  if (type_check (from, 0, BT_INTEGER) == FAILURE)
2526 
    return FAILURE;
2527 
 
2528 
  if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2529 
    return FAILURE;
2530 
 
2531 
  if (type_check (len, 2, BT_INTEGER) == FAILURE)
2532 
    return FAILURE;
2533 
 
2534 
  if (same_type_check (from, 0, to, 3) == FAILURE)
2535 
    return FAILURE;
2536 
 
2537 
  if (variable_check (to, 3) == FAILURE)
2538 
    return FAILURE;
2539 
 
2540 
  if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2541 
    return FAILURE;
2542 
 
2543 
  return SUCCESS;
2544 
}
2545 
 
2546 
 
2547 
try
2548 
gfc_check_random_number (gfc_expr * harvest)
2549 
{
2550 
  if (type_check (harvest, 0, BT_REAL) == FAILURE)
2551 
    return FAILURE;
2552 
 
2553 
  if (variable_check (harvest, 0) == FAILURE)
2554 
    return FAILURE;
2555 
 
2556 
  return SUCCESS;
2557 
}
2558 
 
2559 
 
2560 
try
2561 
gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2562 
{
2563 
  if (size != NULL)
2564 
    {
2565 
      if (scalar_check (size, 0) == FAILURE)
2566 
        return FAILURE;
2567 
 
2568 
      if (type_check (size, 0, BT_INTEGER) == FAILURE)
2569 
        return FAILURE;
2570 
 
2571 
      if (variable_check (size, 0) == FAILURE)
2572 
        return FAILURE;
2573 
 
2574 
      if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2575 
        return FAILURE;
2576 
    }
2577 
 
2578 
  if (put != NULL)
2579 
    {
2580 
 
2581 
      if (size != NULL)
2582 
        gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2583 
                    &put->where);
2584 
 
2585 
      if (array_check (put, 1) == FAILURE)
2586 
        return FAILURE;
2587 
 
2588 
      if (rank_check (put, 1, 1) == FAILURE)
2589 
        return FAILURE;
2590 
 
2591 
      if (type_check (put, 1, BT_INTEGER) == FAILURE)
2592 
        return FAILURE;
2593 
 
2594 
      if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2595 
        return FAILURE;
2596 
    }
2597 
 
2598 
  if (get != NULL)
2599 
    {
2600 
 
2601 
      if (size != NULL || put != NULL)
2602 
        gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2603 
                    &get->where);
2604 
 
2605 
      if (array_check (get, 2) == FAILURE)
2606 
        return FAILURE;
2607 
 
2608 
      if (rank_check (get, 2, 1) == FAILURE)
2609 
        return FAILURE;
2610 
 
2611 
      if (type_check (get, 2, BT_INTEGER) == FAILURE)
2612 
        return FAILURE;
2613 
 
2614 
      if (variable_check (get, 2) == FAILURE)
2615 
        return FAILURE;
2616 
 
2617 
      if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2618 
        return FAILURE;
2619 
    }
2620 
 
2621 
  return SUCCESS;
2622 
}
2623 
 
2624 
try
2625 
gfc_check_second_sub (gfc_expr * time)
2626 
{
2627 
  if (scalar_check (time, 0) == FAILURE)
2628 
    return FAILURE;
2629 
 
2630 
  if (type_check (time, 0, BT_REAL) == FAILURE)
2631 
    return FAILURE;
2632 
 
2633 
  if (kind_value_check(time, 0, 4) == FAILURE)
2634 
    return FAILURE;
2635 
 
2636 
  return SUCCESS;
2637 
}
2638 
 
2639 
 
2640 
/* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2641 
   count, count_rate, and count_max are all optional arguments */
2642 
 
2643 
try
2644 
gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2645 
                        gfc_expr * count_max)
2646 
{
2647 
  if (count != NULL)
2648 
    {
2649 
      if (scalar_check (count, 0) == FAILURE)
2650 
        return FAILURE;
2651 
 
2652 
      if (type_check (count, 0, BT_INTEGER) == FAILURE)
2653 
        return FAILURE;
2654 
 
2655 
      if (variable_check (count, 0) == FAILURE)
2656 
        return FAILURE;
2657 
    }
2658 
 
2659 
  if (count_rate != NULL)
2660 
    {
2661 
      if (scalar_check (count_rate, 1) == FAILURE)
2662 
        return FAILURE;
2663 
 
2664 
      if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2665 
        return FAILURE;
2666 
 
2667 
      if (variable_check (count_rate, 1) == FAILURE)
2668 
        return FAILURE;
2669 
 
2670 
      if (count != NULL
2671 
          && same_type_check (count, 0, count_rate, 1) == FAILURE)
2672 
        return FAILURE;
2673 
 
2674 
    }
2675 
 
2676 
  if (count_max != NULL)
2677 
    {
2678 
      if (scalar_check (count_max, 2) == FAILURE)
2679 
        return FAILURE;
2680 
 
2681 
      if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2682 
        return FAILURE;
2683 
 
2684 
      if (variable_check (count_max, 2) == FAILURE)
2685 
        return FAILURE;
2686 
 
2687 
      if (count != NULL
2688 
          && same_type_check (count, 0, count_max, 2) == FAILURE)
2689 
        return FAILURE;
2690 
 
2691 
      if (count_rate != NULL
2692 
          && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2693 
        return FAILURE;
2694 
    }
2695 
 
2696 
  return SUCCESS;
2697 
}
2698 
 
2699 
try
2700 
gfc_check_irand (gfc_expr * x)
2701 
{
2702 
  if (x == NULL)
2703 
    return SUCCESS;
2704 
 
2705 
  if (scalar_check (x, 0) == FAILURE)
2706 
    return FAILURE;
2707 
 
2708 
  if (type_check (x, 0, BT_INTEGER) == FAILURE)
2709 
    return FAILURE;
2710 
 
2711 
  if (kind_value_check(x, 0, 4) == FAILURE)
2712 
    return FAILURE;
2713 
 
2714 
  return SUCCESS;
2715 
}
2716 
 
2717 
 
2718 
try
2719 
gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2720 
{
2721 
  if (scalar_check (seconds, 0) == FAILURE)
2722 
    return FAILURE;
2723 
 
2724 
  if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2725 
    return FAILURE;
2726 
 
2727 
  if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2728 
    {
2729 
      gfc_error (
2730 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2731 
        gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2732 
      return FAILURE;
2733 
    }
2734 
 
2735 
  if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2736 
    return FAILURE;
2737 
 
2738 
  if (status == NULL)
2739 
    return SUCCESS;
2740 
 
2741 
  if (scalar_check (status, 2) == FAILURE)
2742 
    return FAILURE;
2743 
 
2744 
  if (type_check (status, 2, BT_INTEGER) == FAILURE)
2745 
    return FAILURE;
2746 
 
2747 
  return SUCCESS;
2748 
}
2749 
 
2750 
 
2751 
try
2752 
gfc_check_rand (gfc_expr * x)
2753 
{
2754 
  if (x == NULL)
2755 
    return SUCCESS;
2756 
 
2757 
  if (scalar_check (x, 0) == FAILURE)
2758 
    return FAILURE;
2759 
 
2760 
  if (type_check (x, 0, BT_INTEGER) == FAILURE)
2761 
    return FAILURE;
2762 
 
2763 
  if (kind_value_check(x, 0, 4) == FAILURE)
2764 
    return FAILURE;
2765 
 
2766 
  return SUCCESS;
2767 
}
2768 
 
2769 
try
2770 
gfc_check_srand (gfc_expr * x)
2771 
{
2772 
  if (scalar_check (x, 0) == FAILURE)
2773 
    return FAILURE;
2774 
 
2775 
  if (type_check (x, 0, BT_INTEGER) == FAILURE)
2776 
    return FAILURE;
2777 
 
2778 
  if (kind_value_check(x, 0, 4) == FAILURE)
2779 
    return FAILURE;
2780 
 
2781 
  return SUCCESS;
2782 
}
2783 
 
2784 
try
2785 
gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
2786 
{
2787 
  if (scalar_check (time, 0) == FAILURE)
2788 
    return FAILURE;
2789 
 
2790 
  if (type_check (time, 0, BT_INTEGER) == FAILURE)
2791 
    return FAILURE;
2792 
 
2793 
  if (type_check (result, 1, BT_CHARACTER) == FAILURE)
2794 
    return FAILURE;
2795 
 
2796 
  return SUCCESS;
2797 
}
2798 
 
2799 
try
2800 
gfc_check_etime (gfc_expr * x)
2801 
{
2802 
  if (array_check (x, 0) == FAILURE)
2803 
    return FAILURE;
2804 
 
2805 
  if (rank_check (x, 0, 1) == FAILURE)
2806 
    return FAILURE;
2807 
 
2808 
  if (variable_check (x, 0) == FAILURE)
2809 
    return FAILURE;
2810 
 
2811 
  if (type_check (x, 0, BT_REAL) == FAILURE)
2812 
    return FAILURE;
2813 
 
2814 
  if (kind_value_check(x, 0, 4) == FAILURE)
2815 
    return FAILURE;
2816 
 
2817 
  return SUCCESS;
2818 
}
2819 
 
2820 
try
2821 
gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2822 
{
2823 
  if (array_check (values, 0) == FAILURE)
2824 
    return FAILURE;
2825 
 
2826 
  if (rank_check (values, 0, 1) == FAILURE)
2827 
    return FAILURE;
2828 
 
2829 
  if (variable_check (values, 0) == FAILURE)
2830 
    return FAILURE;
2831 
 
2832 
  if (type_check (values, 0, BT_REAL) == FAILURE)
2833 
    return FAILURE;
2834 
 
2835 
  if (kind_value_check(values, 0, 4) == FAILURE)
2836 
    return FAILURE;
2837 
 
2838 
  if (scalar_check (time, 1) == FAILURE)
2839 
    return FAILURE;
2840 
 
2841 
  if (type_check (time, 1, BT_REAL) == FAILURE)
2842 
    return FAILURE;
2843 
 
2844 
  if (kind_value_check(time, 1, 4) == FAILURE)
2845 
    return FAILURE;
2846 
 
2847 
  return SUCCESS;
2848 
}
2849 
 
2850 
 
2851 
try
2852 
gfc_check_fdate_sub (gfc_expr * date)
2853 
{
2854 
  if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2855 
    return FAILURE;
2856 
 
2857 
  return SUCCESS;
2858 
}
2859 
 
2860 
 
2861 
try
2862 
gfc_check_gerror (gfc_expr * msg)
2863 
{
2864 
  if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2865 
    return FAILURE;
2866 
 
2867 
  return SUCCESS;
2868 
}
2869 
 
2870 
 
2871 
try
2872 
gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2873 
{
2874 
  if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2875 
    return FAILURE;
2876 
 
2877 
  if (status == NULL)
2878 
    return SUCCESS;
2879 
 
2880 
  if (scalar_check (status, 1) == FAILURE)
2881 
    return FAILURE;
2882 
 
2883 
  if (type_check (status, 1, BT_INTEGER) == FAILURE)
2884 
    return FAILURE;
2885 
 
2886 
  return SUCCESS;
2887 
}
2888 
 
2889 
 
2890 
try
2891 
gfc_check_getlog (gfc_expr * msg)
2892 
{
2893 
  if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2894 
    return FAILURE;
2895 
 
2896 
  return SUCCESS;
2897 
}
2898 
 
2899 
 
2900 
try
2901 
gfc_check_exit (gfc_expr * status)
2902 
{
2903 
  if (status == NULL)
2904 
    return SUCCESS;
2905 
 
2906 
  if (type_check (status, 0, BT_INTEGER) == FAILURE)
2907 
    return FAILURE;
2908 
 
2909 
  if (scalar_check (status, 0) == FAILURE)
2910 
    return FAILURE;
2911 
 
2912 
  return SUCCESS;
2913 
}
2914 
 
2915 
 
2916 
try
2917 
gfc_check_flush (gfc_expr * unit)
2918 
{
2919 
  if (unit == NULL)
2920 
    return SUCCESS;
2921 
 
2922 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2923 
    return FAILURE;
2924 
 
2925 
  if (scalar_check (unit, 0) == FAILURE)
2926 
    return FAILURE;
2927 
 
2928 
  return SUCCESS;
2929 
}
2930 
 
2931 
 
2932 
try
2933 
gfc_check_free (gfc_expr * i)
2934 
{
2935 
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
2936 
    return FAILURE;
2937 
 
2938 
  if (scalar_check (i, 0) == FAILURE)
2939 
    return FAILURE;
2940 
 
2941 
  return SUCCESS;
2942 
}
2943 
 
2944 
 
2945 
try
2946 
gfc_check_hostnm (gfc_expr * name)
2947 
{
2948 
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2949 
    return FAILURE;
2950 
 
2951 
  return SUCCESS;
2952 
}
2953 
 
2954 
 
2955 
try
2956 
gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
2957 
{
2958 
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2959 
    return FAILURE;
2960 
 
2961 
  if (status == NULL)
2962 
    return SUCCESS;
2963 
 
2964 
  if (scalar_check (status, 1) == FAILURE)
2965 
    return FAILURE;
2966 
 
2967 
  if (type_check (status, 1, BT_INTEGER) == FAILURE)
2968 
    return FAILURE;
2969 
 
2970 
  return SUCCESS;
2971 
}
2972 
 
2973 
 
2974 
try
2975 
gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
2976 
{
2977 
  if (scalar_check (unit, 0) == FAILURE)
2978 
    return FAILURE;
2979 
 
2980 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2981 
    return FAILURE;
2982 
 
2983 
  if (type_check (name, 1, BT_CHARACTER) == FAILURE)
2984 
    return FAILURE;
2985 
 
2986 
  return SUCCESS;
2987 
}
2988 
 
2989 
 
2990 
try
2991 
gfc_check_isatty (gfc_expr * unit)
2992 
{
2993 
  if (unit == NULL)
2994 
    return FAILURE;
2995 
 
2996 
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2997 
    return FAILURE;
2998 
 
2999 
  if (scalar_check (unit, 0) == FAILURE)
3000 
    return FAILURE;
3001 
 
3002 
  return SUCCESS;
3003 
}
3004 
 
3005 
 
3006 
try
3007 
gfc_check_perror (gfc_expr * string)
3008 
{
3009 
  if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3010 
    return FAILURE;
3011 
 
3012 
  return SUCCESS;
3013 
}
3014 
 
3015 
 
3016 
try
3017 
gfc_check_umask (gfc_expr * mask)
3018 
{
3019 
  if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3020 
    return FAILURE;
3021 
 
3022 
  if (scalar_check (mask, 0) == FAILURE)
3023 
    return FAILURE;
3024 
 
3025 
  return SUCCESS;
3026 
}
3027 
 
3028 
 
3029 
try
3030 
gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
3031 
{
3032 
  if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3033 
    return FAILURE;
3034 
 
3035 
  if (scalar_check (mask, 0) == FAILURE)
3036 
    return FAILURE;
3037 
 
3038 
  if (old == NULL)
3039 
    return SUCCESS;
3040 
 
3041 
  if (scalar_check (old, 1) == FAILURE)
3042 
    return FAILURE;
3043 
 
3044 
  if (type_check (old, 1, BT_INTEGER) == FAILURE)
3045 
    return FAILURE;
3046 
 
3047 
  return SUCCESS;
3048 
}
3049 
 
3050 
 
3051 
try
3052 
gfc_check_unlink (gfc_expr * name)
3053 
{
3054 
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3055 
    return FAILURE;
3056 
 
3057 
  return SUCCESS;
3058 
}
3059 
 
3060 
 
3061 
try
3062 
gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
3063 
{
3064 
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3065 
    return FAILURE;
3066 
 
3067 
  if (status == NULL)
3068 
    return SUCCESS;
3069 
 
3070 
  if (scalar_check (status, 1) == FAILURE)
3071 
    return FAILURE;
3072 
 
3073 
  if (type_check (status, 1, BT_INTEGER) == FAILURE)
3074 
    return FAILURE;
3075 
 
3076 
  return SUCCESS;
3077 
}
3078 
 
3079 
 
3080 
try
3081 
gfc_check_signal (gfc_expr * number, gfc_expr * handler)
3082 
{
3083 
  if (scalar_check (number, 0) == FAILURE)
3084 
    return FAILURE;
3085 
 
3086 
  if (type_check (number, 0, BT_INTEGER) == FAILURE)
3087 
    return FAILURE;
3088 
 
3089 
  if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3090 
    {
3091 
      gfc_error (
3092 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3093 
        gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3094 
      return FAILURE;
3095 
    }
3096 
 
3097 
  if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3098 
    return FAILURE;
3099 
 
3100 
  return SUCCESS;
3101 
}
3102 
 
3103 
 
3104 
try
3105 
gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
3106 
{
3107 
  if (scalar_check (number, 0) == FAILURE)
3108 
    return FAILURE;
3109 
 
3110 
  if (type_check (number, 0, BT_INTEGER) == FAILURE)
3111 
    return FAILURE;
3112 
 
3113 
  if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3114 
    {
3115 
      gfc_error (
3116 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3117 
        gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3118 
      return FAILURE;
3119 
    }
3120 
 
3121 
  if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3122 
    return FAILURE;
3123 
 
3124 
  if (status == NULL)
3125 
    return SUCCESS;
3126 
 
3127 
  if (type_check (status, 2, BT_INTEGER) == FAILURE)
3128 
    return FAILURE;
3129 
 
3130 
  if (scalar_check (status, 2) == FAILURE)
3131 
    return FAILURE;
3132 
 
3133 
  return SUCCESS;
3134 
}
3135 
 
3136 
 
3137 
try
3138 
gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
3139 
{
3140 
  if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3141 
    return FAILURE;
3142 
 
3143 
  if (scalar_check (status, 1) == FAILURE)
3144 
    return FAILURE;
3145 
 
3146 
  if (type_check (status, 1, BT_INTEGER) == FAILURE)
3147 
    return FAILURE;
3148 
 
3149 
  if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3150 
    return FAILURE;
3151 
 
3152 
  return SUCCESS;
3153 
}
3154 
 
3155 
 
3156 
/* This is used for the GNU intrinsics AND, OR and XOR.  */
3157 
try
3158 
gfc_check_and (gfc_expr * i, gfc_expr * j)
3159 
{
3160 
  if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3161 
    {
3162 
      gfc_error (
3163 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3164 
        gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
3165 
      return FAILURE;
3166 
    }
3167 
 
3168 
  if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3169 
    {
3170 
      gfc_error (
3171 
        "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3172 
        gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
3173 
      return FAILURE;
3174 
    }
3175 
 
3176 
  if (i->ts.type != j->ts.type)
3177 
    {
3178 
      gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3179 
                 "have the same type", gfc_current_intrinsic_arg[0],
3180 
                 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3181 
                 &j->where);
3182 
      return FAILURE;
3183 
    }
3184 
 
3185 
  if (scalar_check (i, 0) == FAILURE)
3186 
    return FAILURE;
3187 
 
3188 
  if (scalar_check (j, 1) == FAILURE)
3189 
    return FAILURE;
3190 
 
3191 
  return SUCCESS;
3192 
}

powered by: WebSVN 2.1.0

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