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 /*  13.14.82  PRESENT(A)
1871 ......
1872   Argument.  A shall be the name of an optional dummy argument that is accessible
1873   in the subprogram in which the PRESENT function reference appears...  */
1874
1875   if (a->ref != NULL
1876         && !(a->ref->next == NULL
1877                && a->ref->type == REF_ARRAY
1878                && a->ref->u.ar.type == AR_FULL))
1879     {
1880       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-"
1881                  "object of '%s'", gfc_current_intrinsic_arg[0],
1882                  gfc_current_intrinsic, &a->where, sym->name);
1883       return FAILURE;
1884     }
1885
1886   return SUCCESS;
1887 }
1888
1889
1890 try
1891 gfc_check_radix (gfc_expr * x)
1892 {
1893   if (int_or_real_check (x, 0) == FAILURE)
1894     return FAILURE;
1895
1896   return SUCCESS;
1897 }
1898
1899
1900 try
1901 gfc_check_range (gfc_expr * x)
1902 {
1903   if (numeric_check (x, 0) == FAILURE)
1904     return FAILURE;
1905
1906   return SUCCESS;
1907 }
1908
1909
1910 /* real, float, sngl.  */
1911 try
1912 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1913 {
1914   if (numeric_check (a, 0) == FAILURE)
1915     return FAILURE;
1916
1917   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1918     return FAILURE;
1919
1920   return SUCCESS;
1921 }
1922
1923
1924 try
1925 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
1926 {
1927   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1928     return FAILURE;
1929
1930   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1931     return FAILURE;
1932
1933   return SUCCESS;
1934 }
1935
1936
1937 try
1938 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1939 {
1940   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1941     return FAILURE;
1942
1943   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1944     return FAILURE;
1945
1946   if (status == NULL)
1947     return SUCCESS;
1948
1949   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1950     return FAILURE;
1951
1952   if (scalar_check (status, 2) == FAILURE)
1953     return FAILURE;
1954
1955   return SUCCESS;
1956 }
1957
1958
1959 try
1960 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1961 {
1962   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1963     return FAILURE;
1964
1965   if (scalar_check (x, 0) == FAILURE)
1966     return FAILURE;
1967
1968   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1969     return FAILURE;
1970
1971   if (scalar_check (y, 1) == FAILURE)
1972     return FAILURE;
1973
1974   return SUCCESS;
1975 }
1976
1977
1978 try
1979 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1980                    gfc_expr * pad, gfc_expr * order)
1981 {
1982   mpz_t size;
1983   int m;
1984
1985   if (array_check (source, 0) == FAILURE)
1986     return FAILURE;
1987
1988   if (rank_check (shape, 1, 1) == FAILURE)
1989     return FAILURE;
1990
1991   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1992     return FAILURE;
1993
1994   if (gfc_array_size (shape, &size) != SUCCESS)
1995     {
1996       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1997                  "array of constant size", &shape->where);
1998       return FAILURE;
1999     }
2000
2001   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2002   mpz_clear (size);
2003
2004   if (m > 0)
2005     {
2006       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2007                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2008       return FAILURE;
2009     }
2010
2011   if (pad != NULL)
2012     {
2013       if (same_type_check (source, 0, pad, 2) == FAILURE)
2014         return FAILURE;
2015       if (array_check (pad, 2) == FAILURE)
2016         return FAILURE;
2017     }
2018
2019   if (order != NULL && array_check (order, 3) == FAILURE)
2020     return FAILURE;
2021
2022   return SUCCESS;
2023 }
2024
2025
2026 try
2027 gfc_check_scale (gfc_expr * x, gfc_expr * i)
2028 {
2029   if (type_check (x, 0, BT_REAL) == FAILURE)
2030     return FAILURE;
2031
2032   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2033     return FAILURE;
2034
2035   return SUCCESS;
2036 }
2037
2038
2039 try
2040 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2041 {
2042   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2043     return FAILURE;
2044
2045   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2046     return FAILURE;
2047
2048   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2049     return FAILURE;
2050
2051   if (same_type_check (x, 0, y, 1) == FAILURE)
2052     return FAILURE;
2053
2054   return SUCCESS;
2055 }
2056
2057
2058 try
2059 gfc_check_secnds (gfc_expr * r)
2060 {
2061
2062   if (type_check (r, 0, BT_REAL) == FAILURE)
2063     return FAILURE;
2064
2065   if (kind_value_check (r, 0, 4) == FAILURE)
2066     return FAILURE;
2067
2068   if (scalar_check (r, 0) == FAILURE)
2069     return FAILURE;
2070
2071   return SUCCESS;
2072 }
2073
2074
2075 try
2076 gfc_check_selected_int_kind (gfc_expr * r)
2077 {
2078
2079   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2080     return FAILURE;
2081
2082   if (scalar_check (r, 0) == FAILURE)
2083     return FAILURE;
2084
2085   return SUCCESS;
2086 }
2087
2088
2089 try
2090 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
2091 {
2092   if (p == NULL && r == NULL)
2093     {
2094       gfc_error ("Missing arguments to %s intrinsic at %L",
2095                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2096
2097       return FAILURE;
2098     }
2099
2100   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2101     return FAILURE;
2102
2103   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2104     return FAILURE;
2105
2106   return SUCCESS;
2107 }
2108
2109
2110 try
2111 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
2112 {
2113   if (type_check (x, 0, BT_REAL) == FAILURE)
2114     return FAILURE;
2115
2116   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2117     return FAILURE;
2118
2119   return SUCCESS;
2120 }
2121
2122
2123 try
2124 gfc_check_shape (gfc_expr * source)
2125 {
2126   gfc_array_ref *ar;
2127
2128   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2129     return SUCCESS;
2130
2131   ar = gfc_find_array_ref (source);
2132
2133   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2134     {
2135       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2136                  "an assumed size array", &source->where);
2137       return FAILURE;
2138     }
2139
2140   return SUCCESS;
2141 }
2142
2143
2144 try
2145 gfc_check_sign (gfc_expr * a, gfc_expr * b)
2146 {
2147   if (int_or_real_check (a, 0) == FAILURE)
2148     return FAILURE;
2149
2150   if (same_type_check (a, 0, b, 1) == FAILURE)
2151     return FAILURE;
2152
2153   return SUCCESS;
2154 }
2155
2156
2157 try
2158 gfc_check_size (gfc_expr * array, gfc_expr * dim)
2159 {
2160   if (array_check (array, 0) == FAILURE)
2161     return FAILURE;
2162
2163   if (dim != NULL)
2164     {
2165       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2166         return FAILURE;
2167
2168       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2169         return FAILURE;
2170
2171       if (dim_rank_check (dim, array, 0) == FAILURE)
2172         return FAILURE;
2173     }
2174
2175   return SUCCESS;
2176 }
2177
2178
2179 try
2180 gfc_check_sleep_sub (gfc_expr * seconds)
2181 {
2182   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2183     return FAILURE;
2184
2185   if (scalar_check (seconds, 0) == FAILURE)
2186     return FAILURE;
2187
2188   return SUCCESS;
2189 }
2190
2191
2192 try
2193 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
2194 {
2195   if (source->rank >= GFC_MAX_DIMENSIONS)
2196     {
2197       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2198                  "than rank %d", gfc_current_intrinsic_arg[0],
2199                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2200
2201       return FAILURE;
2202     }
2203
2204   if (dim_check (dim, 1, 0) == FAILURE)
2205     return FAILURE;
2206
2207   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2208     return FAILURE;
2209
2210   if (scalar_check (ncopies, 2) == FAILURE)
2211     return FAILURE;
2212
2213   if (gfc_init_expr)
2214     return non_init_transformational ();
2215
2216   return SUCCESS;
2217 }
2218
2219
2220 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2221    functions).  */
2222 try
2223 gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
2224 {
2225   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2226     return FAILURE;
2227
2228   if (scalar_check (unit, 0) == FAILURE)
2229     return FAILURE;
2230
2231   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2232     return FAILURE;
2233
2234   if (status == NULL)
2235     return SUCCESS;
2236
2237   if (type_check (status, 2, BT_INTEGER) == FAILURE
2238       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2239       || scalar_check (status, 2) == FAILURE)
2240     return FAILURE;
2241
2242   return SUCCESS;
2243 }
2244
2245
2246 try
2247 gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
2248 {
2249   return gfc_check_fgetputc_sub (unit, c, NULL);
2250 }
2251
2252
2253 try
2254 gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
2255 {
2256   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2257     return FAILURE;
2258
2259   if (status == NULL)
2260     return SUCCESS;
2261
2262   if (type_check (status, 1, BT_INTEGER) == FAILURE
2263       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2264       || scalar_check (status, 1) == FAILURE)
2265     return FAILURE;
2266
2267   return SUCCESS;
2268 }
2269
2270
2271 try
2272 gfc_check_fgetput (gfc_expr * c)
2273 {
2274   return gfc_check_fgetput_sub (c, NULL);
2275 }
2276
2277
2278 try
2279 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2280 {
2281   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2282     return FAILURE;
2283
2284   if (scalar_check (unit, 0) == FAILURE)
2285     return FAILURE;
2286
2287   if (type_check (array, 1, BT_INTEGER) == FAILURE
2288       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2289     return FAILURE;
2290
2291   if (array_check (array, 1) == FAILURE)
2292     return FAILURE;
2293
2294   return SUCCESS;
2295 }
2296
2297
2298 try
2299 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2300 {
2301   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2302     return FAILURE;
2303
2304   if (scalar_check (unit, 0) == FAILURE)
2305     return FAILURE;
2306
2307   if (type_check (array, 1, BT_INTEGER) == FAILURE
2308       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2309     return FAILURE;
2310
2311   if (array_check (array, 1) == FAILURE)
2312     return FAILURE;
2313
2314   if (status == NULL)
2315     return SUCCESS;
2316
2317   if (type_check (status, 2, BT_INTEGER) == FAILURE
2318       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2319     return FAILURE;
2320
2321   if (scalar_check (status, 2) == FAILURE)
2322     return FAILURE;
2323
2324   return SUCCESS;
2325 }
2326
2327
2328 try
2329 gfc_check_ftell (gfc_expr * unit)
2330 {
2331   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2332     return FAILURE;
2333
2334   if (scalar_check (unit, 0) == FAILURE)
2335     return FAILURE;
2336
2337   return SUCCESS;
2338 }
2339
2340
2341 try
2342 gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
2343 {
2344   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2345     return FAILURE;
2346
2347   if (scalar_check (unit, 0) == FAILURE)
2348     return FAILURE;
2349
2350   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2351     return FAILURE;
2352
2353   if (scalar_check (offset, 1) == FAILURE)
2354     return FAILURE;
2355
2356   return SUCCESS;
2357 }
2358
2359
2360 try
2361 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2362 {
2363   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2364     return FAILURE;
2365
2366   if (type_check (array, 1, BT_INTEGER) == FAILURE
2367       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2368     return FAILURE;
2369
2370   if (array_check (array, 1) == FAILURE)
2371     return FAILURE;
2372
2373   return SUCCESS;
2374 }
2375
2376
2377 try
2378 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2379 {
2380   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2381     return FAILURE;
2382
2383   if (type_check (array, 1, BT_INTEGER) == FAILURE
2384       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2385     return FAILURE;
2386
2387   if (array_check (array, 1) == FAILURE)
2388     return FAILURE;
2389
2390   if (status == NULL)
2391     return SUCCESS;
2392
2393   if (type_check (status, 2, BT_INTEGER) == FAILURE
2394       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2395     return FAILURE;
2396
2397   if (scalar_check (status, 2) == FAILURE)
2398     return FAILURE;
2399
2400   return SUCCESS;
2401 }
2402
2403
2404 try
2405 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2406                     gfc_expr * mold ATTRIBUTE_UNUSED,
2407                     gfc_expr * size)
2408 {
2409   if (size != NULL)
2410     {
2411       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2412         return FAILURE;
2413
2414       if (scalar_check (size, 2) == FAILURE)
2415         return FAILURE;
2416
2417       if (nonoptional_check (size, 2) == FAILURE)
2418         return FAILURE;
2419     }
2420
2421   return SUCCESS;
2422 }
2423
2424
2425 try
2426 gfc_check_transpose (gfc_expr * matrix)
2427 {
2428   if (rank_check (matrix, 0, 2) == FAILURE)
2429     return FAILURE;
2430
2431   if (gfc_init_expr)
2432     return non_init_transformational ();
2433
2434   return SUCCESS;
2435 }
2436
2437
2438 try
2439 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2440 {
2441   if (array_check (array, 0) == FAILURE)
2442     return FAILURE;
2443
2444   if (dim != NULL)
2445     {
2446       if (dim_check (dim, 1, 1) == FAILURE)
2447         return FAILURE;
2448
2449       if (dim_rank_check (dim, array, 0) == FAILURE)
2450         return FAILURE;
2451     }
2452
2453   return SUCCESS;
2454 }
2455
2456
2457 try
2458 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2459 {
2460   if (rank_check (vector, 0, 1) == FAILURE)
2461     return FAILURE;
2462
2463   if (array_check (mask, 1) == FAILURE)
2464     return FAILURE;
2465
2466   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2467     return FAILURE;
2468
2469   if (same_type_check (vector, 0, field, 2) == FAILURE)
2470     return FAILURE;
2471
2472   if (gfc_init_expr)
2473     return non_init_transformational ();
2474
2475   return SUCCESS;
2476 }
2477
2478
2479 try
2480 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2481 {
2482   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2483     return FAILURE;
2484
2485   if (same_type_check (x, 0, y, 1) == FAILURE)
2486     return FAILURE;
2487
2488   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2489     return FAILURE;
2490
2491   return SUCCESS;
2492 }
2493
2494
2495 try
2496 gfc_check_trim (gfc_expr * x)
2497 {
2498   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2499     return FAILURE;
2500
2501   if (scalar_check (x, 0) == FAILURE)
2502     return FAILURE;
2503
2504    return SUCCESS;
2505 }
2506
2507
2508 try
2509 gfc_check_ttynam (gfc_expr * unit)
2510 {
2511   if (scalar_check (unit, 0) == FAILURE)
2512     return FAILURE;
2513
2514   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2515     return FAILURE;
2516
2517   return SUCCESS;
2518 }
2519
2520
2521 /* Common check function for the half a dozen intrinsics that have a
2522    single real argument.  */
2523
2524 try
2525 gfc_check_x (gfc_expr * x)
2526 {
2527   if (type_check (x, 0, BT_REAL) == FAILURE)
2528     return FAILURE;
2529
2530   return SUCCESS;
2531 }
2532
2533
2534 /************* Check functions for intrinsic subroutines *************/
2535
2536 try
2537 gfc_check_cpu_time (gfc_expr * time)
2538 {
2539   if (scalar_check (time, 0) == FAILURE)
2540     return FAILURE;
2541
2542   if (type_check (time, 0, BT_REAL) == FAILURE)
2543     return FAILURE;
2544
2545   if (variable_check (time, 0) == FAILURE)
2546     return FAILURE;
2547
2548   return SUCCESS;
2549 }
2550
2551
2552 try
2553 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2554                          gfc_expr * zone, gfc_expr * values)
2555 {
2556   if (date != NULL)
2557     {
2558       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2559         return FAILURE;
2560       if (scalar_check (date, 0) == FAILURE)
2561         return FAILURE;
2562       if (variable_check (date, 0) == FAILURE)
2563         return FAILURE;
2564     }
2565
2566   if (time != NULL)
2567     {
2568       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2569         return FAILURE;
2570       if (scalar_check (time, 1) == FAILURE)
2571         return FAILURE;
2572       if (variable_check (time, 1) == FAILURE)
2573         return FAILURE;
2574     }
2575
2576   if (zone != NULL)
2577     {
2578       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2579         return FAILURE;
2580       if (scalar_check (zone, 2) == FAILURE)
2581         return FAILURE;
2582       if (variable_check (zone, 2) == FAILURE)
2583         return FAILURE;
2584     }
2585
2586   if (values != NULL)
2587     {
2588       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2589         return FAILURE;
2590       if (array_check (values, 3) == FAILURE)
2591         return FAILURE;
2592       if (rank_check (values, 3, 1) == FAILURE)
2593         return FAILURE;
2594       if (variable_check (values, 3) == FAILURE)
2595         return FAILURE;
2596     }
2597
2598   return SUCCESS;
2599 }
2600
2601
2602 try
2603 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2604                   gfc_expr * to, gfc_expr * topos)
2605 {
2606   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2607     return FAILURE;
2608
2609   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2610     return FAILURE;
2611
2612   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2613     return FAILURE;
2614
2615   if (same_type_check (from, 0, to, 3) == FAILURE)
2616     return FAILURE;
2617
2618   if (variable_check (to, 3) == FAILURE)
2619     return FAILURE;
2620
2621   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2622     return FAILURE;
2623
2624   return SUCCESS;
2625 }
2626
2627
2628 try
2629 gfc_check_random_number (gfc_expr * harvest)
2630 {
2631   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2632     return FAILURE;
2633
2634   if (variable_check (harvest, 0) == FAILURE)
2635     return FAILURE;
2636
2637   return SUCCESS;
2638 }
2639
2640
2641 try
2642 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2643 {
2644   if (size != NULL)
2645     {
2646       if (scalar_check (size, 0) == FAILURE)
2647         return FAILURE;
2648
2649       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2650         return FAILURE;
2651
2652       if (variable_check (size, 0) == FAILURE)
2653         return FAILURE;
2654
2655       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2656         return FAILURE;
2657     }
2658
2659   if (put != NULL)
2660     {
2661
2662       if (size != NULL)
2663         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2664                     &put->where);
2665
2666       if (array_check (put, 1) == FAILURE)
2667         return FAILURE;
2668
2669       if (rank_check (put, 1, 1) == FAILURE)
2670         return FAILURE;
2671
2672       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2673         return FAILURE;
2674
2675       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2676         return FAILURE;
2677     }
2678
2679   if (get != NULL)
2680     {
2681
2682       if (size != NULL || put != NULL)
2683         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2684                     &get->where);
2685
2686       if (array_check (get, 2) == FAILURE)
2687         return FAILURE;
2688
2689       if (rank_check (get, 2, 1) == FAILURE)
2690         return FAILURE;
2691
2692       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2693         return FAILURE;
2694
2695       if (variable_check (get, 2) == FAILURE)
2696         return FAILURE;
2697
2698       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2699         return FAILURE;
2700     }
2701
2702   return SUCCESS;
2703 }
2704
2705 try
2706 gfc_check_second_sub (gfc_expr * time)
2707 {
2708   if (scalar_check (time, 0) == FAILURE)
2709     return FAILURE;
2710
2711   if (type_check (time, 0, BT_REAL) == FAILURE)
2712     return FAILURE;
2713
2714   if (kind_value_check(time, 0, 4) == FAILURE)
2715     return FAILURE;
2716
2717   return SUCCESS;
2718 }
2719
2720
2721 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2722    count, count_rate, and count_max are all optional arguments */
2723
2724 try
2725 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2726                         gfc_expr * count_max)
2727 {
2728   if (count != NULL)
2729     {
2730       if (scalar_check (count, 0) == FAILURE)
2731         return FAILURE;
2732
2733       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2734         return FAILURE;
2735
2736       if (variable_check (count, 0) == FAILURE)
2737         return FAILURE;
2738     }
2739
2740   if (count_rate != NULL)
2741     {
2742       if (scalar_check (count_rate, 1) == FAILURE)
2743         return FAILURE;
2744
2745       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2746         return FAILURE;
2747
2748       if (variable_check (count_rate, 1) == FAILURE)
2749         return FAILURE;
2750
2751       if (count != NULL
2752           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2753         return FAILURE;
2754
2755     }
2756
2757   if (count_max != NULL)
2758     {
2759       if (scalar_check (count_max, 2) == FAILURE)
2760         return FAILURE;
2761
2762       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2763         return FAILURE;
2764
2765       if (variable_check (count_max, 2) == FAILURE)
2766         return FAILURE;
2767
2768       if (count != NULL
2769           && same_type_check (count, 0, count_max, 2) == FAILURE)
2770         return FAILURE;
2771
2772       if (count_rate != NULL
2773           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2774         return FAILURE;
2775     }
2776
2777   return SUCCESS;
2778 }
2779
2780 try
2781 gfc_check_irand (gfc_expr * x)
2782 {
2783   if (x == NULL)
2784     return SUCCESS;
2785
2786   if (scalar_check (x, 0) == FAILURE)
2787     return FAILURE;
2788
2789   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2790     return FAILURE;
2791
2792   if (kind_value_check(x, 0, 4) == FAILURE)
2793     return FAILURE;
2794
2795   return SUCCESS;
2796 }
2797
2798
2799 try
2800 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2801 {
2802   if (scalar_check (seconds, 0) == FAILURE)
2803     return FAILURE;
2804
2805   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2806     return FAILURE;
2807
2808   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2809     {
2810       gfc_error (
2811         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2812         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2813       return FAILURE;
2814     }
2815
2816   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2817     return FAILURE;
2818
2819   if (status == NULL)
2820     return SUCCESS;
2821
2822   if (scalar_check (status, 2) == FAILURE)
2823     return FAILURE;
2824
2825   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2826     return FAILURE;
2827
2828   return SUCCESS;
2829 }
2830
2831
2832 try
2833 gfc_check_rand (gfc_expr * x)
2834 {
2835   if (x == NULL)
2836     return SUCCESS;
2837
2838   if (scalar_check (x, 0) == FAILURE)
2839     return FAILURE;
2840
2841   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2842     return FAILURE;
2843
2844   if (kind_value_check(x, 0, 4) == FAILURE)
2845     return FAILURE;
2846
2847   return SUCCESS;
2848 }
2849
2850 try
2851 gfc_check_srand (gfc_expr * x)
2852 {
2853   if (scalar_check (x, 0) == FAILURE)
2854     return FAILURE;
2855
2856   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2857     return FAILURE;
2858
2859   if (kind_value_check(x, 0, 4) == FAILURE)
2860     return FAILURE;
2861
2862   return SUCCESS;
2863 }
2864
2865 try
2866 gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
2867 {
2868   if (scalar_check (time, 0) == FAILURE)
2869     return FAILURE;
2870
2871   if (type_check (time, 0, BT_INTEGER) == FAILURE)
2872     return FAILURE;
2873
2874   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
2875     return FAILURE;
2876
2877   return SUCCESS;
2878 }
2879
2880 try
2881 gfc_check_etime (gfc_expr * x)
2882 {
2883   if (array_check (x, 0) == FAILURE)
2884     return FAILURE;
2885
2886   if (rank_check (x, 0, 1) == FAILURE)
2887     return FAILURE;
2888
2889   if (variable_check (x, 0) == FAILURE)
2890     return FAILURE;
2891
2892   if (type_check (x, 0, BT_REAL) == FAILURE)
2893     return FAILURE;
2894
2895   if (kind_value_check(x, 0, 4) == FAILURE)
2896     return FAILURE;
2897
2898   return SUCCESS;
2899 }
2900
2901 try
2902 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2903 {
2904   if (array_check (values, 0) == FAILURE)
2905     return FAILURE;
2906
2907   if (rank_check (values, 0, 1) == FAILURE)
2908     return FAILURE;
2909
2910   if (variable_check (values, 0) == FAILURE)
2911     return FAILURE;
2912
2913   if (type_check (values, 0, BT_REAL) == FAILURE)
2914     return FAILURE;
2915
2916   if (kind_value_check(values, 0, 4) == FAILURE)
2917     return FAILURE;
2918
2919   if (scalar_check (time, 1) == FAILURE)
2920     return FAILURE;
2921
2922   if (type_check (time, 1, BT_REAL) == FAILURE)
2923     return FAILURE;
2924
2925   if (kind_value_check(time, 1, 4) == FAILURE)
2926     return FAILURE;
2927
2928   return SUCCESS;
2929 }
2930
2931
2932 try
2933 gfc_check_fdate_sub (gfc_expr * date)
2934 {
2935   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2936     return FAILURE;
2937
2938   return SUCCESS;
2939 }
2940
2941
2942 try
2943 gfc_check_gerror (gfc_expr * msg)
2944 {
2945   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2946     return FAILURE;
2947
2948   return SUCCESS;
2949 }
2950
2951
2952 try
2953 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2954 {
2955   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2956     return FAILURE;
2957
2958   if (status == NULL)
2959     return SUCCESS;
2960
2961   if (scalar_check (status, 1) == FAILURE)
2962     return FAILURE;
2963
2964   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2965     return FAILURE;
2966
2967   return SUCCESS;
2968 }
2969
2970
2971 try
2972 gfc_check_getlog (gfc_expr * msg)
2973 {
2974   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2975     return FAILURE;
2976
2977   return SUCCESS;
2978 }
2979
2980
2981 try
2982 gfc_check_exit (gfc_expr * status)
2983 {
2984   if (status == NULL)
2985     return SUCCESS;
2986
2987   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2988     return FAILURE;
2989
2990   if (scalar_check (status, 0) == FAILURE)
2991     return FAILURE;
2992
2993   return SUCCESS;
2994 }
2995
2996
2997 try
2998 gfc_check_flush (gfc_expr * unit)
2999 {
3000   if (unit == NULL)
3001     return SUCCESS;
3002
3003   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3004     return FAILURE;
3005
3006   if (scalar_check (unit, 0) == FAILURE)
3007     return FAILURE;
3008
3009   return SUCCESS;
3010 }
3011
3012
3013 try
3014 gfc_check_free (gfc_expr * i)
3015 {
3016   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3017     return FAILURE;
3018
3019   if (scalar_check (i, 0) == FAILURE)
3020     return FAILURE;
3021
3022   return SUCCESS;
3023 }
3024
3025
3026 try
3027 gfc_check_hostnm (gfc_expr * name)
3028 {
3029   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3030     return FAILURE;
3031
3032   return SUCCESS;
3033 }
3034
3035
3036 try
3037 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
3038 {
3039   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3040     return FAILURE;
3041
3042   if (status == NULL)
3043     return SUCCESS;
3044
3045   if (scalar_check (status, 1) == FAILURE)
3046     return FAILURE;
3047
3048   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3049     return FAILURE;
3050
3051   return SUCCESS;
3052 }
3053
3054
3055 try
3056 gfc_check_itime_idate (gfc_expr * values)
3057 {
3058   if (array_check (values, 0) == FAILURE)
3059     return FAILURE;
3060
3061   if (rank_check (values, 0, 1) == FAILURE)
3062     return FAILURE;
3063
3064   if (variable_check (values, 0) == FAILURE)
3065     return FAILURE;
3066
3067   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3068     return FAILURE;
3069
3070   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3071     return FAILURE;
3072
3073   return SUCCESS;
3074 }
3075
3076
3077 try
3078 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
3079 {
3080   if (scalar_check (unit, 0) == FAILURE)
3081     return FAILURE;
3082
3083   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3084     return FAILURE;
3085
3086   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3087     return FAILURE;
3088
3089   return SUCCESS;
3090 }
3091
3092
3093 try
3094 gfc_check_isatty (gfc_expr * unit)
3095 {
3096   if (unit == NULL)
3097     return FAILURE;
3098
3099   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3100     return FAILURE;
3101
3102   if (scalar_check (unit, 0) == FAILURE)
3103     return FAILURE;
3104
3105   return SUCCESS;
3106 }
3107
3108
3109 try
3110 gfc_check_perror (gfc_expr * string)
3111 {
3112   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3113     return FAILURE;
3114
3115   return SUCCESS;
3116 }
3117
3118
3119 try
3120 gfc_check_umask (gfc_expr * mask)
3121 {
3122   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3123     return FAILURE;
3124
3125   if (scalar_check (mask, 0) == FAILURE)
3126     return FAILURE;
3127
3128   return SUCCESS;
3129 }
3130
3131
3132 try
3133 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
3134 {
3135   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3136     return FAILURE;
3137
3138   if (scalar_check (mask, 0) == FAILURE)
3139     return FAILURE;
3140
3141   if (old == NULL)
3142     return SUCCESS;
3143
3144   if (scalar_check (old, 1) == FAILURE)
3145     return FAILURE;
3146
3147   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3148     return FAILURE;
3149
3150   return SUCCESS;
3151 }
3152
3153
3154 try
3155 gfc_check_unlink (gfc_expr * name)
3156 {
3157   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3158     return FAILURE;
3159
3160   return SUCCESS;
3161 }
3162
3163
3164 try
3165 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
3166 {
3167   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3168     return FAILURE;
3169
3170   if (status == NULL)
3171     return SUCCESS;
3172
3173   if (scalar_check (status, 1) == FAILURE)
3174     return FAILURE;
3175
3176   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3177     return FAILURE;
3178
3179   return SUCCESS;
3180 }
3181
3182
3183 try
3184 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
3185 {
3186   if (scalar_check (number, 0) == FAILURE)
3187     return FAILURE;
3188
3189   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3190     return FAILURE;
3191
3192   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3193     {
3194       gfc_error (
3195         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3196         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3197       return FAILURE;
3198     }
3199
3200   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3201     return FAILURE;
3202
3203   return SUCCESS;
3204 }
3205
3206
3207 try
3208 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
3209 {
3210   if (scalar_check (number, 0) == FAILURE)
3211     return FAILURE;
3212
3213   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3214     return FAILURE;
3215
3216   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3217     {
3218       gfc_error (
3219         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3220         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3221       return FAILURE;
3222     }
3223
3224   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3225     return FAILURE;
3226
3227   if (status == NULL)
3228     return SUCCESS;
3229
3230   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3231     return FAILURE;
3232
3233   if (scalar_check (status, 2) == FAILURE)
3234     return FAILURE;
3235
3236   return SUCCESS;
3237 }
3238
3239
3240 try
3241 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
3242 {
3243   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3244     return FAILURE;
3245
3246   if (scalar_check (status, 1) == FAILURE)
3247     return FAILURE;
3248
3249   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3250     return FAILURE;
3251
3252   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3253     return FAILURE;
3254
3255   return SUCCESS;
3256 }
3257
3258
3259 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3260 try
3261 gfc_check_and (gfc_expr * i, gfc_expr * j)
3262 {
3263   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3264     {
3265       gfc_error (
3266         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3267         gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
3268       return FAILURE;
3269     }
3270
3271   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3272     {
3273       gfc_error (
3274         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3275         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
3276       return FAILURE;
3277     }
3278
3279   if (i->ts.type != j->ts.type)
3280     {
3281       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3282                  "have the same type", gfc_current_intrinsic_arg[0],
3283                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3284                  &j->where);
3285       return FAILURE;
3286     }
3287
3288   if (scalar_check (i, 0) == FAILURE)
3289     return FAILURE;
3290
3291   if (scalar_check (j, 1) == FAILURE)
3292     return FAILURE;
3293
3294   return SUCCESS;
3295 }