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