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_ichar_iachar (gfc_expr * c)
 926 {
 927   int i;
 928
 929   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
 930     return FAILURE;
 931
 932   /* Check that the argument is length one.  Non-constant lengths
 933      can't be checked here, so assume thay are ok.  */
 934   if (c->ts.cl && c->ts.cl->length)
 935     {
 936       /* If we already have a length for this expression then use it.  */
 937       if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
 938         return SUCCESS;
 939       i = mpz_get_si (c->ts.cl->length->value.integer);
 940     }
 941   else if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
 942     {
 943       gfc_expr *start;
 944       gfc_expr *end;
 945       gfc_ref *ref;
 946
 947       /* Substring references don't have the charlength set.  */
 948       ref = c->ref;
 949       while (ref && ref->type != REF_SUBSTRING)
 950         ref = ref->next;
 951
 952       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
 953
 954       if (!ref)
 955         return SUCCESS;
 956
 957       start = ref->u.ss.start;
 958       end = ref->u.ss.end;
 959
 960       gcc_assert (start);
 961       if (end == NULL || end->expr_type != EXPR_CONSTANT
 962           || start->expr_type != EXPR_CONSTANT)
 963         return SUCCESS;
 964
 965       i = mpz_get_si (end->value.integer) + 1
 966           - mpz_get_si (start->value.integer);
 967     }
 968   else
 969     return SUCCESS;
 970
 971   if (i != 1)
 972     {
 973       gfc_error ("Argument of %s at %L must be of length one",
 974                  gfc_current_intrinsic, &c->where);
 975       return FAILURE;
 976     }
 977
 978   return SUCCESS;
 979 }
 980
 981
 982 try
 983 gfc_check_idnint (gfc_expr * a)
 984 {
 985   if (double_check (a, 0) == FAILURE)
 986     return FAILURE;
 987
 988   return SUCCESS;
 989 }
 990
 991
 992 try
 993 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
 994 {
 995   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 996     return FAILURE;
 997
 998   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 999     return FAILURE;
1000
1001   if (i->ts.kind != j->ts.kind)
1002     {
1003       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1004                           &i->where) == FAILURE)
1005         return FAILURE;
1006     }
1007
1008   return SUCCESS;
1009 }
1010
1011
1012 try
1013 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
1014 {
1015   if (type_check (string, 0, BT_CHARACTER) == FAILURE
1016       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1017     return FAILURE;
1018
1019
1020   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1021     return FAILURE;
1022
1023   if (string->ts.kind != substring->ts.kind)
1024     {
1025       must_be (substring, 1, "the same kind as 'string'");
1026       return FAILURE;
1027     }
1028
1029   return SUCCESS;
1030 }
1031
1032
1033 try
1034 gfc_check_int (gfc_expr * x, gfc_expr * kind)
1035 {
1036   if (numeric_check (x, 0) == FAILURE)
1037     return FAILURE;
1038
1039   if (kind != NULL)
1040     {
1041       if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1042     return FAILURE;
1043
1044       if (scalar_check (kind, 1) == FAILURE)
1045         return FAILURE;
1046     }
1047
1048   return SUCCESS;
1049 }
1050
1051
1052 try
1053 gfc_check_ior (gfc_expr * i, gfc_expr * j)
1054 {
1055   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1056     return FAILURE;
1057
1058   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1059     return FAILURE;
1060
1061   if (i->ts.kind != j->ts.kind)
1062     {
1063       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1064                           &i->where) == FAILURE)
1065     return FAILURE;
1066     }
1067
1068   return SUCCESS;
1069 }
1070
1071
1072 try
1073 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
1074 {
1075   if (type_check (i, 0, BT_INTEGER) == FAILURE
1076       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1077     return FAILURE;
1078
1079   return SUCCESS;
1080 }
1081
1082
1083 try
1084 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
1085 {
1086   if (type_check (i, 0, BT_INTEGER) == FAILURE
1087       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1088     return FAILURE;
1089
1090   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1091     return FAILURE;
1092
1093   return SUCCESS;
1094 }
1095
1096
1097 try
1098 gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
1099 {
1100   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1101     return FAILURE;
1102
1103   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1104     return FAILURE;
1105
1106   return SUCCESS;
1107 }
1108
1109
1110 try
1111 gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
1112 {
1113   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1114     return FAILURE;
1115
1116   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1117     return FAILURE;
1118
1119   if (status == NULL)
1120     return SUCCESS;
1121
1122   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1123     return FAILURE;
1124
1125   if (scalar_check (status, 2) == FAILURE)
1126     return FAILURE;
1127
1128   return SUCCESS;
1129 }
1130
1131
1132 try
1133 gfc_check_kind (gfc_expr * x)
1134 {
1135   if (x->ts.type == BT_DERIVED)
1136     {
1137       must_be (x, 0, "a non-derived type");
1138       return FAILURE;
1139     }
1140
1141   return SUCCESS;
1142 }
1143
1144
1145 try
1146 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1147 {
1148   if (array_check (array, 0) == FAILURE)
1149     return FAILURE;
1150
1151   if (dim != NULL)
1152     {
1153       if (dim_check (dim, 1, 1) == FAILURE)
1154         return FAILURE;
1155
1156       if (dim_rank_check (dim, array, 1) == FAILURE)
1157         return FAILURE;
1158     }
1159   return SUCCESS;
1160 }
1161
1162
1163 try
1164 gfc_check_link (gfc_expr * path1, gfc_expr * path2)
1165 {
1166   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1167     return FAILURE;
1168
1169   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1170     return FAILURE;
1171
1172   return SUCCESS;
1173 }
1174
1175
1176 try
1177 gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1178 {
1179   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1180     return FAILURE;
1181
1182   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1183     return FAILURE;
1184
1185   if (status == NULL)
1186     return SUCCESS;
1187
1188   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1189     return FAILURE;
1190
1191   if (scalar_check (status, 2) == FAILURE)
1192     return FAILURE;
1193
1194   return SUCCESS;
1195 }
1196
1197
1198 try
1199 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
1200 {
1201   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1202     return FAILURE;
1203
1204   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1205     return FAILURE;
1206
1207   return SUCCESS;
1208 }
1209
1210
1211 try
1212 gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1213 {
1214   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1215     return FAILURE;
1216
1217   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1218     return FAILURE;
1219
1220   if (status == NULL)
1221     return SUCCESS;
1222
1223   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1224     return FAILURE;
1225
1226   if (scalar_check (status, 2) == FAILURE)
1227     return FAILURE;
1228
1229   return SUCCESS;
1230 }
1231
1232
1233 try
1234 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1235 {
1236   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1237     return FAILURE;
1238   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1239     return FAILURE;
1240
1241   return SUCCESS;
1242 }
1243
1244
1245 /* Min/max family.  */
1246
1247 static try
1248 min_max_args (gfc_actual_arglist * arg)
1249 {
1250   if (arg == NULL || arg->next == NULL)
1251     {
1252       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1253                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1254       return FAILURE;
1255     }
1256
1257   return SUCCESS;
1258 }
1259
1260
1261 static try
1262 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1263 {
1264   gfc_expr *x;
1265   int n;
1266
1267   if (min_max_args (arg) == FAILURE)
1268     return FAILURE;
1269
1270   n = 1;
1271
1272   for (; arg; arg = arg->next, n++)
1273     {
1274       x = arg->expr;
1275       if (x->ts.type != type || x->ts.kind != kind)
1276         {
1277           if (x->ts.type == type)
1278             {
1279               if (gfc_notify_std (GFC_STD_GNU,
1280                     "Extension: Different type kinds at %L", &x->where)
1281                   == FAILURE)
1282                 return FAILURE;
1283             }
1284           else
1285             {
1286               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1287                          n, gfc_current_intrinsic, &x->where,
1288                          gfc_basic_typename (type), kind);
1289               return FAILURE;
1290             }
1291         }
1292     }
1293
1294   return SUCCESS;
1295 }
1296
1297
1298 try
1299 gfc_check_min_max (gfc_actual_arglist * arg)
1300 {
1301   gfc_expr *x;
1302
1303   if (min_max_args (arg) == FAILURE)
1304     return FAILURE;
1305
1306   x = arg->expr;
1307
1308   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1309     {
1310       gfc_error
1311         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1312          gfc_current_intrinsic, &x->where);
1313       return FAILURE;
1314     }
1315
1316   return check_rest (x->ts.type, x->ts.kind, arg);
1317 }
1318
1319
1320 try
1321 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1322 {
1323   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1324 }
1325
1326
1327 try
1328 gfc_check_min_max_real (gfc_actual_arglist * arg)
1329 {
1330   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1331 }
1332
1333
1334 try
1335 gfc_check_min_max_double (gfc_actual_arglist * arg)
1336 {
1337   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1338 }
1339
1340 /* End of min/max family.  */
1341
1342
1343 try
1344 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1345 {
1346   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1347     {
1348       must_be (matrix_a, 0, "numeric or LOGICAL");
1349       return FAILURE;
1350     }
1351
1352   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1353     {
1354       must_be (matrix_b, 0, "numeric or LOGICAL");
1355       return FAILURE;
1356     }
1357
1358   switch (matrix_a->rank)
1359     {
1360     case 1:
1361       if (rank_check (matrix_b, 1, 2) == FAILURE)
1362         return FAILURE;
1363       break;
1364
1365     case 2:
1366       if (matrix_b->rank == 2)
1367         break;
1368       if (rank_check (matrix_b, 1, 1) == FAILURE)
1369         return FAILURE;
1370       break;
1371
1372     default:
1373       must_be (matrix_a, 0, "of rank 1 or 2");
1374       return FAILURE;
1375     }
1376
1377   return SUCCESS;
1378 }
1379
1380
1381 /* Whoever came up with this interface was probably on something.
1382    The possibilities for the occupation of the second and third
1383    parameters are:
1384
1385          Arg #2     Arg #3
1386          NULL       NULL
1387          DIM        NULL
1388          MASK       NULL
1389          NULL       MASK             minloc(array, mask=m)
1390          DIM        MASK
1391
1392    I.e. in the case of minloc(array,mask), mask will be in the second
1393    position of the argument list and we'll have to fix that up.  */
1394
1395 try
1396 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1397 {
1398   gfc_expr *a, *m, *d;
1399
1400   a = ap->expr;
1401   if (int_or_real_check (a, 0) == FAILURE
1402       || array_check (a, 0) == FAILURE)
1403     return FAILURE;
1404
1405   d = ap->next->expr;
1406   m = ap->next->next->expr;
1407
1408   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1409       && ap->next->name == NULL)
1410     {
1411       m = d;
1412       d = NULL;
1413
1414       ap->next->expr = NULL;
1415       ap->next->next->expr = m;
1416     }
1417
1418   if (d != NULL
1419       && (scalar_check (d, 1) == FAILURE
1420       || type_check (d, 1, BT_INTEGER) == FAILURE))
1421     return FAILURE;
1422
1423   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1424     return FAILURE;
1425
1426   return SUCCESS;
1427 }
1428
1429
1430 /* Similar to minloc/maxloc, the argument list might need to be
1431    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1432    difference is that MINLOC/MAXLOC take an additional KIND argument.
1433    The possibilities are:
1434
1435          Arg #2     Arg #3
1436          NULL       NULL
1437          DIM        NULL
1438          MASK       NULL
1439          NULL       MASK             minval(array, mask=m)
1440          DIM        MASK
1441
1442    I.e. in the case of minval(array,mask), mask will be in the second
1443    position of the argument list and we'll have to fix that up.  */
1444
1445 static try
1446 check_reduction (gfc_actual_arglist * ap)
1447 {
1448   gfc_expr *m, *d;
1449
1450   d = ap->next->expr;
1451   m = ap->next->next->expr;
1452
1453   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1454       && ap->next->name == NULL)
1455     {
1456       m = d;
1457       d = NULL;
1458
1459       ap->next->expr = NULL;
1460       ap->next->next->expr = m;
1461     }
1462
1463   if (d != NULL
1464       && (scalar_check (d, 1) == FAILURE
1465       || type_check (d, 1, BT_INTEGER) == FAILURE))
1466     return FAILURE;
1467
1468   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1469     return FAILURE;
1470
1471   return SUCCESS;
1472 }
1473
1474
1475 try
1476 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1477 {
1478   if (int_or_real_check (ap->expr, 0) == FAILURE
1479       || array_check (ap->expr, 0) == FAILURE)
1480     return FAILURE;
1481
1482   return check_reduction (ap);
1483 }
1484
1485
1486 try
1487 gfc_check_product_sum (gfc_actual_arglist * ap)
1488 {
1489   if (numeric_check (ap->expr, 0) == FAILURE
1490       || array_check (ap->expr, 0) == FAILURE)
1491     return FAILURE;
1492
1493   return check_reduction (ap);
1494 }
1495
1496
1497 try
1498 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1499 {
1500   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1501     return FAILURE;
1502
1503   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1504     return FAILURE;
1505
1506   return SUCCESS;
1507 }
1508
1509
1510 try
1511 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1512 {
1513   if (type_check (x, 0, BT_REAL) == FAILURE)
1514     return FAILURE;
1515
1516   if (type_check (s, 1, BT_REAL) == FAILURE)
1517     return FAILURE;
1518
1519   return SUCCESS;
1520 }
1521
1522
1523 try
1524 gfc_check_null (gfc_expr * mold)
1525 {
1526   symbol_attribute attr;
1527
1528   if (mold == NULL)
1529     return SUCCESS;
1530
1531   if (variable_check (mold, 0) == FAILURE)
1532     return FAILURE;
1533
1534   attr = gfc_variable_attr (mold, NULL);
1535
1536   if (!attr.pointer)
1537     {
1538       must_be (mold, 0, "a POINTER");
1539       return FAILURE;
1540     }
1541
1542   return SUCCESS;
1543 }
1544
1545
1546 try
1547 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1548 {
1549   if (array_check (array, 0) == FAILURE)
1550     return FAILURE;
1551
1552   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1553     return FAILURE;
1554
1555   if (mask->rank != 0 && mask->rank != array->rank)
1556     {
1557       must_be (array, 0, "conformable with 'mask' argument");
1558       return FAILURE;
1559     }
1560
1561   if (vector != NULL)
1562     {
1563       if (same_type_check (array, 0, vector, 2) == FAILURE)
1564         return FAILURE;
1565
1566       if (rank_check (vector, 2, 1) == FAILURE)
1567         return FAILURE;
1568
1569       /* TODO: More constraints here.  */
1570     }
1571
1572   return SUCCESS;
1573 }
1574
1575
1576 try
1577 gfc_check_precision (gfc_expr * x)
1578 {
1579   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1580     {
1581       must_be (x, 0, "of type REAL or COMPLEX");
1582       return FAILURE;
1583     }
1584
1585   return SUCCESS;
1586 }
1587
1588
1589 try
1590 gfc_check_present (gfc_expr * a)
1591 {
1592   gfc_symbol *sym;
1593
1594   if (variable_check (a, 0) == FAILURE)
1595     return FAILURE;
1596
1597   sym = a->symtree->n.sym;
1598   if (!sym->attr.dummy)
1599     {
1600       must_be (a, 0, "a dummy variable");
1601       return FAILURE;
1602     }
1603
1604   if (!sym->attr.optional)
1605     {
1606       must_be (a, 0, "an OPTIONAL dummy variable");
1607       return FAILURE;
1608     }
1609
1610   return SUCCESS;
1611 }
1612
1613
1614 try
1615 gfc_check_radix (gfc_expr * x)
1616 {
1617   if (int_or_real_check (x, 0) == FAILURE)
1618     return FAILURE;
1619
1620   return SUCCESS;
1621 }
1622
1623
1624 try
1625 gfc_check_range (gfc_expr * x)
1626 {
1627   if (numeric_check (x, 0) == FAILURE)
1628     return FAILURE;
1629
1630   return SUCCESS;
1631 }
1632
1633
1634 /* real, float, sngl.  */
1635 try
1636 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1637 {
1638   if (numeric_check (a, 0) == FAILURE)
1639     return FAILURE;
1640
1641   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1642     return FAILURE;
1643
1644   return SUCCESS;
1645 }
1646
1647
1648 try
1649 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
1650 {
1651   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1652     return FAILURE;
1653
1654   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1655     return FAILURE;
1656
1657   return SUCCESS;
1658 }
1659
1660
1661 try
1662 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1663 {
1664   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1665     return FAILURE;
1666
1667   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1668     return FAILURE;
1669
1670   if (status == NULL)
1671     return SUCCESS;
1672
1673   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1674     return FAILURE;
1675
1676   if (scalar_check (status, 2) == FAILURE)
1677     return FAILURE;
1678
1679   return SUCCESS;
1680 }
1681
1682
1683 try
1684 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1685 {
1686   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1687     return FAILURE;
1688
1689   if (scalar_check (x, 0) == FAILURE)
1690     return FAILURE;
1691
1692   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1693     return FAILURE;
1694
1695   if (scalar_check (y, 1) == FAILURE)
1696     return FAILURE;
1697
1698   return SUCCESS;
1699 }
1700
1701
1702 try
1703 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1704                    gfc_expr * pad, gfc_expr * order)
1705 {
1706   mpz_t size;
1707   int m;
1708
1709   if (array_check (source, 0) == FAILURE)
1710     return FAILURE;
1711
1712   if (rank_check (shape, 1, 1) == FAILURE)
1713     return FAILURE;
1714
1715   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1716     return FAILURE;
1717
1718   if (gfc_array_size (shape, &size) != SUCCESS)
1719     {
1720       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1721                  "array of constant size", &shape->where);
1722       return FAILURE;
1723     }
1724
1725   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1726   mpz_clear (size);
1727
1728   if (m > 0)
1729     {
1730       gfc_error
1731         ("'shape' argument of 'reshape' intrinsic at %L has more than "
1732          stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1733       return FAILURE;
1734     }
1735
1736   if (pad != NULL)
1737     {
1738       if (same_type_check (source, 0, pad, 2) == FAILURE)
1739         return FAILURE;
1740       if (array_check (pad, 2) == FAILURE)
1741         return FAILURE;
1742     }
1743
1744   if (order != NULL && array_check (order, 3) == FAILURE)
1745     return FAILURE;
1746
1747   return SUCCESS;
1748 }
1749
1750
1751 try
1752 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1753 {
1754   if (type_check (x, 0, BT_REAL) == FAILURE)
1755     return FAILURE;
1756
1757   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1758     return FAILURE;
1759
1760   return SUCCESS;
1761 }
1762
1763
1764 try
1765 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1766 {
1767   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1768     return FAILURE;
1769
1770   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1771     return FAILURE;
1772
1773   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1774     return FAILURE;
1775
1776   if (same_type_check (x, 0, y, 1) == FAILURE)
1777     return FAILURE;
1778
1779   return SUCCESS;
1780 }
1781
1782
1783 try
1784 gfc_check_selected_int_kind (gfc_expr * r)
1785 {
1786
1787   if (type_check (r, 0, BT_INTEGER) == FAILURE)
1788     return FAILURE;
1789
1790   if (scalar_check (r, 0) == FAILURE)
1791     return FAILURE;
1792
1793   return SUCCESS;
1794 }
1795
1796
1797 try
1798 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1799 {
1800   if (p == NULL && r == NULL)
1801     {
1802       gfc_error ("Missing arguments to %s intrinsic at %L",
1803                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1804
1805       return FAILURE;
1806     }
1807
1808   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1809     return FAILURE;
1810
1811   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1812     return FAILURE;
1813
1814   return SUCCESS;
1815 }
1816
1817
1818 try
1819 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1820 {
1821   if (type_check (x, 0, BT_REAL) == FAILURE)
1822     return FAILURE;
1823
1824   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1825     return FAILURE;
1826
1827   return SUCCESS;
1828 }
1829
1830
1831 try
1832 gfc_check_shape (gfc_expr * source)
1833 {
1834   gfc_array_ref *ar;
1835
1836   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1837     return SUCCESS;
1838
1839   ar = gfc_find_array_ref (source);
1840
1841   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1842     {
1843       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1844                  "an assumed size array", &source->where);
1845       return FAILURE;
1846     }
1847
1848   return SUCCESS;
1849 }
1850
1851
1852 try
1853 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1854 {
1855   if (int_or_real_check (a, 0) == FAILURE)
1856     return FAILURE;
1857
1858   if (same_type_check (a, 0, b, 1) == FAILURE)
1859     return FAILURE;
1860
1861   return SUCCESS;
1862 }
1863
1864
1865 try
1866 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1867 {
1868   if (array_check (array, 0) == FAILURE)
1869     return FAILURE;
1870
1871   if (dim != NULL)
1872     {
1873       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1874         return FAILURE;
1875
1876       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1877         return FAILURE;
1878
1879       if (dim_rank_check (dim, array, 0) == FAILURE)
1880         return FAILURE;
1881     }
1882
1883   return SUCCESS;
1884 }
1885
1886
1887 try
1888 gfc_check_sleep_sub (gfc_expr * seconds)
1889 {
1890   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
1891     return FAILURE;
1892
1893   if (scalar_check (seconds, 0) == FAILURE)
1894     return FAILURE;
1895
1896   return SUCCESS;
1897 }
1898
1899
1900 try
1901 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1902 {
1903   if (source->rank >= GFC_MAX_DIMENSIONS)
1904     {
1905       must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1906       return FAILURE;
1907     }
1908
1909   if (dim_check (dim, 1, 0) == FAILURE)
1910     return FAILURE;
1911
1912   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1913     return FAILURE;
1914
1915   if (scalar_check (ncopies, 2) == FAILURE)
1916     return FAILURE;
1917
1918   return SUCCESS;
1919 }
1920
1921
1922 try
1923 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
1924 {
1925   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1926     return FAILURE;
1927
1928   if (scalar_check (unit, 0) == FAILURE)
1929     return FAILURE;
1930
1931   if (type_check (array, 1, BT_INTEGER) == FAILURE
1932       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
1933     return FAILURE;
1934
1935   if (array_check (array, 1) == FAILURE)
1936     return FAILURE;
1937
1938   return SUCCESS;
1939 }
1940
1941
1942 try
1943 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
1944 {
1945   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1946     return FAILURE;
1947
1948   if (scalar_check (unit, 0) == FAILURE)
1949     return FAILURE;
1950
1951   if (type_check (array, 1, BT_INTEGER) == FAILURE
1952       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1953     return FAILURE;
1954
1955   if (array_check (array, 1) == FAILURE)
1956     return FAILURE;
1957
1958   if (status == NULL)
1959     return SUCCESS;
1960
1961   if (type_check (status, 2, BT_INTEGER) == FAILURE
1962       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
1963     return FAILURE;
1964
1965   if (scalar_check (status, 2) == FAILURE)
1966     return FAILURE;
1967
1968   return SUCCESS;
1969 }
1970
1971
1972 try
1973 gfc_check_stat (gfc_expr * name, gfc_expr * array)
1974 {
1975   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1976     return FAILURE;
1977
1978   if (type_check (array, 1, BT_INTEGER) == FAILURE
1979       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1980     return FAILURE;
1981
1982   if (array_check (array, 1) == FAILURE)
1983     return FAILURE;
1984
1985   return SUCCESS;
1986 }
1987
1988
1989 try
1990 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
1991 {
1992   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1993     return FAILURE;
1994
1995   if (type_check (array, 1, BT_INTEGER) == FAILURE
1996       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1997     return FAILURE;
1998
1999   if (array_check (array, 1) == FAILURE)
2000     return FAILURE;
2001
2002   if (status == NULL)
2003     return SUCCESS;
2004
2005   if (type_check (status, 2, BT_INTEGER) == FAILURE
2006       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2007     return FAILURE;
2008
2009   if (scalar_check (status, 2) == FAILURE)
2010     return FAILURE;
2011
2012   return SUCCESS;
2013 }
2014
2015
2016 try
2017 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2018                     gfc_expr * mold ATTRIBUTE_UNUSED,
2019                     gfc_expr * size)
2020 {
2021   if (size != NULL)
2022     {
2023       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2024         return FAILURE;
2025
2026       if (scalar_check (size, 2) == FAILURE)
2027         return FAILURE;
2028
2029       if (nonoptional_check (size, 2) == FAILURE)
2030         return FAILURE;
2031     }
2032
2033   return SUCCESS;
2034 }
2035
2036
2037 try
2038 gfc_check_transpose (gfc_expr * matrix)
2039 {
2040   if (rank_check (matrix, 0, 2) == FAILURE)
2041     return FAILURE;
2042
2043   return SUCCESS;
2044 }
2045
2046
2047 try
2048 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2049 {
2050   if (array_check (array, 0) == FAILURE)
2051     return FAILURE;
2052
2053   if (dim != NULL)
2054     {
2055       if (dim_check (dim, 1, 1) == FAILURE)
2056         return FAILURE;
2057
2058       if (dim_rank_check (dim, array, 0) == FAILURE)
2059         return FAILURE;
2060     }
2061
2062   return SUCCESS;
2063 }
2064
2065
2066 try
2067 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2068 {
2069   if (rank_check (vector, 0, 1) == FAILURE)
2070     return FAILURE;
2071
2072   if (array_check (mask, 1) == FAILURE)
2073     return FAILURE;
2074
2075   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2076     return FAILURE;
2077
2078   if (same_type_check (vector, 0, field, 2) == FAILURE)
2079     return FAILURE;
2080
2081   return SUCCESS;
2082 }
2083
2084
2085 try
2086 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2087 {
2088   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2089     return FAILURE;
2090
2091   if (same_type_check (x, 0, y, 1) == FAILURE)
2092     return FAILURE;
2093
2094   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2095     return FAILURE;
2096
2097   return SUCCESS;
2098 }
2099
2100
2101 try
2102 gfc_check_trim (gfc_expr * x)
2103 {
2104   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2105     return FAILURE;
2106
2107   if (scalar_check (x, 0) == FAILURE)
2108     return FAILURE;
2109
2110    return SUCCESS;
2111 }
2112
2113
2114 /* Common check function for the half a dozen intrinsics that have a
2115    single real argument.  */
2116
2117 try
2118 gfc_check_x (gfc_expr * x)
2119 {
2120   if (type_check (x, 0, BT_REAL) == FAILURE)
2121     return FAILURE;
2122
2123   return SUCCESS;
2124 }
2125
2126
2127 /************* Check functions for intrinsic subroutines *************/
2128
2129 try
2130 gfc_check_cpu_time (gfc_expr * time)
2131 {
2132   if (scalar_check (time, 0) == FAILURE)
2133     return FAILURE;
2134
2135   if (type_check (time, 0, BT_REAL) == FAILURE)
2136     return FAILURE;
2137
2138   if (variable_check (time, 0) == FAILURE)
2139     return FAILURE;
2140
2141   return SUCCESS;
2142 }
2143
2144
2145 try
2146 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2147                          gfc_expr * zone, gfc_expr * values)
2148 {
2149   if (date != NULL)
2150     {
2151       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2152         return FAILURE;
2153       if (scalar_check (date, 0) == FAILURE)
2154         return FAILURE;
2155       if (variable_check (date, 0) == FAILURE)
2156         return FAILURE;
2157     }
2158
2159   if (time != NULL)
2160     {
2161       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2162         return FAILURE;
2163       if (scalar_check (time, 1) == FAILURE)
2164         return FAILURE;
2165       if (variable_check (time, 1) == FAILURE)
2166         return FAILURE;
2167     }
2168
2169   if (zone != NULL)
2170     {
2171       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2172         return FAILURE;
2173       if (scalar_check (zone, 2) == FAILURE)
2174         return FAILURE;
2175       if (variable_check (zone, 2) == FAILURE)
2176         return FAILURE;
2177     }
2178
2179   if (values != NULL)
2180     {
2181       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2182         return FAILURE;
2183       if (array_check (values, 3) == FAILURE)
2184         return FAILURE;
2185       if (rank_check (values, 3, 1) == FAILURE)
2186         return FAILURE;
2187       if (variable_check (values, 3) == FAILURE)
2188         return FAILURE;
2189     }
2190
2191   return SUCCESS;
2192 }
2193
2194
2195 try
2196 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2197                   gfc_expr * to, gfc_expr * topos)
2198 {
2199   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2200     return FAILURE;
2201
2202   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2203     return FAILURE;
2204
2205   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2206     return FAILURE;
2207
2208   if (same_type_check (from, 0, to, 3) == FAILURE)
2209     return FAILURE;
2210
2211   if (variable_check (to, 3) == FAILURE)
2212     return FAILURE;
2213
2214   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2215     return FAILURE;
2216
2217   return SUCCESS;
2218 }
2219
2220
2221 try
2222 gfc_check_random_number (gfc_expr * harvest)
2223 {
2224   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2225     return FAILURE;
2226
2227   if (variable_check (harvest, 0) == FAILURE)
2228     return FAILURE;
2229
2230   return SUCCESS;
2231 }
2232
2233
2234 try
2235 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2236 {
2237   if (size != NULL)
2238     {
2239       if (scalar_check (size, 0) == FAILURE)
2240         return FAILURE;
2241
2242       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2243         return FAILURE;
2244
2245       if (variable_check (size, 0) == FAILURE)
2246         return FAILURE;
2247
2248       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2249         return FAILURE;
2250     }
2251
2252   if (put != NULL)
2253     {
2254
2255       if (size != NULL)
2256         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2257                     &put->where);
2258
2259       if (array_check (put, 1) == FAILURE)
2260         return FAILURE;
2261
2262       if (rank_check (put, 1, 1) == FAILURE)
2263         return FAILURE;
2264
2265       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2266         return FAILURE;
2267
2268       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2269         return FAILURE;
2270     }
2271
2272   if (get != NULL)
2273     {
2274
2275       if (size != NULL || put != NULL)
2276         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2277                     &get->where);
2278
2279       if (array_check (get, 2) == FAILURE)
2280         return FAILURE;
2281
2282       if (rank_check (get, 2, 1) == FAILURE)
2283         return FAILURE;
2284
2285       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2286         return FAILURE;
2287
2288       if (variable_check (get, 2) == FAILURE)
2289         return FAILURE;
2290
2291       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2292         return FAILURE;
2293     }
2294
2295   return SUCCESS;
2296 }
2297
2298 try
2299 gfc_check_second_sub (gfc_expr * time)
2300 {
2301   if (scalar_check (time, 0) == FAILURE)
2302     return FAILURE;
2303
2304   if (type_check (time, 0, BT_REAL) == FAILURE)
2305     return FAILURE;
2306
2307   if (kind_value_check(time, 0, 4) == FAILURE)
2308     return FAILURE;
2309
2310   return SUCCESS;
2311 }
2312
2313
2314 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2315    count, count_rate, and count_max are all optional arguments */
2316
2317 try
2318 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2319                         gfc_expr * count_max)
2320 {
2321   if (count != NULL)
2322     {
2323       if (scalar_check (count, 0) == FAILURE)
2324         return FAILURE;
2325
2326       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2327         return FAILURE;
2328
2329       if (variable_check (count, 0) == FAILURE)
2330         return FAILURE;
2331     }
2332
2333   if (count_rate != NULL)
2334     {
2335       if (scalar_check (count_rate, 1) == FAILURE)
2336         return FAILURE;
2337
2338       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2339         return FAILURE;
2340
2341       if (variable_check (count_rate, 1) == FAILURE)
2342         return FAILURE;
2343
2344       if (count != NULL
2345           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2346         return FAILURE;
2347
2348     }
2349
2350   if (count_max != NULL)
2351     {
2352       if (scalar_check (count_max, 2) == FAILURE)
2353         return FAILURE;
2354
2355       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2356         return FAILURE;
2357
2358       if (variable_check (count_max, 2) == FAILURE)
2359         return FAILURE;
2360
2361       if (count != NULL
2362           && same_type_check (count, 0, count_max, 2) == FAILURE)
2363         return FAILURE;
2364
2365       if (count_rate != NULL
2366           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2367         return FAILURE;
2368     }
2369
2370   return SUCCESS;
2371 }
2372
2373 try
2374 gfc_check_irand (gfc_expr * x)
2375 {
2376   if (x == NULL)
2377     return SUCCESS;
2378
2379   if (scalar_check (x, 0) == FAILURE)
2380     return FAILURE;
2381
2382   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2383     return FAILURE;
2384
2385   if (kind_value_check(x, 0, 4) == FAILURE)
2386     return FAILURE;
2387
2388   return SUCCESS;
2389 }
2390
2391 try
2392 gfc_check_rand (gfc_expr * x)
2393 {
2394   if (x == NULL)
2395     return SUCCESS;
2396
2397   if (scalar_check (x, 0) == FAILURE)
2398     return FAILURE;
2399
2400   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2401     return FAILURE;
2402
2403   if (kind_value_check(x, 0, 4) == FAILURE)
2404     return FAILURE;
2405
2406   return SUCCESS;
2407 }
2408
2409 try
2410 gfc_check_srand (gfc_expr * x)
2411 {
2412   if (scalar_check (x, 0) == FAILURE)
2413     return FAILURE;
2414
2415   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2416     return FAILURE;
2417
2418   if (kind_value_check(x, 0, 4) == FAILURE)
2419     return FAILURE;
2420
2421   return SUCCESS;
2422 }
2423
2424 try
2425 gfc_check_etime (gfc_expr * x)
2426 {
2427   if (array_check (x, 0) == FAILURE)
2428     return FAILURE;
2429
2430   if (rank_check (x, 0, 1) == FAILURE)
2431     return FAILURE;
2432
2433   if (variable_check (x, 0) == FAILURE)
2434     return FAILURE;
2435
2436   if (type_check (x, 0, BT_REAL) == FAILURE)
2437     return FAILURE;
2438
2439   if (kind_value_check(x, 0, 4) == FAILURE)
2440     return FAILURE;
2441
2442   return SUCCESS;
2443 }
2444
2445 try
2446 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2447 {
2448   if (array_check (values, 0) == FAILURE)
2449     return FAILURE;
2450
2451   if (rank_check (values, 0, 1) == FAILURE)
2452     return FAILURE;
2453
2454   if (variable_check (values, 0) == FAILURE)
2455     return FAILURE;
2456
2457   if (type_check (values, 0, BT_REAL) == FAILURE)
2458     return FAILURE;
2459
2460   if (kind_value_check(values, 0, 4) == FAILURE)
2461     return FAILURE;
2462
2463   if (scalar_check (time, 1) == FAILURE)
2464     return FAILURE;
2465
2466   if (type_check (time, 1, BT_REAL) == FAILURE)
2467     return FAILURE;
2468
2469   if (kind_value_check(time, 1, 4) == FAILURE)
2470     return FAILURE;
2471
2472   return SUCCESS;
2473 }
2474
2475
2476 try
2477 gfc_check_gerror (gfc_expr * msg)
2478 {
2479   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2480     return FAILURE;
2481
2482   return SUCCESS;
2483 }
2484
2485
2486 try
2487 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2488 {
2489   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2490     return FAILURE;
2491
2492   if (status == NULL)
2493     return SUCCESS;
2494
2495   if (scalar_check (status, 1) == FAILURE)
2496     return FAILURE;
2497
2498   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2499     return FAILURE;
2500
2501   return SUCCESS;
2502 }
2503
2504
2505 try
2506 gfc_check_getlog (gfc_expr * msg)
2507 {
2508   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2509     return FAILURE;
2510
2511   return SUCCESS;
2512 }
2513
2514
2515 try
2516 gfc_check_exit (gfc_expr * status)
2517 {
2518   if (status == NULL)
2519     return SUCCESS;
2520
2521   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2522     return FAILURE;
2523
2524   if (scalar_check (status, 0) == FAILURE)
2525     return FAILURE;
2526
2527   return SUCCESS;
2528 }
2529
2530
2531 try
2532 gfc_check_flush (gfc_expr * unit)
2533 {
2534   if (unit == NULL)
2535     return SUCCESS;
2536
2537   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2538     return FAILURE;
2539
2540   if (scalar_check (unit, 0) == FAILURE)
2541     return FAILURE;
2542
2543   return SUCCESS;
2544 }
2545
2546
2547 try
2548 gfc_check_hostnm (gfc_expr * name)
2549 {
2550   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2551     return FAILURE;
2552
2553   return SUCCESS;
2554 }
2555
2556
2557 try
2558 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
2559 {
2560   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2561     return FAILURE;
2562
2563   if (status == NULL)
2564     return SUCCESS;
2565
2566   if (scalar_check (status, 1) == FAILURE)
2567     return FAILURE;
2568
2569   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2570     return FAILURE;
2571
2572   return SUCCESS;
2573 }
2574
2575
2576 try
2577 gfc_check_perror (gfc_expr * string)
2578 {
2579   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
2580     return FAILURE;
2581
2582   return SUCCESS;
2583 }
2584
2585
2586 try
2587 gfc_check_umask (gfc_expr * mask)
2588 {
2589   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2590     return FAILURE;
2591
2592   if (scalar_check (mask, 0) == FAILURE)
2593     return FAILURE;
2594
2595   return SUCCESS;
2596 }
2597
2598
2599 try
2600 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2601 {
2602   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2603     return FAILURE;
2604
2605   if (scalar_check (mask, 0) == FAILURE)
2606     return FAILURE;
2607
2608   if (old == NULL)
2609     return SUCCESS;
2610
2611   if (scalar_check (old, 1) == FAILURE)
2612     return FAILURE;
2613
2614   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2615     return FAILURE;
2616
2617   return SUCCESS;
2618 }
2619
2620
2621 try
2622 gfc_check_unlink (gfc_expr * name)
2623 {
2624   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2625     return FAILURE;
2626
2627   return SUCCESS;
2628 }
2629
2630
2631 try
2632 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2633 {
2634   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2635     return FAILURE;
2636
2637   if (status == NULL)
2638     return SUCCESS;
2639
2640   if (scalar_check (status, 1) == FAILURE)
2641     return FAILURE;
2642
2643   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2644     return FAILURE;
2645
2646   return SUCCESS;
2647 }
2648
2649
2650 try
2651 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2652 {
2653   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2654     return FAILURE;
2655
2656   if (scalar_check (status, 1) == FAILURE)
2657     return FAILURE;
2658
2659   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2660     return FAILURE;
2661
2662   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
2663     return FAILURE;
2664
2665   return SUCCESS;
2666 }