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_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 579 {
 580   if (numeric_check (x, 0) == FAILURE)
 581     return FAILURE;
 582
 583   if (y != NULL)
 584     {
 585       if (numeric_check (y, 1) == FAILURE)
 586         return FAILURE;
 587
 588       if (x->ts.type == BT_COMPLEX)
 589         {
 590           must_be (y, 1, "not be present if 'x' is COMPLEX");
 591           return FAILURE;
 592         }
 593     }
 594
 595   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 596     return FAILURE;
 597
 598   return SUCCESS;
 599 }
 600
 601
 602 try
 603 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
 604 {
 605   if (logical_array_check (mask, 0) == FAILURE)
 606     return FAILURE;
 607   if (dim_check (dim, 1, 1) == FAILURE)
 608     return FAILURE;
 609
 610   return SUCCESS;
 611 }
 612
 613
 614 try
 615 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
 616 {
 617   if (array_check (array, 0) == FAILURE)
 618     return FAILURE;
 619
 620   if (array->rank == 1)
 621     {
 622       if (scalar_check (shift, 1) == FAILURE)
 623         return FAILURE;
 624     }
 625   else
 626     {
 627       /* TODO: more requirements on shift parameter.  */
 628     }
 629
 630   if (dim_check (dim, 2, 1) == FAILURE)
 631     return FAILURE;
 632
 633   return SUCCESS;
 634 }
 635
 636
 637 try
 638 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 639 {
 640   if (numeric_check (x, 0) == FAILURE)
 641     return FAILURE;
 642
 643   if (y != NULL)
 644     {
 645       if (numeric_check (y, 1) == FAILURE)
 646         return FAILURE;
 647
 648       if (x->ts.type == BT_COMPLEX)
 649         {
 650           must_be (y, 1, "not be present if 'x' is COMPLEX");
 651           return FAILURE;
 652         }
 653     }
 654
 655   return SUCCESS;
 656 }
 657
 658
 659 try
 660 gfc_check_dble (gfc_expr * x)
 661 {
 662   if (numeric_check (x, 0) == FAILURE)
 663     return FAILURE;
 664
 665   return SUCCESS;
 666 }
 667
 668
 669 try
 670 gfc_check_digits (gfc_expr * x)
 671 {
 672   if (int_or_real_check (x, 0) == FAILURE)
 673     return FAILURE;
 674
 675   return SUCCESS;
 676 }
 677
 678
 679 try
 680 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
 681 {
 682   switch (vector_a->ts.type)
 683     {
 684     case BT_LOGICAL:
 685       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 686         return FAILURE;
 687       break;
 688
 689     case BT_INTEGER:
 690     case BT_REAL:
 691     case BT_COMPLEX:
 692       if (numeric_check (vector_b, 1) == FAILURE)
 693         return FAILURE;
 694       break;
 695
 696     default:
 697       must_be (vector_a, 0, "numeric or LOGICAL");
 698       return FAILURE;
 699     }
 700
 701   if (rank_check (vector_a, 0, 1) == FAILURE)
 702     return FAILURE;
 703
 704   if (rank_check (vector_b, 1, 1) == FAILURE)
 705     return FAILURE;
 706
 707   return SUCCESS;
 708 }
 709
 710
 711 try
 712 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
 713                    gfc_expr * dim)
 714 {
 715   if (array_check (array, 0) == FAILURE)
 716     return FAILURE;
 717
 718   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 719     return FAILURE;
 720
 721   if (array->rank == 1)
 722     {
 723       if (scalar_check (shift, 2) == FAILURE)
 724         return FAILURE;
 725     }
 726   else
 727     {
 728       /* TODO: more weird restrictions on shift.  */
 729     }
 730
 731   if (boundary != NULL)
 732     {
 733       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 734         return FAILURE;
 735
 736       /* TODO: more restrictions on boundary.  */
 737     }
 738
 739   if (dim_check (dim, 1, 1) == FAILURE)
 740     return FAILURE;
 741
 742   return SUCCESS;
 743 }
 744
 745
 746 /* A single complex argument.  */
 747
 748 try
 749 gfc_check_fn_c (gfc_expr * a)
 750 {
 751   if (type_check (a, 0, BT_COMPLEX) == FAILURE)
 752     return FAILURE;
 753
 754   return SUCCESS;
 755 }
 756
 757
 758 /* A single real argument.  */
 759
 760 try
 761 gfc_check_fn_r (gfc_expr * a)
 762 {
 763   if (type_check (a, 0, BT_REAL) == FAILURE)
 764     return FAILURE;
 765
 766   return SUCCESS;
 767 }
 768
 769
 770 /* A single real or complex argument.  */
 771
 772 try
 773 gfc_check_fn_rc (gfc_expr * a)
 774 {
 775   if (real_or_complex_check (a, 0) == FAILURE)
 776     return FAILURE;
 777
 778   return SUCCESS;
 779 }
 780
 781
 782 try
 783 gfc_check_fnum (gfc_expr * unit)
 784 {
 785   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
 786     return FAILURE;
 787
 788   if (scalar_check (unit, 0) == FAILURE)
 789     return FAILURE;
 790
 791   return SUCCESS;
 792 }
 793
 794
 795 /* This is used for the g77 one-argument Bessel functions, and the
 796    error function.  */
 797
 798 try
 799 gfc_check_g77_math1 (gfc_expr * x)
 800 {
 801   if (scalar_check (x, 0) == FAILURE)
 802     return FAILURE;
 803
 804   if (type_check (x, 0, BT_REAL) == FAILURE)
 805     return FAILURE;
 806
 807   return SUCCESS;
 808 }
 809
 810
 811 try
 812 gfc_check_huge (gfc_expr * x)
 813 {
 814   if (int_or_real_check (x, 0) == FAILURE)
 815     return FAILURE;
 816
 817   return SUCCESS;
 818 }
 819
 820
 821 /* Check that the single argument is an integer.  */
 822
 823 try
 824 gfc_check_i (gfc_expr * i)
 825 {
 826   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 827     return FAILURE;
 828
 829   return SUCCESS;
 830 }
 831
 832
 833 try
 834 gfc_check_iand (gfc_expr * i, gfc_expr * j)
 835 {
 836   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 837     return FAILURE;
 838
 839   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 840     return FAILURE;
 841
 842   if (i->ts.kind != j->ts.kind)
 843     {
 844       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 845                           &i->where) == FAILURE)
 846         return FAILURE;
 847     }
 848
 849   return SUCCESS;
 850 }
 851
 852
 853 try
 854 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
 855 {
 856   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 857     return FAILURE;
 858
 859   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 860     return FAILURE;
 861
 862   return SUCCESS;
 863 }
 864
 865
 866 try
 867 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
 868 {
 869   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 870     return FAILURE;
 871
 872   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 873     return FAILURE;
 874
 875   if (type_check (len, 2, BT_INTEGER) == FAILURE)
 876     return FAILURE;
 877
 878   return SUCCESS;
 879 }
 880
 881
 882 try
 883 gfc_check_ibset (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_idnint (gfc_expr * a)
 897 {
 898   if (double_check (a, 0) == FAILURE)
 899     return FAILURE;
 900
 901   return SUCCESS;
 902 }
 903
 904
 905 try
 906 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
 907 {
 908   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 909     return FAILURE;
 910
 911   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 912     return FAILURE;
 913
 914   if (i->ts.kind != j->ts.kind)
 915     {
 916       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 917                           &i->where) == FAILURE)
 918         return FAILURE;
 919     }
 920
 921   return SUCCESS;
 922 }
 923
 924
 925 try
 926 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
 927 {
 928   if (type_check (string, 0, BT_CHARACTER) == FAILURE
 929       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
 930     return FAILURE;
 931
 932
 933   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
 934     return FAILURE;
 935
 936   if (string->ts.kind != substring->ts.kind)
 937     {
 938       must_be (substring, 1, "the same kind as 'string'");
 939       return FAILURE;
 940     }
 941
 942   return SUCCESS;
 943 }
 944
 945
 946 try
 947 gfc_check_int (gfc_expr * x, gfc_expr * kind)
 948 {
 949   if (numeric_check (x, 0) == FAILURE)
 950     return FAILURE;
 951
 952   if (kind != NULL)
 953     {
 954       if (type_check (kind, 1, BT_INTEGER) == FAILURE)
 955     return FAILURE;
 956
 957       if (scalar_check (kind, 1) == FAILURE)
 958         return FAILURE;
 959     }
 960
 961   return SUCCESS;
 962 }
 963
 964
 965 try
 966 gfc_check_ior (gfc_expr * i, gfc_expr * j)
 967 {
 968   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 969     return FAILURE;
 970
 971   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 972     return FAILURE;
 973
 974   if (i->ts.kind != j->ts.kind)
 975     {
 976       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 977                           &i->where) == FAILURE)
 978     return FAILURE;
 979     }
 980
 981   return SUCCESS;
 982 }
 983
 984
 985 try
 986 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
 987 {
 988   if (type_check (i, 0, BT_INTEGER) == FAILURE
 989       || type_check (shift, 1, BT_INTEGER) == FAILURE)
 990     return FAILURE;
 991
 992   return SUCCESS;
 993 }
 994
 995
 996 try
 997 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
 998 {
 999   if (type_check (i, 0, BT_INTEGER) == FAILURE
1000       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1001     return FAILURE;
1002
1003   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1004     return FAILURE;
1005
1006   return SUCCESS;
1007 }
1008
1009
1010 try
1011 gfc_check_kind (gfc_expr * x)
1012 {
1013   if (x->ts.type == BT_DERIVED)
1014     {
1015       must_be (x, 0, "a non-derived type");
1016       return FAILURE;
1017     }
1018
1019   return SUCCESS;
1020 }
1021
1022
1023 try
1024 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1025 {
1026   if (array_check (array, 0) == FAILURE)
1027     return FAILURE;
1028
1029   if (dim != NULL)
1030     {
1031       if (dim_check (dim, 1, 1) == FAILURE)
1032         return FAILURE;
1033
1034       if (dim_rank_check (dim, array, 1) == FAILURE)
1035         return FAILURE;
1036     }
1037   return SUCCESS;
1038 }
1039
1040
1041 try
1042 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1043 {
1044   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1045     return FAILURE;
1046   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1047     return FAILURE;
1048
1049   return SUCCESS;
1050 }
1051
1052
1053 /* Min/max family.  */
1054
1055 static try
1056 min_max_args (gfc_actual_arglist * arg)
1057 {
1058   if (arg == NULL || arg->next == NULL)
1059     {
1060       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1061                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1062       return FAILURE;
1063     }
1064
1065   return SUCCESS;
1066 }
1067
1068
1069 static try
1070 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1071 {
1072   gfc_expr *x;
1073   int n;
1074
1075   if (min_max_args (arg) == FAILURE)
1076     return FAILURE;
1077
1078   n = 1;
1079
1080   for (; arg; arg = arg->next, n++)
1081     {
1082       x = arg->expr;
1083       if (x->ts.type != type || x->ts.kind != kind)
1084         {
1085           if (x->ts.type == type)
1086             {
1087               if (gfc_notify_std (GFC_STD_GNU,
1088                     "Extension: Different type kinds at %L", &x->where)
1089                   == FAILURE)
1090                 return FAILURE;
1091             }
1092           else
1093             {
1094               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1095                          n, gfc_current_intrinsic, &x->where,
1096                          gfc_basic_typename (type), kind);
1097               return FAILURE;
1098             }
1099         }
1100     }
1101
1102   return SUCCESS;
1103 }
1104
1105
1106 try
1107 gfc_check_min_max (gfc_actual_arglist * arg)
1108 {
1109   gfc_expr *x;
1110
1111   if (min_max_args (arg) == FAILURE)
1112     return FAILURE;
1113
1114   x = arg->expr;
1115
1116   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1117     {
1118       gfc_error
1119         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1120          gfc_current_intrinsic, &x->where);
1121       return FAILURE;
1122     }
1123
1124   return check_rest (x->ts.type, x->ts.kind, arg);
1125 }
1126
1127
1128 try
1129 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1130 {
1131   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1132 }
1133
1134
1135 try
1136 gfc_check_min_max_real (gfc_actual_arglist * arg)
1137 {
1138   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1139 }
1140
1141
1142 try
1143 gfc_check_min_max_double (gfc_actual_arglist * arg)
1144 {
1145   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1146 }
1147
1148 /* End of min/max family.  */
1149
1150
1151 try
1152 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1153 {
1154   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1155     {
1156       must_be (matrix_a, 0, "numeric or LOGICAL");
1157       return FAILURE;
1158     }
1159
1160   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1161     {
1162       must_be (matrix_b, 0, "numeric or LOGICAL");
1163       return FAILURE;
1164     }
1165
1166   switch (matrix_a->rank)
1167     {
1168     case 1:
1169       if (rank_check (matrix_b, 1, 2) == FAILURE)
1170         return FAILURE;
1171       break;
1172
1173     case 2:
1174       if (matrix_b->rank == 2)
1175         break;
1176       if (rank_check (matrix_b, 1, 1) == FAILURE)
1177         return FAILURE;
1178       break;
1179
1180     default:
1181       must_be (matrix_a, 0, "of rank 1 or 2");
1182       return FAILURE;
1183     }
1184
1185   return SUCCESS;
1186 }
1187
1188
1189 /* Whoever came up with this interface was probably on something.
1190    The possibilities for the occupation of the second and third
1191    parameters are:
1192
1193          Arg #2     Arg #3
1194          NULL       NULL
1195          DIM        NULL
1196          MASK       NULL
1197          NULL       MASK             minloc(array, mask=m)
1198          DIM        MASK
1199
1200    I.e. in the case of minloc(array,mask), mask will be in the second
1201    position of the argument list and we'll have to fix that up.  */
1202
1203 try
1204 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1205 {
1206   gfc_expr *a, *m, *d;
1207
1208   a = ap->expr;
1209   if (int_or_real_check (a, 0) == FAILURE
1210       || array_check (a, 0) == FAILURE)
1211     return FAILURE;
1212
1213   d = ap->next->expr;
1214   m = ap->next->next->expr;
1215
1216   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1217       && ap->next->name == NULL)
1218     {
1219       m = d;
1220       d = NULL;
1221
1222       ap->next->expr = NULL;
1223       ap->next->next->expr = m;
1224     }
1225
1226   if (d != NULL
1227       && (scalar_check (d, 1) == FAILURE
1228       || type_check (d, 1, BT_INTEGER) == FAILURE))
1229     return FAILURE;
1230
1231   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1232     return FAILURE;
1233
1234   return SUCCESS;
1235 }
1236
1237
1238 /* Similar to minloc/maxloc, the argument list might need to be
1239    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1240    difference is that MINLOC/MAXLOC take an additional KIND argument.
1241    The possibilities are:
1242
1243          Arg #2     Arg #3
1244          NULL       NULL
1245          DIM        NULL
1246          MASK       NULL
1247          NULL       MASK             minval(array, mask=m)
1248          DIM        MASK
1249
1250    I.e. in the case of minval(array,mask), mask will be in the second
1251    position of the argument list and we'll have to fix that up.  */
1252
1253 static try
1254 check_reduction (gfc_actual_arglist * ap)
1255 {
1256   gfc_expr *m, *d;
1257
1258   d = ap->next->expr;
1259   m = ap->next->next->expr;
1260
1261   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1262       && ap->next->name == NULL)
1263     {
1264       m = d;
1265       d = NULL;
1266
1267       ap->next->expr = NULL;
1268       ap->next->next->expr = m;
1269     }
1270
1271   if (d != NULL
1272       && (scalar_check (d, 1) == FAILURE
1273       || type_check (d, 1, BT_INTEGER) == FAILURE))
1274     return FAILURE;
1275
1276   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1277     return FAILURE;
1278
1279   return SUCCESS;
1280 }
1281
1282
1283 try
1284 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1285 {
1286   if (int_or_real_check (ap->expr, 0) == FAILURE
1287       || array_check (ap->expr, 0) == FAILURE)
1288     return FAILURE;
1289
1290   return check_reduction (ap);
1291 }
1292
1293
1294 try
1295 gfc_check_product_sum (gfc_actual_arglist * ap)
1296 {
1297   if (numeric_check (ap->expr, 0) == FAILURE
1298       || array_check (ap->expr, 0) == FAILURE)
1299     return FAILURE;
1300
1301   return check_reduction (ap);
1302 }
1303
1304
1305 try
1306 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1307 {
1308   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1309     return FAILURE;
1310
1311   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1312     return FAILURE;
1313
1314   return SUCCESS;
1315 }
1316
1317
1318 try
1319 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1320 {
1321   if (type_check (x, 0, BT_REAL) == FAILURE)
1322     return FAILURE;
1323
1324   if (type_check (s, 1, BT_REAL) == FAILURE)
1325     return FAILURE;
1326
1327   return SUCCESS;
1328 }
1329
1330
1331 try
1332 gfc_check_null (gfc_expr * mold)
1333 {
1334   symbol_attribute attr;
1335
1336   if (mold == NULL)
1337     return SUCCESS;
1338
1339   if (variable_check (mold, 0) == FAILURE)
1340     return FAILURE;
1341
1342   attr = gfc_variable_attr (mold, NULL);
1343
1344   if (!attr.pointer)
1345     {
1346       must_be (mold, 0, "a POINTER");
1347       return FAILURE;
1348     }
1349
1350   return SUCCESS;
1351 }
1352
1353
1354 try
1355 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1356 {
1357   if (array_check (array, 0) == FAILURE)
1358     return FAILURE;
1359
1360   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1361     return FAILURE;
1362
1363   if (mask->rank != 0 && mask->rank != array->rank)
1364     {
1365       must_be (array, 0, "conformable with 'mask' argument");
1366       return FAILURE;
1367     }
1368
1369   if (vector != NULL)
1370     {
1371       if (same_type_check (array, 0, vector, 2) == FAILURE)
1372         return FAILURE;
1373
1374       if (rank_check (vector, 2, 1) == FAILURE)
1375         return FAILURE;
1376
1377       /* TODO: More constraints here.  */
1378     }
1379
1380   return SUCCESS;
1381 }
1382
1383
1384 try
1385 gfc_check_precision (gfc_expr * x)
1386 {
1387   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1388     {
1389       must_be (x, 0, "of type REAL or COMPLEX");
1390       return FAILURE;
1391     }
1392
1393   return SUCCESS;
1394 }
1395
1396
1397 try
1398 gfc_check_present (gfc_expr * a)
1399 {
1400   gfc_symbol *sym;
1401
1402   if (variable_check (a, 0) == FAILURE)
1403     return FAILURE;
1404
1405   sym = a->symtree->n.sym;
1406   if (!sym->attr.dummy)
1407     {
1408       must_be (a, 0, "a dummy variable");
1409       return FAILURE;
1410     }
1411
1412   if (!sym->attr.optional)
1413     {
1414       must_be (a, 0, "an OPTIONAL dummy variable");
1415       return FAILURE;
1416     }
1417
1418   return SUCCESS;
1419 }
1420
1421
1422 try
1423 gfc_check_radix (gfc_expr * x)
1424 {
1425   if (int_or_real_check (x, 0) == FAILURE)
1426     return FAILURE;
1427
1428   return SUCCESS;
1429 }
1430
1431
1432 try
1433 gfc_check_range (gfc_expr * x)
1434 {
1435   if (numeric_check (x, 0) == FAILURE)
1436     return FAILURE;
1437
1438   return SUCCESS;
1439 }
1440
1441
1442 /* real, float, sngl.  */
1443 try
1444 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1445 {
1446   if (numeric_check (a, 0) == FAILURE)
1447     return FAILURE;
1448
1449   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1450     return FAILURE;
1451
1452   return SUCCESS;
1453 }
1454
1455
1456 try
1457 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1458 {
1459   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1460     return FAILURE;
1461
1462   if (scalar_check (x, 0) == FAILURE)
1463     return FAILURE;
1464
1465   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1466     return FAILURE;
1467
1468   if (scalar_check (y, 1) == FAILURE)
1469     return FAILURE;
1470
1471   return SUCCESS;
1472 }
1473
1474
1475 try
1476 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1477                    gfc_expr * pad, gfc_expr * order)
1478 {
1479   mpz_t size;
1480   int m;
1481
1482   if (array_check (source, 0) == FAILURE)
1483     return FAILURE;
1484
1485   if (rank_check (shape, 1, 1) == FAILURE)
1486     return FAILURE;
1487
1488   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1489     return FAILURE;
1490
1491   if (gfc_array_size (shape, &size) != SUCCESS)
1492     {
1493       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1494                  "array of constant size", &shape->where);
1495       return FAILURE;
1496     }
1497
1498   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1499   mpz_clear (size);
1500
1501   if (m > 0)
1502     {
1503       gfc_error
1504         ("'shape' argument of 'reshape' intrinsic at %L has more than "
1505          stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1506       return FAILURE;
1507     }
1508
1509   if (pad != NULL)
1510     {
1511       if (same_type_check (source, 0, pad, 2) == FAILURE)
1512         return FAILURE;
1513       if (array_check (pad, 2) == FAILURE)
1514         return FAILURE;
1515     }
1516
1517   if (order != NULL && array_check (order, 3) == FAILURE)
1518     return FAILURE;
1519
1520   return SUCCESS;
1521 }
1522
1523
1524 try
1525 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1526 {
1527   if (type_check (x, 0, BT_REAL) == FAILURE)
1528     return FAILURE;
1529
1530   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1531     return FAILURE;
1532
1533   return SUCCESS;
1534 }
1535
1536
1537 try
1538 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1539 {
1540   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1541     return FAILURE;
1542
1543   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1544     return FAILURE;
1545
1546   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1547     return FAILURE;
1548
1549   if (same_type_check (x, 0, y, 1) == FAILURE)
1550     return FAILURE;
1551
1552   return SUCCESS;
1553 }
1554
1555
1556 try
1557 gfc_check_selected_int_kind (gfc_expr * r)
1558 {
1559
1560   if (type_check (r, 0, BT_INTEGER) == FAILURE)
1561     return FAILURE;
1562
1563   if (scalar_check (r, 0) == FAILURE)
1564     return FAILURE;
1565
1566   return SUCCESS;
1567 }
1568
1569
1570 try
1571 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1572 {
1573   if (p == NULL && r == NULL)
1574     {
1575       gfc_error ("Missing arguments to %s intrinsic at %L",
1576                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1577
1578       return FAILURE;
1579     }
1580
1581   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1582     return FAILURE;
1583
1584   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1585     return FAILURE;
1586
1587   return SUCCESS;
1588 }
1589
1590
1591 try
1592 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1593 {
1594   if (type_check (x, 0, BT_REAL) == FAILURE)
1595     return FAILURE;
1596
1597   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1598     return FAILURE;
1599
1600   return SUCCESS;
1601 }
1602
1603
1604 try
1605 gfc_check_shape (gfc_expr * source)
1606 {
1607   gfc_array_ref *ar;
1608
1609   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1610     return SUCCESS;
1611
1612   ar = gfc_find_array_ref (source);
1613
1614   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1615     {
1616       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1617                  "an assumed size array", &source->where);
1618       return FAILURE;
1619     }
1620
1621   return SUCCESS;
1622 }
1623
1624
1625 try
1626 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1627 {
1628   if (int_or_real_check (a, 0) == FAILURE)
1629     return FAILURE;
1630
1631   if (same_type_check (a, 0, b, 1) == FAILURE)
1632     return FAILURE;
1633
1634   return SUCCESS;
1635 }
1636
1637
1638 try
1639 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1640 {
1641   if (array_check (array, 0) == FAILURE)
1642     return FAILURE;
1643
1644   if (dim != NULL)
1645     {
1646       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1647         return FAILURE;
1648
1649       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1650         return FAILURE;
1651
1652       if (dim_rank_check (dim, array, 0) == FAILURE)
1653         return FAILURE;
1654     }
1655
1656   return SUCCESS;
1657 }
1658
1659
1660 try
1661 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1662 {
1663   if (source->rank >= GFC_MAX_DIMENSIONS)
1664     {
1665       must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1666       return FAILURE;
1667     }
1668
1669   if (dim_check (dim, 1, 0) == FAILURE)
1670     return FAILURE;
1671
1672   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1673     return FAILURE;
1674
1675   if (scalar_check (ncopies, 2) == FAILURE)
1676     return FAILURE;
1677
1678   return SUCCESS;
1679 }
1680
1681
1682 try
1683 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
1684 {
1685   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1686     return FAILURE;
1687
1688   if (scalar_check (unit, 0) == FAILURE)
1689     return FAILURE;
1690
1691   if (type_check (array, 1, BT_INTEGER) == FAILURE
1692       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
1693     return FAILURE;
1694
1695   if (array_check (array, 1) == FAILURE)
1696     return FAILURE;
1697
1698   return SUCCESS;
1699 }
1700
1701
1702 try
1703 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
1704 {
1705   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1706     return FAILURE;
1707
1708   if (scalar_check (unit, 0) == FAILURE)
1709     return FAILURE;
1710
1711   if (type_check (array, 1, BT_INTEGER) == FAILURE
1712       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1713     return FAILURE;
1714
1715   if (array_check (array, 1) == FAILURE)
1716     return FAILURE;
1717
1718   if (status == NULL)
1719     return SUCCESS;
1720
1721   if (type_check (status, 2, BT_INTEGER) == FAILURE
1722       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
1723     return FAILURE;
1724
1725   if (scalar_check (status, 2) == FAILURE)
1726     return FAILURE;
1727
1728   return SUCCESS;
1729 }
1730
1731
1732 try
1733 gfc_check_stat (gfc_expr * name, gfc_expr * array)
1734 {
1735   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1736     return FAILURE;
1737
1738   if (type_check (array, 1, BT_INTEGER) == FAILURE
1739       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1740     return FAILURE;
1741
1742   if (array_check (array, 1) == FAILURE)
1743     return FAILURE;
1744
1745   return SUCCESS;
1746 }
1747
1748
1749 try
1750 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
1751 {
1752   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1753     return FAILURE;
1754
1755   if (type_check (array, 1, BT_INTEGER) == FAILURE
1756       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1757     return FAILURE;
1758
1759   if (array_check (array, 1) == FAILURE)
1760     return FAILURE;
1761
1762   if (status == NULL)
1763     return SUCCESS;
1764
1765   if (type_check (status, 2, BT_INTEGER) == FAILURE
1766       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1767     return FAILURE;
1768
1769   if (scalar_check (status, 2) == FAILURE)
1770     return FAILURE;
1771
1772   return SUCCESS;
1773 }
1774
1775
1776 try
1777 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1778                     gfc_expr * mold ATTRIBUTE_UNUSED,
1779                     gfc_expr * size)
1780 {
1781   if (size != NULL)
1782     {
1783       if (type_check (size, 2, BT_INTEGER) == FAILURE)
1784         return FAILURE;
1785
1786       if (scalar_check (size, 2) == FAILURE)
1787         return FAILURE;
1788
1789       if (nonoptional_check (size, 2) == FAILURE)
1790         return FAILURE;
1791     }
1792
1793   return SUCCESS;
1794 }
1795
1796
1797 try
1798 gfc_check_transpose (gfc_expr * matrix)
1799 {
1800   if (rank_check (matrix, 0, 2) == FAILURE)
1801     return FAILURE;
1802
1803   return SUCCESS;
1804 }
1805
1806
1807 try
1808 gfc_check_ubound (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 (dim_check (dim, 1, 1) == FAILURE)
1816         return FAILURE;
1817
1818       if (dim_rank_check (dim, array, 0) == FAILURE)
1819         return FAILURE;
1820     }
1821
1822   return SUCCESS;
1823 }
1824
1825
1826 try
1827 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1828 {
1829   if (rank_check (vector, 0, 1) == FAILURE)
1830     return FAILURE;
1831
1832   if (array_check (mask, 1) == FAILURE)
1833     return FAILURE;
1834
1835   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1836     return FAILURE;
1837
1838   if (same_type_check (vector, 0, field, 2) == FAILURE)
1839     return FAILURE;
1840
1841   return SUCCESS;
1842 }
1843
1844
1845 try
1846 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1847 {
1848   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1849     return FAILURE;
1850
1851   if (same_type_check (x, 0, y, 1) == FAILURE)
1852     return FAILURE;
1853
1854   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1855     return FAILURE;
1856
1857   return SUCCESS;
1858 }
1859
1860
1861 try
1862 gfc_check_trim (gfc_expr * x)
1863 {
1864   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1865     return FAILURE;
1866
1867   if (scalar_check (x, 0) == FAILURE)
1868     return FAILURE;
1869
1870    return SUCCESS;
1871 }
1872
1873
1874 /* Common check function for the half a dozen intrinsics that have a
1875    single real argument.  */
1876
1877 try
1878 gfc_check_x (gfc_expr * x)
1879 {
1880   if (type_check (x, 0, BT_REAL) == FAILURE)
1881     return FAILURE;
1882
1883   return SUCCESS;
1884 }
1885
1886
1887 /************* Check functions for intrinsic subroutines *************/
1888
1889 try
1890 gfc_check_cpu_time (gfc_expr * time)
1891 {
1892   if (scalar_check (time, 0) == FAILURE)
1893     return FAILURE;
1894
1895   if (type_check (time, 0, BT_REAL) == FAILURE)
1896     return FAILURE;
1897
1898   if (variable_check (time, 0) == FAILURE)
1899     return FAILURE;
1900
1901   return SUCCESS;
1902 }
1903
1904
1905 try
1906 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1907                          gfc_expr * zone, gfc_expr * values)
1908 {
1909   if (date != NULL)
1910     {
1911       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1912         return FAILURE;
1913       if (scalar_check (date, 0) == FAILURE)
1914         return FAILURE;
1915       if (variable_check (date, 0) == FAILURE)
1916         return FAILURE;
1917     }
1918
1919   if (time != NULL)
1920     {
1921       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1922         return FAILURE;
1923       if (scalar_check (time, 1) == FAILURE)
1924         return FAILURE;
1925       if (variable_check (time, 1) == FAILURE)
1926         return FAILURE;
1927     }
1928
1929   if (zone != NULL)
1930     {
1931       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1932         return FAILURE;
1933       if (scalar_check (zone, 2) == FAILURE)
1934         return FAILURE;
1935       if (variable_check (zone, 2) == FAILURE)
1936         return FAILURE;
1937     }
1938
1939   if (values != NULL)
1940     {
1941       if (type_check (values, 3, BT_INTEGER) == FAILURE)
1942         return FAILURE;
1943       if (array_check (values, 3) == FAILURE)
1944         return FAILURE;
1945       if (rank_check (values, 3, 1) == FAILURE)
1946         return FAILURE;
1947       if (variable_check (values, 3) == FAILURE)
1948         return FAILURE;
1949     }
1950
1951   return SUCCESS;
1952 }
1953
1954
1955 try
1956 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1957                   gfc_expr * to, gfc_expr * topos)
1958 {
1959   if (type_check (from, 0, BT_INTEGER) == FAILURE)
1960     return FAILURE;
1961
1962   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1963     return FAILURE;
1964
1965   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1966     return FAILURE;
1967
1968   if (same_type_check (from, 0, to, 3) == FAILURE)
1969     return FAILURE;
1970
1971   if (variable_check (to, 3) == FAILURE)
1972     return FAILURE;
1973
1974   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1975     return FAILURE;
1976
1977   return SUCCESS;
1978 }
1979
1980
1981 try
1982 gfc_check_random_number (gfc_expr * harvest)
1983 {
1984   if (type_check (harvest, 0, BT_REAL) == FAILURE)
1985     return FAILURE;
1986
1987   if (variable_check (harvest, 0) == FAILURE)
1988     return FAILURE;
1989
1990   return SUCCESS;
1991 }
1992
1993
1994 try
1995 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1996 {
1997   if (size != NULL)
1998     {
1999       if (scalar_check (size, 0) == FAILURE)
2000         return FAILURE;
2001
2002       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2003         return FAILURE;
2004
2005       if (variable_check (size, 0) == FAILURE)
2006         return FAILURE;
2007
2008       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2009         return FAILURE;
2010     }
2011
2012   if (put != NULL)
2013     {
2014
2015       if (size != NULL)
2016         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2017                     &put->where);
2018
2019       if (array_check (put, 1) == FAILURE)
2020         return FAILURE;
2021
2022       if (rank_check (put, 1, 1) == FAILURE)
2023         return FAILURE;
2024
2025       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2026         return FAILURE;
2027
2028       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2029         return FAILURE;
2030     }
2031
2032   if (get != NULL)
2033     {
2034
2035       if (size != NULL || put != NULL)
2036         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2037                     &get->where);
2038
2039       if (array_check (get, 2) == FAILURE)
2040         return FAILURE;
2041
2042       if (rank_check (get, 2, 1) == FAILURE)
2043         return FAILURE;
2044
2045       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2046         return FAILURE;
2047
2048       if (variable_check (get, 2) == FAILURE)
2049         return FAILURE;
2050
2051       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2052         return FAILURE;
2053     }
2054
2055   return SUCCESS;
2056 }
2057
2058 try
2059 gfc_check_second_sub (gfc_expr * time)
2060 {
2061   if (scalar_check (time, 0) == FAILURE)
2062     return FAILURE;
2063
2064   if (type_check (time, 0, BT_REAL) == FAILURE)
2065     return FAILURE;
2066
2067   if (kind_value_check(time, 0, 4) == FAILURE)
2068     return FAILURE;
2069
2070   return SUCCESS;
2071 }
2072
2073
2074 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2075    count, count_rate, and count_max are all optional arguments */
2076
2077 try
2078 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2079                         gfc_expr * count_max)
2080 {
2081   if (count != NULL)
2082     {
2083       if (scalar_check (count, 0) == FAILURE)
2084         return FAILURE;
2085
2086       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2087         return FAILURE;
2088
2089       if (variable_check (count, 0) == FAILURE)
2090         return FAILURE;
2091     }
2092
2093   if (count_rate != NULL)
2094     {
2095       if (scalar_check (count_rate, 1) == FAILURE)
2096         return FAILURE;
2097
2098       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2099         return FAILURE;
2100
2101       if (variable_check (count_rate, 1) == FAILURE)
2102         return FAILURE;
2103
2104       if (count != NULL
2105           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2106         return FAILURE;
2107
2108     }
2109
2110   if (count_max != NULL)
2111     {
2112       if (scalar_check (count_max, 2) == FAILURE)
2113         return FAILURE;
2114
2115       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2116         return FAILURE;
2117
2118       if (variable_check (count_max, 2) == FAILURE)
2119         return FAILURE;
2120
2121       if (count != NULL
2122           && same_type_check (count, 0, count_max, 2) == FAILURE)
2123         return FAILURE;
2124
2125       if (count_rate != NULL
2126           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2127         return FAILURE;
2128     }
2129
2130   return SUCCESS;
2131 }
2132
2133 try
2134 gfc_check_irand (gfc_expr * x)
2135 {
2136   if (x == NULL)
2137     return SUCCESS;
2138
2139   if (scalar_check (x, 0) == FAILURE)
2140     return FAILURE;
2141
2142   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2143     return FAILURE;
2144
2145   if (kind_value_check(x, 0, 4) == FAILURE)
2146     return FAILURE;
2147
2148   return SUCCESS;
2149 }
2150
2151 try
2152 gfc_check_rand (gfc_expr * x)
2153 {
2154   if (x == NULL)
2155     return SUCCESS;
2156
2157   if (scalar_check (x, 0) == FAILURE)
2158     return FAILURE;
2159
2160   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2161     return FAILURE;
2162
2163   if (kind_value_check(x, 0, 4) == FAILURE)
2164     return FAILURE;
2165
2166   return SUCCESS;
2167 }
2168
2169 try
2170 gfc_check_srand (gfc_expr * x)
2171 {
2172   if (scalar_check (x, 0) == FAILURE)
2173     return FAILURE;
2174
2175   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2176     return FAILURE;
2177
2178   if (kind_value_check(x, 0, 4) == FAILURE)
2179     return FAILURE;
2180
2181   return SUCCESS;
2182 }
2183
2184 try
2185 gfc_check_etime (gfc_expr * x)
2186 {
2187   if (array_check (x, 0) == FAILURE)
2188     return FAILURE;
2189
2190   if (rank_check (x, 0, 1) == FAILURE)
2191     return FAILURE;
2192
2193   if (variable_check (x, 0) == FAILURE)
2194     return FAILURE;
2195
2196   if (type_check (x, 0, BT_REAL) == FAILURE)
2197     return FAILURE;
2198
2199   if (kind_value_check(x, 0, 4) == FAILURE)
2200     return FAILURE;
2201
2202   return SUCCESS;
2203 }
2204
2205 try
2206 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2207 {
2208   if (array_check (values, 0) == FAILURE)
2209     return FAILURE;
2210
2211   if (rank_check (values, 0, 1) == FAILURE)
2212     return FAILURE;
2213
2214   if (variable_check (values, 0) == FAILURE)
2215     return FAILURE;
2216
2217   if (type_check (values, 0, BT_REAL) == FAILURE)
2218     return FAILURE;
2219
2220   if (kind_value_check(values, 0, 4) == FAILURE)
2221     return FAILURE;
2222
2223   if (scalar_check (time, 1) == FAILURE)
2224     return FAILURE;
2225
2226   if (type_check (time, 1, BT_REAL) == FAILURE)
2227     return FAILURE;
2228
2229   if (kind_value_check(time, 1, 4) == FAILURE)
2230     return FAILURE;
2231
2232   return SUCCESS;
2233 }
2234
2235
2236 try
2237 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2238 {
2239   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2240     return FAILURE;
2241
2242   if (status == NULL)
2243     return SUCCESS;
2244
2245   if (scalar_check (status, 1) == FAILURE)
2246     return FAILURE;
2247
2248   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2249     return FAILURE;
2250
2251   return SUCCESS;
2252 }
2253
2254
2255 try
2256 gfc_check_exit (gfc_expr * status)
2257 {
2258   if (status == NULL)
2259     return SUCCESS;
2260
2261   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2262     return FAILURE;
2263
2264   if (scalar_check (status, 0) == FAILURE)
2265     return FAILURE;
2266
2267   return SUCCESS;
2268 }
2269
2270
2271 try
2272 gfc_check_flush (gfc_expr * unit)
2273 {
2274   if (unit == NULL)
2275     return SUCCESS;
2276
2277   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2278     return FAILURE;
2279
2280   if (scalar_check (unit, 0) == FAILURE)
2281     return FAILURE;
2282
2283   return SUCCESS;
2284 }
2285
2286
2287 try
2288 gfc_check_umask (gfc_expr * mask)
2289 {
2290   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2291     return FAILURE;
2292
2293   if (scalar_check (mask, 0) == FAILURE)
2294     return FAILURE;
2295
2296   return SUCCESS;
2297 }
2298
2299
2300 try
2301 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2302 {
2303   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2304     return FAILURE;
2305
2306   if (scalar_check (mask, 0) == FAILURE)
2307     return FAILURE;
2308
2309   if (old == NULL)
2310     return SUCCESS;
2311
2312   if (scalar_check (old, 1) == FAILURE)
2313     return FAILURE;
2314
2315   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2316     return FAILURE;
2317
2318   return SUCCESS;
2319 }
2320
2321
2322 try
2323 gfc_check_unlink (gfc_expr * name)
2324 {
2325   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2326     return FAILURE;
2327
2328   return SUCCESS;
2329 }
2330
2331
2332 try
2333 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2334 {
2335   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2336     return FAILURE;
2337
2338   if (status == NULL)
2339     return SUCCESS;
2340
2341   if (scalar_check (status, 1) == FAILURE)
2342     return FAILURE;
2343
2344   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2345     return FAILURE;
2346
2347   return SUCCESS;
2348 }
2349
2350
2351 try
2352 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2353 {
2354   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2355     return FAILURE;
2356
2357   if (scalar_check (status, 1) == FAILURE)
2358     return FAILURE;
2359
2360   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2361     return FAILURE;
2362
2363   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
2364     return FAILURE;
2365
2366   return SUCCESS;
2367 }