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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [check.c] - Blame information for rev 301

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

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

powered by: WebSVN 2.1.0

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