gcc/fortran/check.c

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