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[0] == '\0')
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[0] == '\0')
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_real_kind (gfc_expr * p, gfc_expr * r)
1558 {
1559   if (p == NULL && r == NULL)
1560     {
1561       gfc_error ("Missing arguments to %s intrinsic at %L",
1562                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1563
1564       return FAILURE;
1565     }
1566
1567   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1568     return FAILURE;
1569
1570   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1571     return FAILURE;
1572
1573   return SUCCESS;
1574 }
1575
1576
1577 try
1578 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1579 {
1580   if (type_check (x, 0, BT_REAL) == FAILURE)
1581     return FAILURE;
1582
1583   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1584     return FAILURE;
1585
1586   return SUCCESS;
1587 }
1588
1589
1590 try
1591 gfc_check_shape (gfc_expr * source)
1592 {
1593   gfc_array_ref *ar;
1594
1595   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1596     return SUCCESS;
1597
1598   ar = gfc_find_array_ref (source);
1599
1600   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1601     {
1602       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1603                  "an assumed size array", &source->where);
1604       return FAILURE;
1605     }
1606
1607   return SUCCESS;
1608 }
1609
1610
1611 try
1612 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1613 {
1614   if (int_or_real_check (a, 0) == FAILURE)
1615     return FAILURE;
1616
1617   if (same_type_check (a, 0, b, 1) == FAILURE)
1618     return FAILURE;
1619
1620   return SUCCESS;
1621 }
1622
1623
1624 try
1625 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1626 {
1627   if (array_check (array, 0) == FAILURE)
1628     return FAILURE;
1629
1630   if (dim != NULL)
1631     {
1632       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1633         return FAILURE;
1634
1635       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1636         return FAILURE;
1637
1638       if (dim_rank_check (dim, array, 0) == FAILURE)
1639         return FAILURE;
1640     }
1641
1642   return SUCCESS;
1643 }
1644
1645
1646 try
1647 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1648 {
1649   if (source->rank >= GFC_MAX_DIMENSIONS)
1650     {
1651       must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1652       return FAILURE;
1653     }
1654
1655   if (dim_check (dim, 1, 0) == FAILURE)
1656     return FAILURE;
1657
1658   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1659     return FAILURE;
1660
1661   if (scalar_check (ncopies, 2) == FAILURE)
1662     return FAILURE;
1663
1664   return SUCCESS;
1665 }
1666
1667
1668 try
1669 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
1670 {
1671   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1672     return FAILURE;
1673
1674   if (scalar_check (unit, 0) == FAILURE)
1675     return FAILURE;
1676
1677   if (type_check (array, 1, BT_INTEGER) == FAILURE
1678       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
1679     return FAILURE;
1680
1681   if (array_check (array, 1) == FAILURE)
1682     return FAILURE;
1683
1684   return SUCCESS;
1685 }
1686
1687
1688 try
1689 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
1690 {
1691   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1692     return FAILURE;
1693
1694   if (scalar_check (unit, 0) == FAILURE)
1695     return FAILURE;
1696
1697   if (type_check (array, 1, BT_INTEGER) == FAILURE
1698       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1699     return FAILURE;
1700
1701   if (array_check (array, 1) == FAILURE)
1702     return FAILURE;
1703
1704   if (status == NULL)
1705     return SUCCESS;
1706
1707   if (type_check (status, 2, BT_INTEGER) == FAILURE
1708       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
1709     return FAILURE;
1710
1711   if (scalar_check (status, 2) == FAILURE)
1712     return FAILURE;
1713
1714   return SUCCESS;
1715 }
1716
1717
1718 try
1719 gfc_check_stat (gfc_expr * name, gfc_expr * array)
1720 {
1721   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1722     return FAILURE;
1723
1724   if (type_check (array, 1, BT_INTEGER) == FAILURE
1725       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1726     return FAILURE;
1727
1728   if (array_check (array, 1) == FAILURE)
1729     return FAILURE;
1730
1731   return SUCCESS;
1732 }
1733
1734
1735 try
1736 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
1737 {
1738   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1739     return FAILURE;
1740
1741   if (type_check (array, 1, BT_INTEGER) == FAILURE
1742       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1743     return FAILURE;
1744
1745   if (array_check (array, 1) == FAILURE)
1746     return FAILURE;
1747
1748   if (status == NULL)
1749     return SUCCESS;
1750
1751   if (type_check (status, 2, BT_INTEGER) == FAILURE
1752       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1753     return FAILURE;
1754
1755   if (scalar_check (status, 2) == FAILURE)
1756     return FAILURE;
1757
1758   return SUCCESS;
1759 }
1760
1761
1762 try
1763 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1764                     gfc_expr * mold ATTRIBUTE_UNUSED,
1765                     gfc_expr * size)
1766 {
1767   if (size != NULL)
1768     {
1769       if (type_check (size, 2, BT_INTEGER) == FAILURE)
1770         return FAILURE;
1771
1772       if (scalar_check (size, 2) == FAILURE)
1773         return FAILURE;
1774
1775       if (nonoptional_check (size, 2) == FAILURE)
1776         return FAILURE;
1777     }
1778
1779   return SUCCESS;
1780 }
1781
1782
1783 try
1784 gfc_check_transpose (gfc_expr * matrix)
1785 {
1786   if (rank_check (matrix, 0, 2) == FAILURE)
1787     return FAILURE;
1788
1789   return SUCCESS;
1790 }
1791
1792
1793 try
1794 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
1795 {
1796   if (array_check (array, 0) == FAILURE)
1797     return FAILURE;
1798
1799   if (dim != NULL)
1800     {
1801       if (dim_check (dim, 1, 1) == FAILURE)
1802         return FAILURE;
1803
1804       if (dim_rank_check (dim, array, 0) == FAILURE)
1805         return FAILURE;
1806     }
1807
1808   return SUCCESS;
1809 }
1810
1811
1812 try
1813 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1814 {
1815   if (rank_check (vector, 0, 1) == FAILURE)
1816     return FAILURE;
1817
1818   if (array_check (mask, 1) == FAILURE)
1819     return FAILURE;
1820
1821   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1822     return FAILURE;
1823
1824   if (same_type_check (vector, 0, field, 2) == FAILURE)
1825     return FAILURE;
1826
1827   return SUCCESS;
1828 }
1829
1830
1831 try
1832 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1833 {
1834   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1835     return FAILURE;
1836
1837   if (same_type_check (x, 0, y, 1) == FAILURE)
1838     return FAILURE;
1839
1840   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1841     return FAILURE;
1842
1843   return SUCCESS;
1844 }
1845
1846
1847 try
1848 gfc_check_trim (gfc_expr * x)
1849 {
1850   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1851     return FAILURE;
1852
1853   if (scalar_check (x, 0) == FAILURE)
1854     return FAILURE;
1855
1856    return SUCCESS;
1857 }
1858
1859
1860 /* Common check function for the half a dozen intrinsics that have a
1861    single real argument.  */
1862
1863 try
1864 gfc_check_x (gfc_expr * x)
1865 {
1866   if (type_check (x, 0, BT_REAL) == FAILURE)
1867     return FAILURE;
1868
1869   return SUCCESS;
1870 }
1871
1872
1873 /************* Check functions for intrinsic subroutines *************/
1874
1875 try
1876 gfc_check_cpu_time (gfc_expr * time)
1877 {
1878   if (scalar_check (time, 0) == FAILURE)
1879     return FAILURE;
1880
1881   if (type_check (time, 0, BT_REAL) == FAILURE)
1882     return FAILURE;
1883
1884   if (variable_check (time, 0) == FAILURE)
1885     return FAILURE;
1886
1887   return SUCCESS;
1888 }
1889
1890
1891 try
1892 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1893                          gfc_expr * zone, gfc_expr * values)
1894 {
1895   if (date != NULL)
1896     {
1897       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1898         return FAILURE;
1899       if (scalar_check (date, 0) == FAILURE)
1900         return FAILURE;
1901       if (variable_check (date, 0) == FAILURE)
1902         return FAILURE;
1903     }
1904
1905   if (time != NULL)
1906     {
1907       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1908         return FAILURE;
1909       if (scalar_check (time, 1) == FAILURE)
1910         return FAILURE;
1911       if (variable_check (time, 1) == FAILURE)
1912         return FAILURE;
1913     }
1914
1915   if (zone != NULL)
1916     {
1917       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1918         return FAILURE;
1919       if (scalar_check (zone, 2) == FAILURE)
1920         return FAILURE;
1921       if (variable_check (zone, 2) == FAILURE)
1922         return FAILURE;
1923     }
1924
1925   if (values != NULL)
1926     {
1927       if (type_check (values, 3, BT_INTEGER) == FAILURE)
1928         return FAILURE;
1929       if (array_check (values, 3) == FAILURE)
1930         return FAILURE;
1931       if (rank_check (values, 3, 1) == FAILURE)
1932         return FAILURE;
1933       if (variable_check (values, 3) == FAILURE)
1934         return FAILURE;
1935     }
1936
1937   return SUCCESS;
1938 }
1939
1940
1941 try
1942 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1943                   gfc_expr * to, gfc_expr * topos)
1944 {
1945   if (type_check (from, 0, BT_INTEGER) == FAILURE)
1946     return FAILURE;
1947
1948   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1949     return FAILURE;
1950
1951   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1952     return FAILURE;
1953
1954   if (same_type_check (from, 0, to, 3) == FAILURE)
1955     return FAILURE;
1956
1957   if (variable_check (to, 3) == FAILURE)
1958     return FAILURE;
1959
1960   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1961     return FAILURE;
1962
1963   return SUCCESS;
1964 }
1965
1966
1967 try
1968 gfc_check_random_number (gfc_expr * harvest)
1969 {
1970   if (type_check (harvest, 0, BT_REAL) == FAILURE)
1971     return FAILURE;
1972
1973   if (variable_check (harvest, 0) == FAILURE)
1974     return FAILURE;
1975
1976   return SUCCESS;
1977 }
1978
1979
1980 try
1981 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1982 {
1983   if (size != NULL)
1984     {
1985       if (scalar_check (size, 0) == FAILURE)
1986         return FAILURE;
1987
1988       if (type_check (size, 0, BT_INTEGER) == FAILURE)
1989         return FAILURE;
1990
1991       if (variable_check (size, 0) == FAILURE)
1992         return FAILURE;
1993
1994       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
1995         return FAILURE;
1996     }
1997
1998   if (put != NULL)
1999     {
2000
2001       if (size != NULL)
2002         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2003                     &put->where);
2004
2005       if (array_check (put, 1) == FAILURE)
2006         return FAILURE;
2007
2008       if (rank_check (put, 1, 1) == FAILURE)
2009         return FAILURE;
2010
2011       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2012         return FAILURE;
2013
2014       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2015         return FAILURE;
2016     }
2017
2018   if (get != NULL)
2019     {
2020
2021       if (size != NULL || put != NULL)
2022         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2023                     &get->where);
2024
2025       if (array_check (get, 2) == FAILURE)
2026         return FAILURE;
2027
2028       if (rank_check (get, 2, 1) == FAILURE)
2029         return FAILURE;
2030
2031       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2032         return FAILURE;
2033
2034       if (variable_check (get, 2) == FAILURE)
2035         return FAILURE;
2036
2037       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2038         return FAILURE;
2039     }
2040
2041   return SUCCESS;
2042 }
2043
2044 try
2045 gfc_check_second_sub (gfc_expr * time)
2046 {
2047   if (scalar_check (time, 0) == FAILURE)
2048     return FAILURE;
2049
2050   if (type_check (time, 0, BT_REAL) == FAILURE)
2051     return FAILURE;
2052
2053   if (kind_value_check(time, 0, 4) == FAILURE)
2054     return FAILURE;
2055
2056   return SUCCESS;
2057 }
2058
2059
2060 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2061    count, count_rate, and count_max are all optional arguments */
2062
2063 try
2064 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2065                         gfc_expr * count_max)
2066 {
2067   if (count != NULL)
2068     {
2069       if (scalar_check (count, 0) == FAILURE)
2070         return FAILURE;
2071
2072       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2073         return FAILURE;
2074
2075       if (variable_check (count, 0) == FAILURE)
2076         return FAILURE;
2077     }
2078
2079   if (count_rate != NULL)
2080     {
2081       if (scalar_check (count_rate, 1) == FAILURE)
2082         return FAILURE;
2083
2084       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2085         return FAILURE;
2086
2087       if (variable_check (count_rate, 1) == FAILURE)
2088         return FAILURE;
2089
2090       if (count != NULL
2091           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2092         return FAILURE;
2093
2094     }
2095
2096   if (count_max != NULL)
2097     {
2098       if (scalar_check (count_max, 2) == FAILURE)
2099         return FAILURE;
2100
2101       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2102         return FAILURE;
2103
2104       if (variable_check (count_max, 2) == FAILURE)
2105         return FAILURE;
2106
2107       if (count != NULL
2108           && same_type_check (count, 0, count_max, 2) == FAILURE)
2109         return FAILURE;
2110
2111       if (count_rate != NULL
2112           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2113         return FAILURE;
2114     }
2115
2116   return SUCCESS;
2117 }
2118
2119 try
2120 gfc_check_irand (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_rand (gfc_expr * x)
2139 {
2140   if (x == NULL)
2141     return SUCCESS;
2142
2143   if (scalar_check (x, 0) == FAILURE)
2144     return FAILURE;
2145
2146   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2147     return FAILURE;
2148
2149   if (kind_value_check(x, 0, 4) == FAILURE)
2150     return FAILURE;
2151
2152   return SUCCESS;
2153 }
2154
2155 try
2156 gfc_check_srand (gfc_expr * x)
2157 {
2158   if (scalar_check (x, 0) == FAILURE)
2159     return FAILURE;
2160
2161   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2162     return FAILURE;
2163
2164   if (kind_value_check(x, 0, 4) == FAILURE)
2165     return FAILURE;
2166
2167   return SUCCESS;
2168 }
2169
2170 try
2171 gfc_check_etime (gfc_expr * x)
2172 {
2173   if (array_check (x, 0) == FAILURE)
2174     return FAILURE;
2175
2176   if (rank_check (x, 0, 1) == FAILURE)
2177     return FAILURE;
2178
2179   if (variable_check (x, 0) == FAILURE)
2180     return FAILURE;
2181
2182   if (type_check (x, 0, BT_REAL) == FAILURE)
2183     return FAILURE;
2184
2185   if (kind_value_check(x, 0, 4) == FAILURE)
2186     return FAILURE;
2187
2188   return SUCCESS;
2189 }
2190
2191 try
2192 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2193 {
2194   if (array_check (values, 0) == FAILURE)
2195     return FAILURE;
2196
2197   if (rank_check (values, 0, 1) == FAILURE)
2198     return FAILURE;
2199
2200   if (variable_check (values, 0) == FAILURE)
2201     return FAILURE;
2202
2203   if (type_check (values, 0, BT_REAL) == FAILURE)
2204     return FAILURE;
2205
2206   if (kind_value_check(values, 0, 4) == FAILURE)
2207     return FAILURE;
2208
2209   if (scalar_check (time, 1) == FAILURE)
2210     return FAILURE;
2211
2212   if (type_check (time, 1, BT_REAL) == FAILURE)
2213     return FAILURE;
2214
2215   if (kind_value_check(time, 1, 4) == FAILURE)
2216     return FAILURE;
2217
2218   return SUCCESS;
2219 }
2220
2221
2222 try
2223 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2224 {
2225   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2226     return FAILURE;
2227
2228   if (status == NULL)
2229     return SUCCESS;
2230
2231   if (scalar_check (status, 1) == FAILURE)
2232     return FAILURE;
2233
2234   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2235     return FAILURE;
2236
2237   return SUCCESS;
2238 }
2239
2240
2241 try
2242 gfc_check_exit (gfc_expr * status)
2243 {
2244   if (status == NULL)
2245     return SUCCESS;
2246
2247   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2248     return FAILURE;
2249
2250   if (scalar_check (status, 0) == FAILURE)
2251     return FAILURE;
2252
2253   return SUCCESS;
2254 }
2255
2256
2257 try
2258 gfc_check_flush (gfc_expr * unit)
2259 {
2260   if (unit == NULL)
2261     return SUCCESS;
2262
2263   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2264     return FAILURE;
2265
2266   if (scalar_check (unit, 0) == FAILURE)
2267     return FAILURE;
2268
2269   return SUCCESS;
2270 }
2271
2272
2273 try
2274 gfc_check_umask (gfc_expr * mask)
2275 {
2276   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2277     return FAILURE;
2278
2279   if (scalar_check (mask, 0) == FAILURE)
2280     return FAILURE;
2281
2282   return SUCCESS;
2283 }
2284
2285
2286 try
2287 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2288 {
2289   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2290     return FAILURE;
2291
2292   if (scalar_check (mask, 0) == FAILURE)
2293     return FAILURE;
2294
2295   if (old == NULL)
2296     return SUCCESS;
2297
2298   if (scalar_check (old, 1) == FAILURE)
2299     return FAILURE;
2300
2301   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2302     return FAILURE;
2303
2304   return SUCCESS;
2305 }
2306
2307
2308 try
2309 gfc_check_unlink (gfc_expr * name)
2310 {
2311   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2312     return FAILURE;
2313
2314   return SUCCESS;
2315 }
2316
2317
2318 try
2319 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2320 {
2321   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2322     return FAILURE;
2323
2324   if (status == NULL)
2325     return SUCCESS;
2326
2327   if (scalar_check (status, 1) == FAILURE)
2328     return FAILURE;
2329
2330   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2331     return FAILURE;
2332
2333   return SUCCESS;
2334 }
2335
2336
2337 try
2338 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2339 {
2340   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2341     return FAILURE;
2342
2343   if (scalar_check (status, 1) == FAILURE)
2344     return FAILURE;
2345
2346   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2347     return FAILURE;
2348
2349   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
2350     return FAILURE;
2351
2352   return SUCCESS;
2353 }