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_intconv (gfc_expr * x)
1204 {
1205   if (numeric_check (x, 0) == FAILURE)
1206     return FAILURE;
1207
1208   return SUCCESS;
1209 }
1210
1211
1212 try
1213 gfc_check_ior (gfc_expr * i, gfc_expr * j)
1214 {
1215   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1216     return FAILURE;
1217
1218   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1219     return FAILURE;
1220
1221   if (i->ts.kind != j->ts.kind)
1222     {
1223       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1224                           &i->where) == FAILURE)
1225     return FAILURE;
1226     }
1227
1228   return SUCCESS;
1229 }
1230
1231
1232 try
1233 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
1234 {
1235   if (type_check (i, 0, BT_INTEGER) == FAILURE
1236       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1237     return FAILURE;
1238
1239   return SUCCESS;
1240 }
1241
1242
1243 try
1244 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
1245 {
1246   if (type_check (i, 0, BT_INTEGER) == FAILURE
1247       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1248     return FAILURE;
1249
1250   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1251     return FAILURE;
1252
1253   return SUCCESS;
1254 }
1255
1256
1257 try
1258 gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
1259 {
1260   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1261     return FAILURE;
1262
1263   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1264     return FAILURE;
1265
1266   return SUCCESS;
1267 }
1268
1269
1270 try
1271 gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
1272 {
1273   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1274     return FAILURE;
1275
1276   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1277     return FAILURE;
1278
1279   if (status == NULL)
1280     return SUCCESS;
1281
1282   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1283     return FAILURE;
1284
1285   if (scalar_check (status, 2) == FAILURE)
1286     return FAILURE;
1287
1288   return SUCCESS;
1289 }
1290
1291
1292 try
1293 gfc_check_kind (gfc_expr * x)
1294 {
1295   if (x->ts.type == BT_DERIVED)
1296     {
1297       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1298                  "non-derived type", gfc_current_intrinsic_arg[0],
1299                  gfc_current_intrinsic, &x->where);
1300       return FAILURE;
1301     }
1302
1303   return SUCCESS;
1304 }
1305
1306
1307 try
1308 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1309 {
1310   if (array_check (array, 0) == FAILURE)
1311     return FAILURE;
1312
1313   if (dim != NULL)
1314     {
1315       if (dim_check (dim, 1, 1) == FAILURE)
1316         return FAILURE;
1317
1318       if (dim_rank_check (dim, array, 1) == FAILURE)
1319         return FAILURE;
1320     }
1321   return SUCCESS;
1322 }
1323
1324
1325 try
1326 gfc_check_link (gfc_expr * path1, gfc_expr * path2)
1327 {
1328   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1329     return FAILURE;
1330
1331   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1332     return FAILURE;
1333
1334   return SUCCESS;
1335 }
1336
1337
1338 try
1339 gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1340 {
1341   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1342     return FAILURE;
1343
1344   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1345     return FAILURE;
1346
1347   if (status == NULL)
1348     return SUCCESS;
1349
1350   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1351     return FAILURE;
1352
1353   if (scalar_check (status, 2) == FAILURE)
1354     return FAILURE;
1355
1356   return SUCCESS;
1357 }
1358
1359 try
1360 gfc_check_loc (gfc_expr *expr)
1361 {
1362   return variable_check (expr, 0);
1363 }
1364
1365
1366 try
1367 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
1368 {
1369   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1370     return FAILURE;
1371
1372   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1373     return FAILURE;
1374
1375   return SUCCESS;
1376 }
1377
1378
1379 try
1380 gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1381 {
1382   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1383     return FAILURE;
1384
1385   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1386     return FAILURE;
1387
1388   if (status == NULL)
1389     return SUCCESS;
1390
1391   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1392     return FAILURE;
1393
1394   if (scalar_check (status, 2) == FAILURE)
1395     return FAILURE;
1396
1397   return SUCCESS;
1398 }
1399
1400
1401 try
1402 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1403 {
1404   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1405     return FAILURE;
1406   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1407     return FAILURE;
1408
1409   return SUCCESS;
1410 }
1411
1412
1413 /* Min/max family.  */
1414
1415 static try
1416 min_max_args (gfc_actual_arglist * arg)
1417 {
1418   if (arg == NULL || arg->next == NULL)
1419     {
1420       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1421                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1422       return FAILURE;
1423     }
1424
1425   return SUCCESS;
1426 }
1427
1428
1429 static try
1430 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1431 {
1432   gfc_expr *x;
1433   int n;
1434
1435   if (min_max_args (arg) == FAILURE)
1436     return FAILURE;
1437
1438   n = 1;
1439
1440   for (; arg; arg = arg->next, n++)
1441     {
1442       x = arg->expr;
1443       if (x->ts.type != type || x->ts.kind != kind)
1444         {
1445           if (x->ts.type == type)
1446             {
1447               if (gfc_notify_std (GFC_STD_GNU,
1448                     "Extension: Different type kinds at %L", &x->where)
1449                   == FAILURE)
1450                 return FAILURE;
1451             }
1452           else
1453             {
1454               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1455                          n, gfc_current_intrinsic, &x->where,
1456                          gfc_basic_typename (type), kind);
1457               return FAILURE;
1458             }
1459         }
1460     }
1461
1462   return SUCCESS;
1463 }
1464
1465
1466 try
1467 gfc_check_min_max (gfc_actual_arglist * arg)
1468 {
1469   gfc_expr *x;
1470
1471   if (min_max_args (arg) == FAILURE)
1472     return FAILURE;
1473
1474   x = arg->expr;
1475
1476   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1477     {
1478       gfc_error
1479         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1480          gfc_current_intrinsic, &x->where);
1481       return FAILURE;
1482     }
1483
1484   return check_rest (x->ts.type, x->ts.kind, arg);
1485 }
1486
1487
1488 try
1489 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1490 {
1491   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1492 }
1493
1494
1495 try
1496 gfc_check_min_max_real (gfc_actual_arglist * arg)
1497 {
1498   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1499 }
1500
1501
1502 try
1503 gfc_check_min_max_double (gfc_actual_arglist * arg)
1504 {
1505   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1506 }
1507
1508 /* End of min/max family.  */
1509
1510 try
1511 gfc_check_malloc (gfc_expr * size)
1512 {
1513   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1514     return FAILURE;
1515
1516   if (scalar_check (size, 0) == FAILURE)
1517     return FAILURE;
1518
1519   return SUCCESS;
1520 }
1521
1522
1523 try
1524 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1525 {
1526   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1527     {
1528       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1529                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1530                  gfc_current_intrinsic, &matrix_a->where);
1531       return FAILURE;
1532     }
1533
1534   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1535     {
1536       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1537                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1538                  gfc_current_intrinsic, &matrix_b->where);
1539       return FAILURE;
1540     }
1541
1542   switch (matrix_a->rank)
1543     {
1544     case 1:
1545       if (rank_check (matrix_b, 1, 2) == FAILURE)
1546         return FAILURE;
1547       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
1548       if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1549         {
1550           gfc_error ("different shape on dimension 1 for arguments '%s' "
1551                      "and '%s' at %L for intrinsic matmul",
1552                      gfc_current_intrinsic_arg[0],
1553                      gfc_current_intrinsic_arg[1],
1554                      &matrix_a->where);
1555           return FAILURE;
1556         }
1557       break;
1558
1559     case 2:
1560       if (matrix_b->rank != 2)
1561         {
1562           if (rank_check (matrix_b, 1, 1) == FAILURE)
1563             return FAILURE;
1564         }
1565       /* matrix_b has rank 1 or 2 here. Common check for the cases
1566          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1567          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
1568       if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1569         {
1570           gfc_error ("different shape on dimension 2 for argument '%s' and "
1571                      "dimension 1 for argument '%s' at %L for intrinsic "
1572                      "matmul", gfc_current_intrinsic_arg[0],
1573                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1574           return FAILURE;
1575         }
1576       break;
1577
1578     default:
1579       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1580                  "1 or 2", gfc_current_intrinsic_arg[0],
1581                  gfc_current_intrinsic, &matrix_a->where);
1582       return FAILURE;
1583     }
1584
1585   if (gfc_init_expr)
1586     return non_init_transformational ();
1587
1588   return SUCCESS;
1589 }
1590
1591
1592 /* Whoever came up with this interface was probably on something.
1593    The possibilities for the occupation of the second and third
1594    parameters are:
1595
1596          Arg #2     Arg #3
1597          NULL       NULL
1598          DIM        NULL
1599          MASK       NULL
1600          NULL       MASK             minloc(array, mask=m)
1601          DIM        MASK
1602
1603    I.e. in the case of minloc(array,mask), mask will be in the second
1604    position of the argument list and we'll have to fix that up.  */
1605
1606 try
1607 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1608 {
1609   gfc_expr *a, *m, *d;
1610
1611   a = ap->expr;
1612   if (int_or_real_check (a, 0) == FAILURE
1613       || array_check (a, 0) == FAILURE)
1614     return FAILURE;
1615
1616   d = ap->next->expr;
1617   m = ap->next->next->expr;
1618
1619   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1620       && ap->next->name == NULL)
1621     {
1622       m = d;
1623       d = NULL;
1624
1625       ap->next->expr = NULL;
1626       ap->next->next->expr = m;
1627     }
1628
1629   if (dim_check (d, 1, 1) == FAILURE)
1630     return FAILURE;
1631
1632   if (d && dim_rank_check (d, a, 0) == FAILURE)
1633     return FAILURE;
1634
1635   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1636     return FAILURE;
1637
1638   if (m != NULL)
1639     {
1640       char buffer[80];
1641       snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1642                gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1643                gfc_current_intrinsic);
1644       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1645         return FAILURE;
1646     }
1647
1648   if (gfc_init_expr)
1649     return non_init_transformational ();
1650
1651   return SUCCESS;
1652 }
1653
1654
1655 /* Similar to minloc/maxloc, the argument list might need to be
1656    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1657    difference is that MINLOC/MAXLOC take an additional KIND argument.
1658    The possibilities are:
1659
1660          Arg #2     Arg #3
1661          NULL       NULL
1662          DIM        NULL
1663          MASK       NULL
1664          NULL       MASK             minval(array, mask=m)
1665          DIM        MASK
1666
1667    I.e. in the case of minval(array,mask), mask will be in the second
1668    position of the argument list and we'll have to fix that up.  */
1669
1670 static try
1671 check_reduction (gfc_actual_arglist * ap)
1672 {
1673   gfc_expr *a, *m, *d;
1674
1675   a = ap->expr;
1676   d = ap->next->expr;
1677   m = ap->next->next->expr;
1678
1679   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1680       && ap->next->name == NULL)
1681     {
1682       m = d;
1683       d = NULL;
1684
1685       ap->next->expr = NULL;
1686       ap->next->next->expr = m;
1687     }
1688
1689   if (dim_check (d, 1, 1) == FAILURE)
1690     return FAILURE;
1691
1692   if (d && dim_rank_check (d, a, 0) == FAILURE)
1693     return FAILURE;
1694
1695   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1696     return FAILURE;
1697
1698   if (m != NULL)
1699     {
1700       char buffer[80];
1701       snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1702                gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1703                gfc_current_intrinsic);
1704       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1705         return FAILURE;
1706     }
1707
1708   return SUCCESS;
1709 }
1710
1711
1712 try
1713 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1714 {
1715   if (int_or_real_check (ap->expr, 0) == FAILURE
1716       || array_check (ap->expr, 0) == FAILURE)
1717     return FAILURE;
1718
1719   if (gfc_init_expr)
1720     return non_init_transformational ();
1721
1722   return check_reduction (ap);
1723 }
1724
1725
1726 try
1727 gfc_check_product_sum (gfc_actual_arglist * ap)
1728 {
1729   if (numeric_check (ap->expr, 0) == FAILURE
1730       || array_check (ap->expr, 0) == FAILURE)
1731     return FAILURE;
1732
1733   if (gfc_init_expr)
1734     return non_init_transformational ();
1735
1736   return check_reduction (ap);
1737 }
1738
1739
1740 try
1741 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1742 {
1743   char buffer[80];
1744
1745   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1746     return FAILURE;
1747
1748   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1749     return FAILURE;
1750
1751   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1752            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1753            gfc_current_intrinsic);
1754   if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
1755     return FAILURE;
1756
1757   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1758            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1759            gfc_current_intrinsic);
1760   if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
1761     return FAILURE;
1762
1763   return SUCCESS;
1764 }
1765
1766
1767 try
1768 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1769 {
1770   if (type_check (x, 0, BT_REAL) == FAILURE)
1771     return FAILURE;
1772
1773   if (type_check (s, 1, BT_REAL) == FAILURE)
1774     return FAILURE;
1775
1776   return SUCCESS;
1777 }
1778
1779
1780 try
1781 gfc_check_null (gfc_expr * mold)
1782 {
1783   symbol_attribute attr;
1784
1785   if (mold == NULL)
1786     return SUCCESS;
1787
1788   if (variable_check (mold, 0) == FAILURE)
1789     return FAILURE;
1790
1791   attr = gfc_variable_attr (mold, NULL);
1792
1793   if (!attr.pointer)
1794     {
1795       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1796                  gfc_current_intrinsic_arg[0],
1797                  gfc_current_intrinsic, &mold->where);
1798       return FAILURE;
1799     }
1800
1801   return SUCCESS;
1802 }
1803
1804
1805 try
1806 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1807 {
1808   char buffer[80];
1809
1810   if (array_check (array, 0) == FAILURE)
1811     return FAILURE;
1812
1813   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1814     return FAILURE;
1815
1816   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1817            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1818            gfc_current_intrinsic);
1819   if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1820     return FAILURE;
1821
1822   if (vector != NULL)
1823     {
1824       if (same_type_check (array, 0, vector, 2) == FAILURE)
1825         return FAILURE;
1826
1827       if (rank_check (vector, 2, 1) == FAILURE)
1828         return FAILURE;
1829
1830       /* TODO: More constraints here.  */
1831     }
1832
1833   if (gfc_init_expr)
1834     return non_init_transformational ();
1835
1836   return SUCCESS;
1837 }
1838
1839
1840 try
1841 gfc_check_precision (gfc_expr * x)
1842 {
1843   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1844     {
1845       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1846                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1847                  gfc_current_intrinsic, &x->where);
1848       return FAILURE;
1849     }
1850
1851   return SUCCESS;
1852 }
1853
1854
1855 try
1856 gfc_check_present (gfc_expr * a)
1857 {
1858   gfc_symbol *sym;
1859
1860   if (variable_check (a, 0) == FAILURE)
1861     return FAILURE;
1862
1863   sym = a->symtree->n.sym;
1864   if (!sym->attr.dummy)
1865     {
1866       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1867                  "dummy variable", gfc_current_intrinsic_arg[0],
1868                  gfc_current_intrinsic, &a->where);
1869       return FAILURE;
1870     }
1871
1872   if (!sym->attr.optional)
1873     {
1874       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1875                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1876                  gfc_current_intrinsic, &a->where);
1877       return FAILURE;
1878     }
1879
1880 /*  13.14.82  PRESENT(A)
1881 ......
1882   Argument.  A shall be the name of an optional dummy argument that is accessible
1883   in the subprogram in which the PRESENT function reference appears...  */
1884
1885   if (a->ref != NULL
1886         && !(a->ref->next == NULL
1887                && a->ref->type == REF_ARRAY
1888                && a->ref->u.ar.type == AR_FULL))
1889     {
1890       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-"
1891                  "object of '%s'", gfc_current_intrinsic_arg[0],
1892                  gfc_current_intrinsic, &a->where, sym->name);
1893       return FAILURE;
1894     }
1895
1896   return SUCCESS;
1897 }
1898
1899
1900 try
1901 gfc_check_radix (gfc_expr * x)
1902 {
1903   if (int_or_real_check (x, 0) == FAILURE)
1904     return FAILURE;
1905
1906   return SUCCESS;
1907 }
1908
1909
1910 try
1911 gfc_check_range (gfc_expr * x)
1912 {
1913   if (numeric_check (x, 0) == FAILURE)
1914     return FAILURE;
1915
1916   return SUCCESS;
1917 }
1918
1919
1920 /* real, float, sngl.  */
1921 try
1922 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1923 {
1924   if (numeric_check (a, 0) == FAILURE)
1925     return FAILURE;
1926
1927   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1928     return FAILURE;
1929
1930   return SUCCESS;
1931 }
1932
1933
1934 try
1935 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
1936 {
1937   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1938     return FAILURE;
1939
1940   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1941     return FAILURE;
1942
1943   return SUCCESS;
1944 }
1945
1946
1947 try
1948 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1949 {
1950   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1951     return FAILURE;
1952
1953   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1954     return FAILURE;
1955
1956   if (status == NULL)
1957     return SUCCESS;
1958
1959   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1960     return FAILURE;
1961
1962   if (scalar_check (status, 2) == FAILURE)
1963     return FAILURE;
1964
1965   return SUCCESS;
1966 }
1967
1968
1969 try
1970 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1971 {
1972   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1973     return FAILURE;
1974
1975   if (scalar_check (x, 0) == FAILURE)
1976     return FAILURE;
1977
1978   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1979     return FAILURE;
1980
1981   if (scalar_check (y, 1) == FAILURE)
1982     return FAILURE;
1983
1984   return SUCCESS;
1985 }
1986
1987
1988 try
1989 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1990                    gfc_expr * pad, gfc_expr * order)
1991 {
1992   mpz_t size;
1993   int m;
1994
1995   if (array_check (source, 0) == FAILURE)
1996     return FAILURE;
1997
1998   if (rank_check (shape, 1, 1) == FAILURE)
1999     return FAILURE;
2000
2001   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2002     return FAILURE;
2003
2004   if (gfc_array_size (shape, &size) != SUCCESS)
2005     {
2006       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2007                  "array of constant size", &shape->where);
2008       return FAILURE;
2009     }
2010
2011   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2012   mpz_clear (size);
2013
2014   if (m > 0)
2015     {
2016       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2017                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2018       return FAILURE;
2019     }
2020
2021   if (pad != NULL)
2022     {
2023       if (same_type_check (source, 0, pad, 2) == FAILURE)
2024         return FAILURE;
2025       if (array_check (pad, 2) == FAILURE)
2026         return FAILURE;
2027     }
2028
2029   if (order != NULL && array_check (order, 3) == FAILURE)
2030     return FAILURE;
2031
2032   return SUCCESS;
2033 }
2034
2035
2036 try
2037 gfc_check_scale (gfc_expr * x, gfc_expr * i)
2038 {
2039   if (type_check (x, 0, BT_REAL) == FAILURE)
2040     return FAILURE;
2041
2042   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2043     return FAILURE;
2044
2045   return SUCCESS;
2046 }
2047
2048
2049 try
2050 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2051 {
2052   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2053     return FAILURE;
2054
2055   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2056     return FAILURE;
2057
2058   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2059     return FAILURE;
2060
2061   if (same_type_check (x, 0, y, 1) == FAILURE)
2062     return FAILURE;
2063
2064   return SUCCESS;
2065 }
2066
2067
2068 try
2069 gfc_check_secnds (gfc_expr * r)
2070 {
2071
2072   if (type_check (r, 0, BT_REAL) == FAILURE)
2073     return FAILURE;
2074
2075   if (kind_value_check (r, 0, 4) == FAILURE)
2076     return FAILURE;
2077
2078   if (scalar_check (r, 0) == FAILURE)
2079     return FAILURE;
2080
2081   return SUCCESS;
2082 }
2083
2084
2085 try
2086 gfc_check_selected_int_kind (gfc_expr * r)
2087 {
2088
2089   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2090     return FAILURE;
2091
2092   if (scalar_check (r, 0) == FAILURE)
2093     return FAILURE;
2094
2095   return SUCCESS;
2096 }
2097
2098
2099 try
2100 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
2101 {
2102   if (p == NULL && r == NULL)
2103     {
2104       gfc_error ("Missing arguments to %s intrinsic at %L",
2105                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2106
2107       return FAILURE;
2108     }
2109
2110   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2111     return FAILURE;
2112
2113   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2114     return FAILURE;
2115
2116   return SUCCESS;
2117 }
2118
2119
2120 try
2121 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
2122 {
2123   if (type_check (x, 0, BT_REAL) == FAILURE)
2124     return FAILURE;
2125
2126   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2127     return FAILURE;
2128
2129   return SUCCESS;
2130 }
2131
2132
2133 try
2134 gfc_check_shape (gfc_expr * source)
2135 {
2136   gfc_array_ref *ar;
2137
2138   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2139     return SUCCESS;
2140
2141   ar = gfc_find_array_ref (source);
2142
2143   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2144     {
2145       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2146                  "an assumed size array", &source->where);
2147       return FAILURE;
2148     }
2149
2150   return SUCCESS;
2151 }
2152
2153
2154 try
2155 gfc_check_sign (gfc_expr * a, gfc_expr * b)
2156 {
2157   if (int_or_real_check (a, 0) == FAILURE)
2158     return FAILURE;
2159
2160   if (same_type_check (a, 0, b, 1) == FAILURE)
2161     return FAILURE;
2162
2163   return SUCCESS;
2164 }
2165
2166
2167 try
2168 gfc_check_size (gfc_expr * array, gfc_expr * dim)
2169 {
2170   if (array_check (array, 0) == FAILURE)
2171     return FAILURE;
2172
2173   if (dim != NULL)
2174     {
2175       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2176         return FAILURE;
2177
2178       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2179         return FAILURE;
2180
2181       if (dim_rank_check (dim, array, 0) == FAILURE)
2182         return FAILURE;
2183     }
2184
2185   return SUCCESS;
2186 }
2187
2188
2189 try
2190 gfc_check_sleep_sub (gfc_expr * seconds)
2191 {
2192   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2193     return FAILURE;
2194
2195   if (scalar_check (seconds, 0) == FAILURE)
2196     return FAILURE;
2197
2198   return SUCCESS;
2199 }
2200
2201
2202 try
2203 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
2204 {
2205   if (source->rank >= GFC_MAX_DIMENSIONS)
2206     {
2207       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2208                  "than rank %d", gfc_current_intrinsic_arg[0],
2209                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2210
2211       return FAILURE;
2212     }
2213
2214   if (dim_check (dim, 1, 0) == FAILURE)
2215     return FAILURE;
2216
2217   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2218     return FAILURE;
2219
2220   if (scalar_check (ncopies, 2) == FAILURE)
2221     return FAILURE;
2222
2223   if (gfc_init_expr)
2224     return non_init_transformational ();
2225
2226   return SUCCESS;
2227 }
2228
2229
2230 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2231    functions).  */
2232 try
2233 gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
2234 {
2235   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2236     return FAILURE;
2237
2238   if (scalar_check (unit, 0) == FAILURE)
2239     return FAILURE;
2240
2241   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2242     return FAILURE;
2243
2244   if (status == NULL)
2245     return SUCCESS;
2246
2247   if (type_check (status, 2, BT_INTEGER) == FAILURE
2248       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2249       || scalar_check (status, 2) == FAILURE)
2250     return FAILURE;
2251
2252   return SUCCESS;
2253 }
2254
2255
2256 try
2257 gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
2258 {
2259   return gfc_check_fgetputc_sub (unit, c, NULL);
2260 }
2261
2262
2263 try
2264 gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
2265 {
2266   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2267     return FAILURE;
2268
2269   if (status == NULL)
2270     return SUCCESS;
2271
2272   if (type_check (status, 1, BT_INTEGER) == FAILURE
2273       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2274       || scalar_check (status, 1) == FAILURE)
2275     return FAILURE;
2276
2277   return SUCCESS;
2278 }
2279
2280
2281 try
2282 gfc_check_fgetput (gfc_expr * c)
2283 {
2284   return gfc_check_fgetput_sub (c, NULL);
2285 }
2286
2287
2288 try
2289 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2290 {
2291   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2292     return FAILURE;
2293
2294   if (scalar_check (unit, 0) == FAILURE)
2295     return FAILURE;
2296
2297   if (type_check (array, 1, BT_INTEGER) == FAILURE
2298       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2299     return FAILURE;
2300
2301   if (array_check (array, 1) == FAILURE)
2302     return FAILURE;
2303
2304   return SUCCESS;
2305 }
2306
2307
2308 try
2309 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2310 {
2311   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2312     return FAILURE;
2313
2314   if (scalar_check (unit, 0) == FAILURE)
2315     return FAILURE;
2316
2317   if (type_check (array, 1, BT_INTEGER) == FAILURE
2318       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2319     return FAILURE;
2320
2321   if (array_check (array, 1) == FAILURE)
2322     return FAILURE;
2323
2324   if (status == NULL)
2325     return SUCCESS;
2326
2327   if (type_check (status, 2, BT_INTEGER) == FAILURE
2328       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2329     return FAILURE;
2330
2331   if (scalar_check (status, 2) == FAILURE)
2332     return FAILURE;
2333
2334   return SUCCESS;
2335 }
2336
2337
2338 try
2339 gfc_check_ftell (gfc_expr * unit)
2340 {
2341   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2342     return FAILURE;
2343
2344   if (scalar_check (unit, 0) == FAILURE)
2345     return FAILURE;
2346
2347   return SUCCESS;
2348 }
2349
2350
2351 try
2352 gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
2353 {
2354   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2355     return FAILURE;
2356
2357   if (scalar_check (unit, 0) == FAILURE)
2358     return FAILURE;
2359
2360   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2361     return FAILURE;
2362
2363   if (scalar_check (offset, 1) == FAILURE)
2364     return FAILURE;
2365
2366   return SUCCESS;
2367 }
2368
2369
2370 try
2371 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2372 {
2373   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2374     return FAILURE;
2375
2376   if (type_check (array, 1, BT_INTEGER) == FAILURE
2377       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2378     return FAILURE;
2379
2380   if (array_check (array, 1) == FAILURE)
2381     return FAILURE;
2382
2383   return SUCCESS;
2384 }
2385
2386
2387 try
2388 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2389 {
2390   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2391     return FAILURE;
2392
2393   if (type_check (array, 1, BT_INTEGER) == FAILURE
2394       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2395     return FAILURE;
2396
2397   if (array_check (array, 1) == FAILURE)
2398     return FAILURE;
2399
2400   if (status == NULL)
2401     return SUCCESS;
2402
2403   if (type_check (status, 2, BT_INTEGER) == FAILURE
2404       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2405     return FAILURE;
2406
2407   if (scalar_check (status, 2) == FAILURE)
2408     return FAILURE;
2409
2410   return SUCCESS;
2411 }
2412
2413
2414 try
2415 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2416                     gfc_expr * mold ATTRIBUTE_UNUSED,
2417                     gfc_expr * size)
2418 {
2419   if (size != NULL)
2420     {
2421       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2422         return FAILURE;
2423
2424       if (scalar_check (size, 2) == FAILURE)
2425         return FAILURE;
2426
2427       if (nonoptional_check (size, 2) == FAILURE)
2428         return FAILURE;
2429     }
2430
2431   return SUCCESS;
2432 }
2433
2434
2435 try
2436 gfc_check_transpose (gfc_expr * matrix)
2437 {
2438   if (rank_check (matrix, 0, 2) == FAILURE)
2439     return FAILURE;
2440
2441   if (gfc_init_expr)
2442     return non_init_transformational ();
2443
2444   return SUCCESS;
2445 }
2446
2447
2448 try
2449 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2450 {
2451   if (array_check (array, 0) == FAILURE)
2452     return FAILURE;
2453
2454   if (dim != NULL)
2455     {
2456       if (dim_check (dim, 1, 1) == FAILURE)
2457         return FAILURE;
2458
2459       if (dim_rank_check (dim, array, 0) == FAILURE)
2460         return FAILURE;
2461     }
2462
2463   return SUCCESS;
2464 }
2465
2466
2467 try
2468 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2469 {
2470   if (rank_check (vector, 0, 1) == FAILURE)
2471     return FAILURE;
2472
2473   if (array_check (mask, 1) == FAILURE)
2474     return FAILURE;
2475
2476   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2477     return FAILURE;
2478
2479   if (same_type_check (vector, 0, field, 2) == FAILURE)
2480     return FAILURE;
2481
2482   if (gfc_init_expr)
2483     return non_init_transformational ();
2484
2485   return SUCCESS;
2486 }
2487
2488
2489 try
2490 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2491 {
2492   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2493     return FAILURE;
2494
2495   if (same_type_check (x, 0, y, 1) == FAILURE)
2496     return FAILURE;
2497
2498   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2499     return FAILURE;
2500
2501   return SUCCESS;
2502 }
2503
2504
2505 try
2506 gfc_check_trim (gfc_expr * x)
2507 {
2508   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2509     return FAILURE;
2510
2511   if (scalar_check (x, 0) == FAILURE)
2512     return FAILURE;
2513
2514    return SUCCESS;
2515 }
2516
2517
2518 try
2519 gfc_check_ttynam (gfc_expr * unit)
2520 {
2521   if (scalar_check (unit, 0) == FAILURE)
2522     return FAILURE;
2523
2524   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2525     return FAILURE;
2526
2527   return SUCCESS;
2528 }
2529
2530
2531 /* Common check function for the half a dozen intrinsics that have a
2532    single real argument.  */
2533
2534 try
2535 gfc_check_x (gfc_expr * x)
2536 {
2537   if (type_check (x, 0, BT_REAL) == FAILURE)
2538     return FAILURE;
2539
2540   return SUCCESS;
2541 }
2542
2543
2544 /************* Check functions for intrinsic subroutines *************/
2545
2546 try
2547 gfc_check_cpu_time (gfc_expr * time)
2548 {
2549   if (scalar_check (time, 0) == FAILURE)
2550     return FAILURE;
2551
2552   if (type_check (time, 0, BT_REAL) == FAILURE)
2553     return FAILURE;
2554
2555   if (variable_check (time, 0) == FAILURE)
2556     return FAILURE;
2557
2558   return SUCCESS;
2559 }
2560
2561
2562 try
2563 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2564                          gfc_expr * zone, gfc_expr * values)
2565 {
2566   if (date != NULL)
2567     {
2568       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2569         return FAILURE;
2570       if (scalar_check (date, 0) == FAILURE)
2571         return FAILURE;
2572       if (variable_check (date, 0) == FAILURE)
2573         return FAILURE;
2574     }
2575
2576   if (time != NULL)
2577     {
2578       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2579         return FAILURE;
2580       if (scalar_check (time, 1) == FAILURE)
2581         return FAILURE;
2582       if (variable_check (time, 1) == FAILURE)
2583         return FAILURE;
2584     }
2585
2586   if (zone != NULL)
2587     {
2588       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2589         return FAILURE;
2590       if (scalar_check (zone, 2) == FAILURE)
2591         return FAILURE;
2592       if (variable_check (zone, 2) == FAILURE)
2593         return FAILURE;
2594     }
2595
2596   if (values != NULL)
2597     {
2598       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2599         return FAILURE;
2600       if (array_check (values, 3) == FAILURE)
2601         return FAILURE;
2602       if (rank_check (values, 3, 1) == FAILURE)
2603         return FAILURE;
2604       if (variable_check (values, 3) == FAILURE)
2605         return FAILURE;
2606     }
2607
2608   return SUCCESS;
2609 }
2610
2611
2612 try
2613 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2614                   gfc_expr * to, gfc_expr * topos)
2615 {
2616   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2617     return FAILURE;
2618
2619   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2620     return FAILURE;
2621
2622   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2623     return FAILURE;
2624
2625   if (same_type_check (from, 0, to, 3) == FAILURE)
2626     return FAILURE;
2627
2628   if (variable_check (to, 3) == FAILURE)
2629     return FAILURE;
2630
2631   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2632     return FAILURE;
2633
2634   return SUCCESS;
2635 }
2636
2637
2638 try
2639 gfc_check_random_number (gfc_expr * harvest)
2640 {
2641   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2642     return FAILURE;
2643
2644   if (variable_check (harvest, 0) == FAILURE)
2645     return FAILURE;
2646
2647   return SUCCESS;
2648 }
2649
2650
2651 try
2652 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2653 {
2654   if (size != NULL)
2655     {
2656       if (scalar_check (size, 0) == FAILURE)
2657         return FAILURE;
2658
2659       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2660         return FAILURE;
2661
2662       if (variable_check (size, 0) == FAILURE)
2663         return FAILURE;
2664
2665       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2666         return FAILURE;
2667     }
2668
2669   if (put != NULL)
2670     {
2671
2672       if (size != NULL)
2673         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2674                     &put->where);
2675
2676       if (array_check (put, 1) == FAILURE)
2677         return FAILURE;
2678
2679       if (rank_check (put, 1, 1) == FAILURE)
2680         return FAILURE;
2681
2682       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2683         return FAILURE;
2684
2685       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2686         return FAILURE;
2687     }
2688
2689   if (get != NULL)
2690     {
2691
2692       if (size != NULL || put != NULL)
2693         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2694                     &get->where);
2695
2696       if (array_check (get, 2) == FAILURE)
2697         return FAILURE;
2698
2699       if (rank_check (get, 2, 1) == FAILURE)
2700         return FAILURE;
2701
2702       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2703         return FAILURE;
2704
2705       if (variable_check (get, 2) == FAILURE)
2706         return FAILURE;
2707
2708       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2709         return FAILURE;
2710     }
2711
2712   return SUCCESS;
2713 }
2714
2715 try
2716 gfc_check_second_sub (gfc_expr * time)
2717 {
2718   if (scalar_check (time, 0) == FAILURE)
2719     return FAILURE;
2720
2721   if (type_check (time, 0, BT_REAL) == FAILURE)
2722     return FAILURE;
2723
2724   if (kind_value_check(time, 0, 4) == FAILURE)
2725     return FAILURE;
2726
2727   return SUCCESS;
2728 }
2729
2730
2731 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2732    count, count_rate, and count_max are all optional arguments */
2733
2734 try
2735 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2736                         gfc_expr * count_max)
2737 {
2738   if (count != NULL)
2739     {
2740       if (scalar_check (count, 0) == FAILURE)
2741         return FAILURE;
2742
2743       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2744         return FAILURE;
2745
2746       if (variable_check (count, 0) == FAILURE)
2747         return FAILURE;
2748     }
2749
2750   if (count_rate != NULL)
2751     {
2752       if (scalar_check (count_rate, 1) == FAILURE)
2753         return FAILURE;
2754
2755       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2756         return FAILURE;
2757
2758       if (variable_check (count_rate, 1) == FAILURE)
2759         return FAILURE;
2760
2761       if (count != NULL
2762           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2763         return FAILURE;
2764
2765     }
2766
2767   if (count_max != NULL)
2768     {
2769       if (scalar_check (count_max, 2) == FAILURE)
2770         return FAILURE;
2771
2772       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2773         return FAILURE;
2774
2775       if (variable_check (count_max, 2) == FAILURE)
2776         return FAILURE;
2777
2778       if (count != NULL
2779           && same_type_check (count, 0, count_max, 2) == FAILURE)
2780         return FAILURE;
2781
2782       if (count_rate != NULL
2783           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2784         return FAILURE;
2785     }
2786
2787   return SUCCESS;
2788 }
2789
2790 try
2791 gfc_check_irand (gfc_expr * x)
2792 {
2793   if (x == NULL)
2794     return SUCCESS;
2795
2796   if (scalar_check (x, 0) == FAILURE)
2797     return FAILURE;
2798
2799   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2800     return FAILURE;
2801
2802   if (kind_value_check(x, 0, 4) == FAILURE)
2803     return FAILURE;
2804
2805   return SUCCESS;
2806 }
2807
2808
2809 try
2810 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2811 {
2812   if (scalar_check (seconds, 0) == FAILURE)
2813     return FAILURE;
2814
2815   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2816     return FAILURE;
2817
2818   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2819     {
2820       gfc_error (
2821         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2822         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2823       return FAILURE;
2824     }
2825
2826   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2827     return FAILURE;
2828
2829   if (status == NULL)
2830     return SUCCESS;
2831
2832   if (scalar_check (status, 2) == FAILURE)
2833     return FAILURE;
2834
2835   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2836     return FAILURE;
2837
2838   return SUCCESS;
2839 }
2840
2841
2842 try
2843 gfc_check_rand (gfc_expr * x)
2844 {
2845   if (x == NULL)
2846     return SUCCESS;
2847
2848   if (scalar_check (x, 0) == FAILURE)
2849     return FAILURE;
2850
2851   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2852     return FAILURE;
2853
2854   if (kind_value_check(x, 0, 4) == FAILURE)
2855     return FAILURE;
2856
2857   return SUCCESS;
2858 }
2859
2860 try
2861 gfc_check_srand (gfc_expr * x)
2862 {
2863   if (scalar_check (x, 0) == FAILURE)
2864     return FAILURE;
2865
2866   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2867     return FAILURE;
2868
2869   if (kind_value_check(x, 0, 4) == FAILURE)
2870     return FAILURE;
2871
2872   return SUCCESS;
2873 }
2874
2875 try
2876 gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
2877 {
2878   if (scalar_check (time, 0) == FAILURE)
2879     return FAILURE;
2880
2881   if (type_check (time, 0, BT_INTEGER) == FAILURE)
2882     return FAILURE;
2883
2884   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
2885     return FAILURE;
2886
2887   return SUCCESS;
2888 }
2889
2890 try
2891 gfc_check_etime (gfc_expr * x)
2892 {
2893   if (array_check (x, 0) == FAILURE)
2894     return FAILURE;
2895
2896   if (rank_check (x, 0, 1) == FAILURE)
2897     return FAILURE;
2898
2899   if (variable_check (x, 0) == FAILURE)
2900     return FAILURE;
2901
2902   if (type_check (x, 0, BT_REAL) == FAILURE)
2903     return FAILURE;
2904
2905   if (kind_value_check(x, 0, 4) == FAILURE)
2906     return FAILURE;
2907
2908   return SUCCESS;
2909 }
2910
2911 try
2912 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2913 {
2914   if (array_check (values, 0) == FAILURE)
2915     return FAILURE;
2916
2917   if (rank_check (values, 0, 1) == FAILURE)
2918     return FAILURE;
2919
2920   if (variable_check (values, 0) == FAILURE)
2921     return FAILURE;
2922
2923   if (type_check (values, 0, BT_REAL) == FAILURE)
2924     return FAILURE;
2925
2926   if (kind_value_check(values, 0, 4) == FAILURE)
2927     return FAILURE;
2928
2929   if (scalar_check (time, 1) == FAILURE)
2930     return FAILURE;
2931
2932   if (type_check (time, 1, BT_REAL) == FAILURE)
2933     return FAILURE;
2934
2935   if (kind_value_check(time, 1, 4) == FAILURE)
2936     return FAILURE;
2937
2938   return SUCCESS;
2939 }
2940
2941
2942 try
2943 gfc_check_fdate_sub (gfc_expr * date)
2944 {
2945   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2946     return FAILURE;
2947
2948   return SUCCESS;
2949 }
2950
2951
2952 try
2953 gfc_check_gerror (gfc_expr * msg)
2954 {
2955   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2956     return FAILURE;
2957
2958   return SUCCESS;
2959 }
2960
2961
2962 try
2963 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2964 {
2965   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2966     return FAILURE;
2967
2968   if (status == NULL)
2969     return SUCCESS;
2970
2971   if (scalar_check (status, 1) == FAILURE)
2972     return FAILURE;
2973
2974   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2975     return FAILURE;
2976
2977   return SUCCESS;
2978 }
2979
2980
2981 try
2982 gfc_check_getlog (gfc_expr * msg)
2983 {
2984   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2985     return FAILURE;
2986
2987   return SUCCESS;
2988 }
2989
2990
2991 try
2992 gfc_check_exit (gfc_expr * status)
2993 {
2994   if (status == NULL)
2995     return SUCCESS;
2996
2997   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2998     return FAILURE;
2999
3000   if (scalar_check (status, 0) == FAILURE)
3001     return FAILURE;
3002
3003   return SUCCESS;
3004 }
3005
3006
3007 try
3008 gfc_check_flush (gfc_expr * unit)
3009 {
3010   if (unit == NULL)
3011     return SUCCESS;
3012
3013   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3014     return FAILURE;
3015
3016   if (scalar_check (unit, 0) == FAILURE)
3017     return FAILURE;
3018
3019   return SUCCESS;
3020 }
3021
3022
3023 try
3024 gfc_check_free (gfc_expr * i)
3025 {
3026   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3027     return FAILURE;
3028
3029   if (scalar_check (i, 0) == FAILURE)
3030     return FAILURE;
3031
3032   return SUCCESS;
3033 }
3034
3035
3036 try
3037 gfc_check_hostnm (gfc_expr * name)
3038 {
3039   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3040     return FAILURE;
3041
3042   return SUCCESS;
3043 }
3044
3045
3046 try
3047 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
3048 {
3049   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3050     return FAILURE;
3051
3052   if (status == NULL)
3053     return SUCCESS;
3054
3055   if (scalar_check (status, 1) == FAILURE)
3056     return FAILURE;
3057
3058   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3059     return FAILURE;
3060
3061   return SUCCESS;
3062 }
3063
3064
3065 try
3066 gfc_check_itime_idate (gfc_expr * values)
3067 {
3068   if (array_check (values, 0) == FAILURE)
3069     return FAILURE;
3070
3071   if (rank_check (values, 0, 1) == FAILURE)
3072     return FAILURE;
3073
3074   if (variable_check (values, 0) == FAILURE)
3075     return FAILURE;
3076
3077   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3078     return FAILURE;
3079
3080   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3081     return FAILURE;
3082
3083   return SUCCESS;
3084 }
3085
3086
3087 try
3088 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
3089 {
3090   if (scalar_check (unit, 0) == FAILURE)
3091     return FAILURE;
3092
3093   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3094     return FAILURE;
3095
3096   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3097     return FAILURE;
3098
3099   return SUCCESS;
3100 }
3101
3102
3103 try
3104 gfc_check_isatty (gfc_expr * unit)
3105 {
3106   if (unit == NULL)
3107     return FAILURE;
3108
3109   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3110     return FAILURE;
3111
3112   if (scalar_check (unit, 0) == FAILURE)
3113     return FAILURE;
3114
3115   return SUCCESS;
3116 }
3117
3118
3119 try
3120 gfc_check_perror (gfc_expr * string)
3121 {
3122   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3123     return FAILURE;
3124
3125   return SUCCESS;
3126 }
3127
3128
3129 try
3130 gfc_check_umask (gfc_expr * mask)
3131 {
3132   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3133     return FAILURE;
3134
3135   if (scalar_check (mask, 0) == FAILURE)
3136     return FAILURE;
3137
3138   return SUCCESS;
3139 }
3140
3141
3142 try
3143 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
3144 {
3145   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3146     return FAILURE;
3147
3148   if (scalar_check (mask, 0) == FAILURE)
3149     return FAILURE;
3150
3151   if (old == NULL)
3152     return SUCCESS;
3153
3154   if (scalar_check (old, 1) == FAILURE)
3155     return FAILURE;
3156
3157   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3158     return FAILURE;
3159
3160   return SUCCESS;
3161 }
3162
3163
3164 try
3165 gfc_check_unlink (gfc_expr * name)
3166 {
3167   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3168     return FAILURE;
3169
3170   return SUCCESS;
3171 }
3172
3173
3174 try
3175 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
3176 {
3177   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3178     return FAILURE;
3179
3180   if (status == NULL)
3181     return SUCCESS;
3182
3183   if (scalar_check (status, 1) == FAILURE)
3184     return FAILURE;
3185
3186   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3187     return FAILURE;
3188
3189   return SUCCESS;
3190 }
3191
3192
3193 try
3194 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
3195 {
3196   if (scalar_check (number, 0) == FAILURE)
3197     return FAILURE;
3198
3199   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3200     return FAILURE;
3201
3202   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3203     {
3204       gfc_error (
3205         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3206         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3207       return FAILURE;
3208     }
3209
3210   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3211     return FAILURE;
3212
3213   return SUCCESS;
3214 }
3215
3216
3217 try
3218 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
3219 {
3220   if (scalar_check (number, 0) == FAILURE)
3221     return FAILURE;
3222
3223   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3224     return FAILURE;
3225
3226   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3227     {
3228       gfc_error (
3229         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3230         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3231       return FAILURE;
3232     }
3233
3234   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3235     return FAILURE;
3236
3237   if (status == NULL)
3238     return SUCCESS;
3239
3240   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3241     return FAILURE;
3242
3243   if (scalar_check (status, 2) == FAILURE)
3244     return FAILURE;
3245
3246   return SUCCESS;
3247 }
3248
3249
3250 try
3251 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
3252 {
3253   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3254     return FAILURE;
3255
3256   if (scalar_check (status, 1) == FAILURE)
3257     return FAILURE;
3258
3259   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3260     return FAILURE;
3261
3262   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3263     return FAILURE;
3264
3265   return SUCCESS;
3266 }
3267
3268
3269 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3270 try
3271 gfc_check_and (gfc_expr * i, gfc_expr * j)
3272 {
3273   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3274     {
3275       gfc_error (
3276         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3277         gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
3278       return FAILURE;
3279     }
3280
3281   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3282     {
3283       gfc_error (
3284         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3285         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
3286       return FAILURE;
3287     }
3288
3289   if (i->ts.type != j->ts.type)
3290     {
3291       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3292                  "have the same type", gfc_current_intrinsic_arg[0],
3293                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3294                  &j->where);
3295       return FAILURE;
3296     }
3297
3298   if (scalar_check (i, 0) == FAILURE)
3299     return FAILURE;
3300
3301   if (scalar_check (j, 1) == FAILURE)
3302     return FAILURE;
3303
3304   return SUCCESS;
3305 }