gcc/fortran/check.c

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