gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004 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
  30 #include <stdlib.h>
  31 #include <stdarg.h>
  32
  33 #include "config.h"
  34 #include "system.h"
  35 #include "flags.h"
  36 #include "gfortran.h"
  37 #include "intrinsic.h"
  38
  39
  40 /* The fundamental complaint function of this source file.  This
  41    function can be called in all kinds of ways.  */
  42
  43 static void
  44 must_be (gfc_expr * e, int n, const char *thing)
  45 {
  46
  47   gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
  48              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
  49              thing);
  50 }
  51
  52
  53 /* Check the type of an expression.  */
  54
  55 static try
  56 type_check (gfc_expr * e, int n, bt type)
  57 {
  58
  59   if (e->ts.type == type)
  60     return SUCCESS;
  61
  62   must_be (e, n, gfc_basic_typename (type));
  63
  64   return FAILURE;
  65 }
  66
  67
  68 /* Check that the expression is a numeric type.  */
  69
  70 static try
  71 numeric_check (gfc_expr * e, int n)
  72 {
  73
  74   if (gfc_numeric_ts (&e->ts))
  75     return SUCCESS;
  76
  77   must_be (e, n, "a numeric type");
  78
  79   return FAILURE;
  80 }
  81
  82
  83 /* Check that an expression is integer or real.  */
  84
  85 static try
  86 int_or_real_check (gfc_expr * e, int n)
  87 {
  88
  89   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
  90     {
  91       must_be (e, n, "INTEGER or REAL");
  92       return FAILURE;
  93     }
  94
  95   return SUCCESS;
  96 }
  97
  98
  99 /* Check that the expression is an optional constant integer
 100    and that it specifies a valid kind for that type.  */
 101
 102 static try
 103 kind_check (gfc_expr * k, int n, bt type)
 104 {
 105   int kind;
 106
 107   if (k == NULL)
 108     return SUCCESS;
 109
 110   if (type_check (k, n, BT_INTEGER) == FAILURE)
 111     return FAILURE;
 112
 113   if (k->expr_type != EXPR_CONSTANT)
 114     {
 115       must_be (k, n, "a constant");
 116       return FAILURE;
 117     }
 118
 119   if (gfc_extract_int (k, &kind) != NULL
 120       || gfc_validate_kind (type, kind) == -1)
 121     {
 122       gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
 123                  &k->where);
 124       return FAILURE;
 125     }
 126
 127   return SUCCESS;
 128 }
 129
 130
 131 /* Make sure the expression is a double precision real.  */
 132
 133 static try
 134 double_check (gfc_expr * d, int n)
 135 {
 136
 137   if (type_check (d, n, BT_REAL) == FAILURE)
 138     return FAILURE;
 139
 140   if (d->ts.kind != gfc_default_double_kind ())
 141     {
 142       must_be (d, n, "double precision");
 143       return FAILURE;
 144     }
 145
 146   return SUCCESS;
 147 }
 148
 149
 150 /* Make sure the expression is a logical array.  */
 151
 152 static try
 153 logical_array_check (gfc_expr * array, int n)
 154 {
 155
 156   if (array->ts.type != BT_LOGICAL || array->rank == 0)
 157     {
 158       must_be (array, n, "a logical array");
 159       return FAILURE;
 160     }
 161
 162   return SUCCESS;
 163 }
 164
 165
 166 /* Make sure an expression is an array.  */
 167
 168 static try
 169 array_check (gfc_expr * e, int n)
 170 {
 171
 172   if (e->rank != 0)
 173     return SUCCESS;
 174
 175   must_be (e, n, "an array");
 176
 177   return FAILURE;
 178 }
 179
 180
 181 /* Make sure an expression is a scalar.  */
 182
 183 static try
 184 scalar_check (gfc_expr * e, int n)
 185 {
 186
 187   if (e->rank == 0)
 188     return SUCCESS;
 189
 190   must_be (e, n, "a scalar");
 191
 192   return FAILURE;
 193 }
 194
 195
 196 /* Make sure two expression have the same type.  */
 197
 198 static try
 199 same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
 200 {
 201   char message[100];
 202
 203   if (gfc_compare_types (&e->ts, &f->ts))
 204     return SUCCESS;
 205
 206   sprintf (message, "the same type and kind as '%s'",
 207            gfc_current_intrinsic_arg[n]);
 208
 209   must_be (f, m, message);
 210
 211   return FAILURE;
 212 }
 213
 214
 215 /* Make sure that an expression has a certain (nonzero) rank.  */
 216
 217 static try
 218 rank_check (gfc_expr * e, int n, int rank)
 219 {
 220   char message[100];
 221
 222   if (e->rank == rank)
 223     return SUCCESS;
 224
 225   sprintf (message, "of rank %d", rank);
 226
 227   must_be (e, n, message);
 228
 229   return FAILURE;
 230 }
 231
 232
 233 /* Make sure a variable expression is not an optional dummy argument.  */
 234
 235 static try
 236 nonoptional_check (gfc_expr * e, int n)
 237 {
 238
 239   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
 240     {
 241       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
 242                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 243                  &e->where);
 244
 245     }
 246
 247   /* TODO: Recursive check on nonoptional variables?  */
 248
 249   return SUCCESS;
 250 }
 251
 252
 253 /* Check that an expression has a particular kind.  */
 254
 255 static try
 256 kind_value_check (gfc_expr * e, int n, int k)
 257 {
 258   char message[100];
 259
 260   if (e->ts.kind == k)
 261     return SUCCESS;
 262
 263   sprintf (message, "of kind %d", k);
 264
 265   must_be (e, n, message);
 266   return FAILURE;
 267 }
 268
 269
 270 /* Make sure an expression is a variable.  */
 271
 272 static try
 273 variable_check (gfc_expr * e, int n)
 274 {
 275
 276   if ((e->expr_type == EXPR_VARIABLE
 277        && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
 278       || (e->expr_type == EXPR_FUNCTION
 279           && e->symtree->n.sym->result == e->symtree->n.sym))
 280     return SUCCESS;
 281
 282   if (e->expr_type == EXPR_VARIABLE
 283       && e->symtree->n.sym->attr.intent == INTENT_IN)
 284     {
 285       gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
 286                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 287                  &e->where);
 288       return FAILURE;
 289     }
 290
 291   must_be (e, n, "a variable");
 292
 293   return FAILURE;
 294 }
 295
 296
 297 /* Check the common DIM parameter for correctness.  */
 298
 299 static try
 300 dim_check (gfc_expr * dim, int n, int optional)
 301 {
 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
 372   if (type_check (a, 0, BT_REAL) == FAILURE)
 373     return FAILURE;
 374   if (kind_check (kind, 1, type) == FAILURE)
 375     return FAILURE;
 376
 377   return SUCCESS;
 378 }
 379
 380 /* Check subroutine suitable for ceiling, floor and nint.  */
 381
 382 try
 383 gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
 384 {
 385
 386   return check_a_kind (a, kind, BT_INTEGER);
 387 }
 388
 389 /* Check subroutine suitable for aint, anint.  */
 390
 391 try
 392 gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
 393 {
 394
 395   return check_a_kind (a, kind, BT_REAL);
 396 }
 397
 398 try
 399 gfc_check_abs (gfc_expr * a)
 400 {
 401
 402   if (numeric_check (a, 0) == FAILURE)
 403     return FAILURE;
 404
 405   return SUCCESS;
 406 }
 407
 408
 409 try
 410 gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
 411 {
 412
 413   if (logical_array_check (mask, 0) == FAILURE)
 414     return FAILURE;
 415
 416   if (dim_check (dim, 1, 1) == FAILURE)
 417     return FAILURE;
 418
 419   return SUCCESS;
 420 }
 421
 422
 423 try
 424 gfc_check_allocated (gfc_expr * array)
 425 {
 426
 427   if (variable_check (array, 0) == FAILURE)
 428     return FAILURE;
 429
 430   if (array_check (array, 0) == FAILURE)
 431     return FAILURE;
 432
 433   if (!array->symtree->n.sym->attr.allocatable)
 434     {
 435       must_be (array, 0, "ALLOCATABLE");
 436       return FAILURE;
 437     }
 438
 439   return SUCCESS;
 440 }
 441
 442
 443 /* Common check function where the first argument must be real or
 444    integer and the second argument must be the same as the first.  */
 445
 446 try
 447 gfc_check_a_p (gfc_expr * a, gfc_expr * p)
 448 {
 449
 450   if (int_or_real_check (a, 0) == FAILURE)
 451     return FAILURE;
 452
 453   if (same_type_check (a, 0, p, 1) == FAILURE)
 454     return FAILURE;
 455
 456   return SUCCESS;
 457 }
 458
 459
 460 try
 461 gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
 462 {
 463   symbol_attribute attr;
 464   int i;
 465   try t;
 466
 467   if (variable_check (pointer, 0) == FAILURE)
 468     return FAILURE;
 469
 470   attr = gfc_variable_attr (pointer, NULL);
 471   if (!attr.pointer)
 472     {
 473       must_be (pointer, 0, "a POINTER");
 474       return FAILURE;
 475     }
 476
 477   if (target == NULL)
 478     return SUCCESS;
 479
 480   /* Target argument is optional.  */
 481   if (target->expr_type == EXPR_NULL)
 482     {
 483       gfc_error ("NULL pointer at %L is not permitted as actual argument "
 484                  "of '%s' intrinsic function",
 485                  &target->where, gfc_current_intrinsic);
 486       return FAILURE;
 487     }
 488
 489   attr = gfc_variable_attr (target, NULL);
 490   if (!attr.pointer && !attr.target)
 491     {
 492       must_be (target, 1, "a POINTER or a TARGET");
 493       return FAILURE;
 494     }
 495
 496   t = SUCCESS;
 497   if (same_type_check (pointer, 0, target, 1) == FAILURE)
 498     t = FAILURE;
 499   if (rank_check (target, 0, pointer->rank) == FAILURE)
 500     t = FAILURE;
 501   if (target->rank > 0)
 502     {
 503       for (i = 0; i < target->rank; i++)
 504         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 505           {
 506             gfc_error ("Array section with a vector subscript at %L shall not "
 507                        "be the target of an pointer",
 508                        &target->where);
 509             t = FAILURE;
 510             break;
 511           }
 512     }
 513   return t;
 514 }
 515
 516
 517 try
 518 gfc_check_btest (gfc_expr * i, gfc_expr * pos)
 519 {
 520
 521   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 522     return FAILURE;
 523   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 524     return FAILURE;
 525
 526   return SUCCESS;
 527 }
 528
 529
 530 try
 531 gfc_check_char (gfc_expr * i, gfc_expr * kind)
 532 {
 533
 534   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 535     return FAILURE;
 536   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 537     return FAILURE;
 538
 539   return SUCCESS;
 540 }
 541
 542
 543 try
 544 gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 545 {
 546
 547   if (numeric_check (x, 0) == FAILURE)
 548     return FAILURE;
 549
 550   if (y != NULL)
 551     {
 552       if (numeric_check (y, 1) == FAILURE)
 553         return FAILURE;
 554
 555       if (x->ts.type == BT_COMPLEX)
 556         {
 557           must_be (y, 1, "not be present if 'x' is COMPLEX");
 558           return FAILURE;
 559         }
 560     }
 561
 562   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 563     return FAILURE;
 564
 565   return SUCCESS;
 566 }
 567
 568
 569 try
 570 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
 571 {
 572
 573   if (logical_array_check (mask, 0) == FAILURE)
 574     return FAILURE;
 575   if (dim_check (dim, 1, 1) == FAILURE)
 576     return FAILURE;
 577
 578   return SUCCESS;
 579 }
 580
 581
 582 try
 583 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
 584 {
 585
 586   if (array_check (array, 0) == FAILURE)
 587     return FAILURE;
 588
 589   if (array->rank == 1)
 590     {
 591       if (scalar_check (shift, 1) == FAILURE)
 592         return FAILURE;
 593     }
 594   else
 595     {
 596       /* TODO: more requirements on shift parameter.  */
 597     }
 598
 599   if (dim_check (dim, 2, 1) == FAILURE)
 600     return FAILURE;
 601
 602   return SUCCESS;
 603 }
 604
 605
 606 try
 607 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 608 {
 609
 610   if (numeric_check (x, 0) == FAILURE)
 611     return FAILURE;
 612
 613   if (y != NULL)
 614     {
 615       if (numeric_check (y, 1) == FAILURE)
 616         return FAILURE;
 617
 618       if (x->ts.type == BT_COMPLEX)
 619         {
 620           must_be (y, 1, "not be present if 'x' is COMPLEX");
 621           return FAILURE;
 622         }
 623     }
 624
 625   return SUCCESS;
 626 }
 627
 628
 629 try
 630 gfc_check_dble (gfc_expr * x)
 631 {
 632
 633   if (numeric_check (x, 0) == FAILURE)
 634     return FAILURE;
 635
 636   return SUCCESS;
 637 }
 638
 639
 640 try
 641 gfc_check_digits (gfc_expr * x)
 642 {
 643
 644   if (int_or_real_check (x, 0) == FAILURE)
 645     return FAILURE;
 646
 647   return SUCCESS;
 648 }
 649
 650
 651 try
 652 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
 653 {
 654
 655   switch (vector_a->ts.type)
 656     {
 657     case BT_LOGICAL:
 658       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 659         return FAILURE;
 660       break;
 661
 662     case BT_INTEGER:
 663     case BT_REAL:
 664     case BT_COMPLEX:
 665       if (numeric_check (vector_b, 1) == FAILURE)
 666         return FAILURE;
 667       break;
 668
 669     default:
 670       must_be (vector_a, 0, "numeric or LOGICAL");
 671       return FAILURE;
 672     }
 673
 674   if (rank_check (vector_a, 0, 1) == FAILURE)
 675     return FAILURE;
 676
 677   if (rank_check (vector_b, 1, 1) == FAILURE)
 678     return FAILURE;
 679
 680   return SUCCESS;
 681 }
 682
 683
 684 try
 685 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
 686                    gfc_expr * dim)
 687 {
 688
 689   if (array_check (array, 0) == FAILURE)
 690     return FAILURE;
 691
 692   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 693     return FAILURE;
 694
 695   if (array->rank == 1)
 696     {
 697       if (scalar_check (shift, 2) == FAILURE)
 698         return FAILURE;
 699     }
 700   else
 701     {
 702       /* TODO: more weird restrictions on shift.  */
 703     }
 704
 705   if (boundary != NULL)
 706     {
 707       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 708         return FAILURE;
 709
 710       /* TODO: more restrictions on boundary.  */
 711     }
 712
 713   if (dim_check (dim, 1, 1) == FAILURE)
 714     return FAILURE;
 715
 716   return SUCCESS;
 717 }
 718
 719
 720
 721 try
 722 gfc_check_huge (gfc_expr * x)
 723 {
 724
 725   if (int_or_real_check (x, 0) == FAILURE)
 726     return FAILURE;
 727
 728   return SUCCESS;
 729 }
 730
 731
 732 /* Check that the single argument is an integer.  */
 733
 734 try
 735 gfc_check_i (gfc_expr * i)
 736 {
 737
 738   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 739     return FAILURE;
 740
 741   return SUCCESS;
 742 }
 743
 744
 745 try
 746 gfc_check_iand (gfc_expr * i, gfc_expr * j)
 747 {
 748
 749   if (type_check (i, 0, BT_INTEGER) == FAILURE
 750       || type_check (j, 1, BT_INTEGER) == FAILURE)
 751     return FAILURE;
 752
 753   if (same_type_check (i, 0, j, 1) == FAILURE)
 754     return FAILURE;
 755
 756   return SUCCESS;
 757 }
 758
 759
 760 try
 761 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
 762 {
 763
 764   if (type_check (i, 0, BT_INTEGER) == FAILURE
 765       || type_check (pos, 1, BT_INTEGER) == FAILURE
 766       || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE)
 767     return FAILURE;
 768
 769   return SUCCESS;
 770 }
 771
 772
 773 try
 774 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
 775 {
 776
 777   if (type_check (i, 0, BT_INTEGER) == FAILURE
 778       || type_check (pos, 1, BT_INTEGER) == FAILURE
 779       || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE
 780       || type_check (len, 2, BT_INTEGER) == FAILURE)
 781     return FAILURE;
 782
 783   return SUCCESS;
 784 }
 785
 786
 787 try
 788 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
 789 {
 790
 791   if (type_check (i, 0, BT_INTEGER) == FAILURE
 792       || type_check (pos, 1, BT_INTEGER) == FAILURE
 793       || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE)
 794     return FAILURE;
 795
 796   return SUCCESS;
 797 }
 798
 799
 800 try
 801 gfc_check_idnint (gfc_expr * a)
 802 {
 803
 804   if (double_check (a, 0) == FAILURE)
 805     return FAILURE;
 806
 807   return SUCCESS;
 808 }
 809
 810
 811 try
 812 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
 813 {
 814
 815   if (type_check (i, 0, BT_INTEGER) == FAILURE
 816       || type_check (j, 1, BT_INTEGER) == FAILURE)
 817     return FAILURE;
 818
 819   if (same_type_check (i, 0, j, 1) == FAILURE)
 820     return FAILURE;
 821
 822   return SUCCESS;
 823 }
 824
 825
 826 try
 827 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
 828 {
 829
 830   if (type_check (string, 0, BT_CHARACTER) == FAILURE
 831       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
 832     return FAILURE;
 833
 834
 835   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
 836     return FAILURE;
 837
 838   if (string->ts.kind != substring->ts.kind)
 839     {
 840       must_be (substring, 1, "the same kind as 'string'");
 841       return FAILURE;
 842     }
 843
 844   return SUCCESS;
 845 }
 846
 847
 848 try
 849 gfc_check_int (gfc_expr * x, gfc_expr * kind)
 850 {
 851
 852   if (numeric_check (x, 0) == FAILURE
 853       || kind_check (kind, 1, BT_INTEGER) == FAILURE)
 854     return FAILURE;
 855
 856   return SUCCESS;
 857 }
 858
 859
 860 try
 861 gfc_check_ior (gfc_expr * i, gfc_expr * j)
 862 {
 863
 864   if (type_check (i, 0, BT_INTEGER) == FAILURE
 865       || type_check (j, 1, BT_INTEGER) == FAILURE)
 866     return FAILURE;
 867
 868   if (same_type_check (i, 0, j, 1) == FAILURE)
 869     return FAILURE;
 870
 871   return SUCCESS;
 872 }
 873
 874
 875 try
 876 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
 877 {
 878
 879   if (type_check (i, 0, BT_INTEGER) == FAILURE
 880       || type_check (shift, 1, BT_INTEGER) == FAILURE)
 881     return FAILURE;
 882
 883   return SUCCESS;
 884 }
 885
 886
 887 try
 888 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
 889 {
 890
 891   if (type_check (i, 0, BT_INTEGER) == FAILURE
 892       || type_check (shift, 1, BT_INTEGER) == FAILURE)
 893     return FAILURE;
 894
 895   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
 896     return FAILURE;
 897
 898   return SUCCESS;
 899 }
 900
 901
 902 try
 903 gfc_check_kind (gfc_expr * x)
 904 {
 905
 906   if (x->ts.type == BT_DERIVED)
 907     {
 908       must_be (x, 0, "a non-derived type");
 909       return FAILURE;
 910     }
 911
 912   return SUCCESS;
 913 }
 914
 915
 916 try
 917 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
 918 {
 919
 920   if (array_check (array, 0) == FAILURE)
 921     return FAILURE;
 922
 923   if (dim != NULL)
 924     {
 925       if (dim_check (dim, 1, 1) == FAILURE)
 926         return FAILURE;
 927
 928       if (dim_rank_check (dim, array, 1) == FAILURE)
 929         return FAILURE;
 930     }
 931   return SUCCESS;
 932 }
 933
 934
 935 try
 936 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
 937 {
 938
 939   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
 940     return FAILURE;
 941   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
 942     return FAILURE;
 943
 944   return SUCCESS;
 945 }
 946
 947
 948 /* Min/max family.  */
 949
 950 static try
 951 min_max_args (gfc_actual_arglist * arg)
 952 {
 953
 954   if (arg == NULL || arg->next == NULL)
 955     {
 956       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
 957                  gfc_current_intrinsic, gfc_current_intrinsic_where);
 958       return FAILURE;
 959     }
 960
 961   return SUCCESS;
 962 }
 963
 964
 965 static try
 966 check_rest (bt type, int kind, gfc_actual_arglist * arg)
 967 {
 968   gfc_expr *x;
 969   int n;
 970
 971   if (min_max_args (arg) == FAILURE)
 972     return FAILURE;
 973
 974   n = 1;
 975
 976   for (; arg; arg = arg->next, n++)
 977     {
 978       x = arg->expr;
 979       if (x->ts.type != type || x->ts.kind != kind)
 980         {
 981           if (x->ts.type == type)
 982             {
 983               if (gfc_notify_std (GFC_STD_GNU,
 984                     "Extension: Different type kinds at %L", &x->where)
 985                   == FAILURE)
 986                 return FAILURE;
 987             }
 988           else
 989             {
 990               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
 991                          n, gfc_current_intrinsic, &x->where,
 992                          gfc_basic_typename (type), kind);
 993               return FAILURE;
 994             }
 995         }
 996     }
 997
 998   return SUCCESS;
 999 }
1000
1001
1002 try
1003 gfc_check_min_max (gfc_actual_arglist * arg)
1004 {
1005   gfc_expr *x;
1006
1007   if (min_max_args (arg) == FAILURE)
1008     return FAILURE;
1009
1010   x = arg->expr;
1011
1012   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1013     {
1014       gfc_error
1015         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1016          gfc_current_intrinsic, &x->where);
1017       return FAILURE;
1018     }
1019
1020   return check_rest (x->ts.type, x->ts.kind, arg);
1021 }
1022
1023
1024 try
1025 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1026 {
1027
1028   return check_rest (BT_INTEGER, gfc_default_integer_kind (), arg);
1029 }
1030
1031
1032 try
1033 gfc_check_min_max_real (gfc_actual_arglist * arg)
1034 {
1035
1036   return check_rest (BT_REAL, gfc_default_real_kind (), arg);
1037 }
1038
1039
1040 try
1041 gfc_check_min_max_double (gfc_actual_arglist * arg)
1042 {
1043
1044   return check_rest (BT_REAL, gfc_default_double_kind (), arg);
1045 }
1046
1047 /* End of min/max family.  */
1048
1049
1050 try
1051 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1052 {
1053
1054   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1055     {
1056       must_be (matrix_a, 0, "numeric or LOGICAL");
1057       return FAILURE;
1058     }
1059
1060   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1061     {
1062       must_be (matrix_b, 0, "numeric or LOGICAL");
1063       return FAILURE;
1064     }
1065
1066   switch (matrix_a->rank)
1067     {
1068     case 1:
1069       if (rank_check (matrix_b, 1, 2) == FAILURE)
1070         return FAILURE;
1071       break;
1072
1073     case 2:
1074       if (matrix_b->rank == 2)
1075         break;
1076       if (rank_check (matrix_b, 1, 1) == FAILURE)
1077         return FAILURE;
1078       break;
1079
1080     default:
1081       must_be (matrix_a, 0, "of rank 1 or 2");
1082       return FAILURE;
1083     }
1084
1085   return SUCCESS;
1086 }
1087
1088
1089 /* Whoever came up with this interface was probably on something.
1090    The possibilities for the occupation of the second and third
1091    parameters are:
1092
1093          Arg #2     Arg #3
1094          NULL       NULL
1095          DIM        NULL
1096          MASK       NULL
1097          NULL       MASK             minloc(array, mask=m)
1098          DIM        MASK
1099 */
1100
1101 try
1102 gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
1103 {
1104
1105   if (int_or_real_check (array, 0) == FAILURE)
1106     return FAILURE;
1107
1108   if (array_check (array, 0) == FAILURE)
1109     return FAILURE;
1110
1111   if (a3 != NULL)
1112     {
1113       if (logical_array_check (a3, 2) == FAILURE)
1114         return FAILURE;
1115
1116       if (a2 != NULL)
1117         {
1118           if (scalar_check (a2, 1) == FAILURE)
1119             return FAILURE;
1120           if (type_check (a2, 1, BT_INTEGER) == FAILURE)
1121             return FAILURE;
1122         }
1123     }
1124   else
1125     {
1126       if (a2 != NULL)
1127         {
1128           switch (a2->ts.type)
1129             {
1130             case BT_INTEGER:
1131               if (scalar_check (a2, 1) == FAILURE)
1132                 return FAILURE;
1133               break;
1134
1135             case BT_LOGICAL:    /* The '2' makes the error message correct */
1136               if (logical_array_check (a2, 2) == FAILURE)
1137                 return FAILURE;
1138               break;
1139
1140             default:
1141               type_check (a2, 1, BT_INTEGER);   /* Guaranteed to fail */
1142               return FAILURE;
1143             }
1144         }
1145     }
1146
1147   return SUCCESS;
1148 }
1149
1150
1151 try
1152 gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
1153 {
1154
1155   if (array_check (array, 0) == FAILURE)
1156     return FAILURE;
1157
1158   if (int_or_real_check (array, 0) == FAILURE)
1159     return FAILURE;
1160
1161   if (dim_check (dim, 1, 1) == FAILURE)
1162     return FAILURE;
1163
1164   if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
1165     return FAILURE;
1166
1167   return SUCCESS;
1168 }
1169
1170
1171 try
1172 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1173 {
1174
1175   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1176     return FAILURE;
1177
1178   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1179     return FAILURE;
1180
1181   return SUCCESS;
1182 }
1183
1184
1185 try
1186 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1187 {
1188
1189   if (type_check (x, 0, BT_REAL) == FAILURE)
1190     return FAILURE;
1191
1192   if (type_check (s, 1, BT_REAL) == FAILURE)
1193     return FAILURE;
1194
1195   return SUCCESS;
1196 }
1197
1198
1199 try
1200 gfc_check_null (gfc_expr * mold)
1201 {
1202   symbol_attribute attr;
1203
1204   if (mold == NULL)
1205     return SUCCESS;
1206
1207   if (variable_check (mold, 0) == FAILURE)
1208     return FAILURE;
1209
1210   attr = gfc_variable_attr (mold, NULL);
1211
1212   if (!attr.pointer)
1213     {
1214       must_be (mold, 0, "a POINTER");
1215       return FAILURE;
1216     }
1217
1218   return SUCCESS;
1219 }
1220
1221
1222 try
1223 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1224 {
1225
1226   if (array_check (array, 0) == FAILURE)
1227     return FAILURE;
1228
1229   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1230     return FAILURE;
1231
1232   if (mask->rank != 0 && mask->rank != array->rank)
1233     {
1234       must_be (array, 0, "conformable with 'mask' argument");
1235       return FAILURE;
1236     }
1237
1238   if (vector != NULL)
1239     {
1240       if (same_type_check (array, 0, vector, 2) == FAILURE)
1241         return FAILURE;
1242
1243       if (rank_check (vector, 2, 1) == FAILURE)
1244         return FAILURE;
1245
1246       /* TODO: More constraints here.  */
1247     }
1248
1249   return SUCCESS;
1250 }
1251
1252
1253 try
1254 gfc_check_precision (gfc_expr * x)
1255 {
1256
1257   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1258     {
1259       must_be (x, 0, "of type REAL or COMPLEX");
1260       return FAILURE;
1261     }
1262
1263   return SUCCESS;
1264 }
1265
1266
1267 try
1268 gfc_check_present (gfc_expr * a)
1269 {
1270   gfc_symbol *sym;
1271
1272   if (variable_check (a, 0) == FAILURE)
1273     return FAILURE;
1274
1275   sym = a->symtree->n.sym;
1276   if (!sym->attr.dummy)
1277     {
1278       must_be (a, 0, "a dummy variable");
1279       return FAILURE;
1280     }
1281
1282   if (!sym->attr.optional)
1283     {
1284       must_be (a, 0, "an OPTIONAL dummy variable");
1285       return FAILURE;
1286     }
1287
1288   return SUCCESS;
1289 }
1290
1291
1292 try
1293 gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
1294 {
1295
1296   if (array_check (array, 0) == FAILURE)
1297     return FAILURE;
1298
1299   if (numeric_check (array, 0) == FAILURE)
1300     return FAILURE;
1301
1302   if (dim_check (dim, 1, 1) == FAILURE)
1303     return FAILURE;
1304
1305   if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
1306     return FAILURE;
1307
1308   return SUCCESS;
1309 }
1310
1311
1312 try
1313 gfc_check_radix (gfc_expr * x)
1314 {
1315
1316   if (int_or_real_check (x, 0) == FAILURE)
1317     return FAILURE;
1318
1319   return SUCCESS;
1320 }
1321
1322
1323 try
1324 gfc_check_range (gfc_expr * x)
1325 {
1326
1327   if (numeric_check (x, 0) == FAILURE)
1328     return FAILURE;
1329
1330   return SUCCESS;
1331 }
1332
1333
1334 /* real, float, sngl.  */
1335 try
1336 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1337 {
1338
1339   if (numeric_check (a, 0) == FAILURE)
1340     return FAILURE;
1341
1342   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1343     return FAILURE;
1344
1345   return SUCCESS;
1346 }
1347
1348
1349 try
1350 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1351 {
1352
1353   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1354     return FAILURE;
1355
1356   if (scalar_check (x, 0) == FAILURE)
1357     return FAILURE;
1358
1359   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1360     return FAILURE;
1361
1362   if (scalar_check (y, 1) == FAILURE)
1363     return FAILURE;
1364
1365   return SUCCESS;
1366 }
1367
1368
1369 try
1370 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1371                    gfc_expr * pad, gfc_expr * order)
1372 {
1373   mpz_t size;
1374   int m;
1375
1376   if (array_check (source, 0) == FAILURE)
1377     return FAILURE;
1378
1379   if (rank_check (shape, 1, 1) == FAILURE)
1380     return FAILURE;
1381
1382   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1383     return FAILURE;
1384
1385   if (gfc_array_size (shape, &size) != SUCCESS)
1386     {
1387       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1388                  "array of constant size", &shape->where);
1389       return FAILURE;
1390     }
1391
1392   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1393   mpz_clear (size);
1394
1395   if (m > 0)
1396     {
1397       gfc_error
1398         ("'shape' argument of 'reshape' intrinsic at %L has more than "
1399          stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1400       return FAILURE;
1401     }
1402
1403   if (pad != NULL)
1404     {
1405       if (same_type_check (source, 0, pad, 2) == FAILURE)
1406         return FAILURE;
1407       if (array_check (pad, 2) == FAILURE)
1408         return FAILURE;
1409     }
1410
1411   if (order != NULL && array_check (order, 3) == FAILURE)
1412     return FAILURE;
1413
1414   return SUCCESS;
1415 }
1416
1417
1418 try
1419 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1420 {
1421
1422   if (type_check (x, 0, BT_REAL) == FAILURE)
1423     return FAILURE;
1424
1425   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1426     return FAILURE;
1427
1428   return SUCCESS;
1429 }
1430
1431
1432 try
1433 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1434 {
1435
1436   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1437     return FAILURE;
1438
1439   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1440     return FAILURE;
1441
1442   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1443     return FAILURE;
1444
1445   if (same_type_check (x, 0, y, 1) == FAILURE)
1446     return FAILURE;
1447
1448   return SUCCESS;
1449 }
1450
1451
1452 try
1453 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1454 {
1455
1456   if (p == NULL && r == NULL)
1457     {
1458       gfc_error ("Missing arguments to %s intrinsic at %L",
1459                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1460
1461       return FAILURE;
1462     }
1463
1464   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1465     return FAILURE;
1466
1467   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1468     return FAILURE;
1469
1470   return SUCCESS;
1471 }
1472
1473
1474 try
1475 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1476 {
1477
1478   if (type_check (x, 0, BT_REAL) == FAILURE)
1479     return FAILURE;
1480
1481   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1482     return FAILURE;
1483
1484   return SUCCESS;
1485 }
1486
1487
1488 try
1489 gfc_check_shape (gfc_expr * source)
1490 {
1491   gfc_array_ref *ar;
1492
1493   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1494     return SUCCESS;
1495
1496   ar = gfc_find_array_ref (source);
1497
1498   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1499     {
1500       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1501                  "an assumed size array", &source->where);
1502       return FAILURE;
1503     }
1504
1505   return SUCCESS;
1506 }
1507
1508
1509 try
1510 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1511 {
1512
1513   if (array_check (array, 0) == FAILURE)
1514     return FAILURE;
1515
1516   if (dim != NULL)
1517     {
1518       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1519         return FAILURE;
1520
1521       if (kind_value_check (dim, 1, gfc_default_integer_kind ()) == FAILURE)
1522         return FAILURE;
1523
1524       if (dim_rank_check (dim, array, 0) == FAILURE)
1525         return FAILURE;
1526     }
1527
1528   return SUCCESS;
1529 }
1530
1531
1532 try
1533 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1534 {
1535
1536   if (int_or_real_check (a, 0) == FAILURE)
1537     return FAILURE;
1538
1539   if (same_type_check (a, 0, b, 1) == FAILURE)
1540     return FAILURE;
1541
1542   return SUCCESS;
1543 }
1544
1545
1546 try
1547 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1548 {
1549
1550   if (source->rank >= GFC_MAX_DIMENSIONS)
1551     {
1552       must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1553       return FAILURE;
1554     }
1555
1556   if (dim_check (dim, 1, 0) == FAILURE)
1557     return FAILURE;
1558
1559   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1560     return FAILURE;
1561   if (scalar_check (ncopies, 2) == FAILURE)
1562     return FAILURE;
1563
1564   return SUCCESS;
1565 }
1566
1567
1568 try
1569 gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
1570 {
1571
1572   if (array_check (array, 0) == FAILURE)
1573     return FAILURE;
1574
1575   if (numeric_check (array, 0) == FAILURE)
1576     return FAILURE;
1577
1578   if (dim_check (dim, 1, 1) == FAILURE)
1579     return FAILURE;
1580
1581   if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
1582     return FAILURE;
1583
1584   return SUCCESS;
1585 }
1586
1587
1588 try
1589 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1590                     gfc_expr * mold ATTRIBUTE_UNUSED,
1591                     gfc_expr * size)
1592 {
1593
1594   if (size != NULL)
1595     {
1596       if (type_check (size, 2, BT_INTEGER) == FAILURE)
1597         return FAILURE;
1598
1599       if (scalar_check (size, 2) == FAILURE)
1600         return FAILURE;
1601
1602       if (nonoptional_check (size, 2) == FAILURE)
1603         return FAILURE;
1604     }
1605
1606   return SUCCESS;
1607 }
1608
1609
1610 try
1611 gfc_check_transpose (gfc_expr * matrix)
1612 {
1613
1614   if (rank_check (matrix, 0, 2) == FAILURE)
1615     return FAILURE;
1616
1617   return SUCCESS;
1618 }
1619
1620
1621 try
1622 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
1623 {
1624
1625   if (array_check (array, 0) == FAILURE)
1626     return FAILURE;
1627
1628   if (dim != NULL)
1629     {
1630       if (dim_check (dim, 1, 1) == FAILURE)
1631         return FAILURE;
1632
1633       if (dim_rank_check (dim, array, 0) == FAILURE)
1634         return FAILURE;
1635     }
1636   return SUCCESS;
1637 }
1638
1639
1640 try
1641 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1642 {
1643
1644   if (rank_check (vector, 0, 1) == FAILURE)
1645     return FAILURE;
1646
1647   if (array_check (mask, 1) == FAILURE)
1648     return FAILURE;
1649
1650   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1651     return FAILURE;
1652
1653   if (same_type_check (vector, 0, field, 2) == FAILURE)
1654     return FAILURE;
1655
1656   return SUCCESS;
1657 }
1658
1659
1660 try
1661 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1662 {
1663
1664   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1665     return FAILURE;
1666
1667   if (same_type_check (x, 0, y, 1) == FAILURE)
1668     return FAILURE;
1669
1670   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1671     return FAILURE;
1672
1673   return SUCCESS;
1674 }
1675
1676
1677 try
1678 gfc_check_trim (gfc_expr * x)
1679 {
1680   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1681     return FAILURE;
1682
1683   if (scalar_check (x, 0) == FAILURE)
1684     return FAILURE;
1685
1686    return SUCCESS;
1687 }
1688
1689
1690 /* Common check function for the half a dozen intrinsics that have a
1691    single real argument.  */
1692
1693 try
1694 gfc_check_x (gfc_expr * x)
1695 {
1696
1697   if (type_check (x, 0, BT_REAL) == FAILURE)
1698     return FAILURE;
1699
1700   return SUCCESS;
1701 }
1702
1703
1704 /************* Check functions for intrinsic subroutines *************/
1705
1706 try
1707 gfc_check_cpu_time (gfc_expr * time)
1708 {
1709
1710   if (scalar_check (time, 0) == FAILURE)
1711     return FAILURE;
1712
1713   if (type_check (time, 0, BT_REAL) == FAILURE)
1714     return FAILURE;
1715
1716   if (variable_check (time, 0) == FAILURE)
1717     return FAILURE;
1718
1719   return SUCCESS;
1720 }
1721
1722
1723 try
1724 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1725                          gfc_expr * zone, gfc_expr * values)
1726 {
1727
1728   if (date != NULL)
1729     {
1730       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1731         return FAILURE;
1732       if (scalar_check (date, 0) == FAILURE)
1733         return FAILURE;
1734       if (variable_check (date, 0) == FAILURE)
1735         return FAILURE;
1736     }
1737
1738   if (time != NULL)
1739     {
1740       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1741         return FAILURE;
1742       if (scalar_check (time, 1) == FAILURE)
1743         return FAILURE;
1744       if (variable_check (time, 1) == FAILURE)
1745         return FAILURE;
1746     }
1747
1748   if (zone != NULL)
1749     {
1750       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1751         return FAILURE;
1752       if (scalar_check (zone, 2) == FAILURE)
1753         return FAILURE;
1754       if (variable_check (zone, 2) == FAILURE)
1755         return FAILURE;
1756     }
1757
1758   if (values != NULL)
1759     {
1760       if (type_check (values, 3, BT_INTEGER) == FAILURE)
1761         return FAILURE;
1762       if (array_check (values, 3) == FAILURE)
1763         return FAILURE;
1764       if (rank_check (values, 3, 1) == FAILURE)
1765         return FAILURE;
1766       if (variable_check (values, 3) == FAILURE)
1767         return FAILURE;
1768     }
1769
1770   return SUCCESS;
1771 }
1772
1773
1774 try
1775 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1776                   gfc_expr * to, gfc_expr * topos)
1777 {
1778
1779   if (type_check (from, 0, BT_INTEGER) == FAILURE)
1780     return FAILURE;
1781
1782   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1783     return FAILURE;
1784
1785   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1786     return FAILURE;
1787
1788   if (same_type_check (from, 0, to, 3) == FAILURE)
1789     return FAILURE;
1790
1791   if (variable_check (to, 3) == FAILURE)
1792     return FAILURE;
1793
1794   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1795     return FAILURE;
1796
1797   return SUCCESS;
1798 }
1799
1800
1801 try
1802 gfc_check_random_number (gfc_expr * harvest)
1803 {
1804
1805   if (type_check (harvest, 0, BT_REAL) == FAILURE)
1806     return FAILURE;
1807
1808   if (variable_check (harvest, 0) == FAILURE)
1809     return FAILURE;
1810
1811   return SUCCESS;
1812 }
1813
1814
1815 try
1816 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1817 {
1818
1819   if (size != NULL)
1820     {
1821       if (scalar_check (size, 0) == FAILURE)
1822         return FAILURE;
1823
1824       if (type_check (size, 0, BT_INTEGER) == FAILURE)
1825         return FAILURE;
1826
1827       if (variable_check (size, 0) == FAILURE)
1828         return FAILURE;
1829
1830       if (kind_value_check (size, 0, gfc_default_integer_kind ()) == FAILURE)
1831         return FAILURE;
1832     }
1833
1834   if (put != NULL)
1835     {
1836
1837       if (size != NULL)
1838         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
1839                     &put->where);
1840
1841       if (array_check (put, 1) == FAILURE)
1842         return FAILURE;
1843
1844       if (rank_check (put, 1, 1) == FAILURE)
1845         return FAILURE;
1846
1847       if (type_check (put, 1, BT_INTEGER) == FAILURE)
1848         return FAILURE;
1849
1850       if (kind_value_check (put, 1, gfc_default_integer_kind ()) == FAILURE)
1851         return FAILURE;
1852     }
1853
1854   if (get != NULL)
1855     {
1856
1857       if (size != NULL || put != NULL)
1858         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
1859                     &get->where);
1860
1861       if (array_check (get, 2) == FAILURE)
1862         return FAILURE;
1863
1864       if (rank_check (get, 2, 1) == FAILURE)
1865         return FAILURE;
1866
1867       if (type_check (get, 2, BT_INTEGER) == FAILURE)
1868         return FAILURE;
1869
1870       if (variable_check (get, 2) == FAILURE)
1871         return FAILURE;
1872
1873       if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE)
1874         return FAILURE;
1875     }
1876
1877   return SUCCESS;
1878 }
1879
1880 try
1881 gfc_check_second_sub (gfc_expr * time)
1882 {
1883
1884   if (scalar_check (time, 0) == FAILURE)
1885     return FAILURE;
1886
1887   if (type_check (time, 0, BT_REAL) == FAILURE)
1888     return FAILURE;
1889
1890   if (kind_value_check(time, 0, 4) == FAILURE)
1891     return FAILURE;
1892
1893   return SUCCESS;
1894 }
1895
1896
1897 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
1898    count, count_rate, and count_max are all optional arguments */
1899
1900 try
1901 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
1902                         gfc_expr * count_max)
1903 {
1904
1905   if (count != NULL)
1906     {
1907       if (scalar_check (count, 0) == FAILURE)
1908         return FAILURE;
1909
1910       if (type_check (count, 0, BT_INTEGER) == FAILURE)
1911         return FAILURE;
1912
1913       if (variable_check (count, 0) == FAILURE)
1914         return FAILURE;
1915     }
1916
1917   if (count_rate != NULL)
1918     {
1919       if (scalar_check (count_rate, 1) == FAILURE)
1920         return FAILURE;
1921
1922       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
1923         return FAILURE;
1924
1925       if (variable_check (count_rate, 1) == FAILURE)
1926         return FAILURE;
1927
1928       if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
1929         return FAILURE;
1930
1931     }
1932
1933   if (count_max != NULL)
1934     {
1935       if (scalar_check (count_max, 2) == FAILURE)
1936         return FAILURE;
1937
1938       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
1939         return FAILURE;
1940
1941       if (variable_check (count_max, 2) == FAILURE)
1942         return FAILURE;
1943
1944       if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
1945         return FAILURE;
1946
1947       if (count_rate != NULL
1948           && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
1949         return FAILURE;
1950
1951    }
1952
1953     return SUCCESS;
1954 }
1955
1956 try
1957 gfc_check_irand (gfc_expr * x)
1958 {
1959   if (scalar_check (x, 0) == FAILURE)
1960     return FAILURE;
1961
1962   if (type_check (x, 0, BT_INTEGER) == FAILURE)
1963     return FAILURE;
1964
1965   if (kind_value_check(x, 0, 4) == FAILURE)
1966     return FAILURE;
1967
1968   return SUCCESS;
1969 }
1970
1971 try
1972 gfc_check_rand (gfc_expr * x)
1973 {
1974   if (scalar_check (x, 0) == FAILURE)
1975     return FAILURE;
1976
1977   if (type_check (x, 0, BT_INTEGER) == FAILURE)
1978     return FAILURE;
1979
1980   if (kind_value_check(x, 0, 4) == FAILURE)
1981     return FAILURE;
1982
1983   return SUCCESS;
1984 }
1985
1986 try
1987 gfc_check_srand (gfc_expr * x)
1988 {
1989   if (scalar_check (x, 0) == FAILURE)
1990     return FAILURE;
1991
1992   if (type_check (x, 0, BT_INTEGER) == FAILURE)
1993     return FAILURE;
1994
1995   if (kind_value_check(x, 0, 4) == FAILURE)
1996     return FAILURE;
1997
1998   return SUCCESS;
1999 }
2000
2001 try
2002 gfc_check_etime (gfc_expr * x)
2003 {
2004   if (array_check (x, 0) == FAILURE)
2005     return FAILURE;
2006
2007   if (rank_check (x, 0, 1) == FAILURE)
2008     return FAILURE;
2009
2010   if (variable_check (x, 0) == FAILURE)
2011     return FAILURE;
2012
2013   if (type_check (x, 0, BT_REAL) == FAILURE)
2014     return FAILURE;
2015
2016   if (kind_value_check(x, 0, 4) == FAILURE)
2017     return FAILURE;
2018
2019   return SUCCESS;
2020 }
2021
2022 try
2023 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2024 {
2025   if (array_check (values, 0) == FAILURE)
2026     return FAILURE;
2027
2028   if (rank_check (values, 0, 1) == FAILURE)
2029     return FAILURE;
2030
2031   if (variable_check (values, 0) == FAILURE)
2032     return FAILURE;
2033
2034   if (type_check (values, 0, BT_REAL) == FAILURE)
2035     return FAILURE;
2036
2037   if (kind_value_check(values, 0, 4) == FAILURE)
2038     return FAILURE;
2039
2040   if (scalar_check (time, 1) == FAILURE)
2041     return FAILURE;
2042
2043   if (type_check (time, 1, BT_REAL) == FAILURE)
2044     return FAILURE;
2045
2046   if (kind_value_check(time, 1, 4) == FAILURE)
2047     return FAILURE;
2048
2049   return SUCCESS;
2050 }