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    I.e. in the case of minloc(array,mask), mask will be in the second
1101    position of the argument list and we'll have to fix that up.  */
1102
1103 try
1104 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1105 {
1106   gfc_expr *a, *m, *d;
1107
1108   a = ap->expr;
1109   if (int_or_real_check (a, 0) == FAILURE
1110       || array_check (a, 0) == FAILURE)
1111     return FAILURE;
1112
1113   d = ap->next->expr;
1114   m = ap->next->next->expr;
1115
1116   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1117       && ap->next->name[0] == '\0')
1118     {
1119       m = d;
1120       d = NULL;
1121
1122       ap->next->expr = NULL;
1123       ap->next->next->expr = m;
1124     }
1125
1126   if (d != NULL
1127       && (scalar_check (d, 1) == FAILURE
1128       || type_check (d, 1, BT_INTEGER) == FAILURE))
1129     return FAILURE;
1130
1131   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1132     return FAILURE;
1133
1134   return SUCCESS;
1135 }
1136
1137
1138 /* Similar to minloc/maxloc, the argument list might need to be
1139    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1140    difference is that MINLOC/MAXLOC take an additional KIND argument.
1141    The possibilities are:
1142
1143          Arg #2     Arg #3
1144          NULL       NULL
1145          DIM        NULL
1146          MASK       NULL
1147          NULL       MASK             minval(array, mask=m)
1148          DIM        MASK
1149
1150    I.e. in the case of minval(array,mask), mask will be in the second
1151    position of the argument list and we'll have to fix that up.  */
1152
1153 try
1154 gfc_check_reduction (gfc_actual_arglist * ap)
1155 {
1156   gfc_expr *a, *m, *d;
1157
1158   a = ap->expr;
1159   if (int_or_real_check (a, 0) == FAILURE
1160       || array_check (a, 0) == FAILURE)
1161     return FAILURE;
1162
1163   d = ap->next->expr;
1164   m = ap->next->next->expr;
1165
1166   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1167       && ap->next->name[0] == '\0')
1168     {
1169       m = d;
1170       d = NULL;
1171
1172       ap->next->expr = NULL;
1173       ap->next->next->expr = m;
1174     }
1175
1176   if (d != NULL
1177       && (scalar_check (d, 1) == FAILURE
1178       || type_check (d, 1, BT_INTEGER) == FAILURE))
1179     return FAILURE;
1180
1181   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1182     return FAILURE;
1183
1184   return SUCCESS;
1185 }
1186
1187
1188 try
1189 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1190 {
1191
1192   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1193     return FAILURE;
1194
1195   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1196     return FAILURE;
1197
1198   return SUCCESS;
1199 }
1200
1201
1202 try
1203 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1204 {
1205
1206   if (type_check (x, 0, BT_REAL) == FAILURE)
1207     return FAILURE;
1208
1209   if (type_check (s, 1, BT_REAL) == FAILURE)
1210     return FAILURE;
1211
1212   return SUCCESS;
1213 }
1214
1215
1216 try
1217 gfc_check_null (gfc_expr * mold)
1218 {
1219   symbol_attribute attr;
1220
1221   if (mold == NULL)
1222     return SUCCESS;
1223
1224   if (variable_check (mold, 0) == FAILURE)
1225     return FAILURE;
1226
1227   attr = gfc_variable_attr (mold, NULL);
1228
1229   if (!attr.pointer)
1230     {
1231       must_be (mold, 0, "a POINTER");
1232       return FAILURE;
1233     }
1234
1235   return SUCCESS;
1236 }
1237
1238
1239 try
1240 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1241 {
1242
1243   if (array_check (array, 0) == FAILURE)
1244     return FAILURE;
1245
1246   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1247     return FAILURE;
1248
1249   if (mask->rank != 0 && mask->rank != array->rank)
1250     {
1251       must_be (array, 0, "conformable with 'mask' argument");
1252       return FAILURE;
1253     }
1254
1255   if (vector != NULL)
1256     {
1257       if (same_type_check (array, 0, vector, 2) == FAILURE)
1258         return FAILURE;
1259
1260       if (rank_check (vector, 2, 1) == FAILURE)
1261         return FAILURE;
1262
1263       /* TODO: More constraints here.  */
1264     }
1265
1266   return SUCCESS;
1267 }
1268
1269
1270 try
1271 gfc_check_precision (gfc_expr * x)
1272 {
1273
1274   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1275     {
1276       must_be (x, 0, "of type REAL or COMPLEX");
1277       return FAILURE;
1278     }
1279
1280   return SUCCESS;
1281 }
1282
1283
1284 try
1285 gfc_check_present (gfc_expr * a)
1286 {
1287   gfc_symbol *sym;
1288
1289   if (variable_check (a, 0) == FAILURE)
1290     return FAILURE;
1291
1292   sym = a->symtree->n.sym;
1293   if (!sym->attr.dummy)
1294     {
1295       must_be (a, 0, "a dummy variable");
1296       return FAILURE;
1297     }
1298
1299   if (!sym->attr.optional)
1300     {
1301       must_be (a, 0, "an OPTIONAL dummy variable");
1302       return FAILURE;
1303     }
1304
1305   return SUCCESS;
1306 }
1307
1308
1309 try
1310 gfc_check_radix (gfc_expr * x)
1311 {
1312
1313   if (int_or_real_check (x, 0) == FAILURE)
1314     return FAILURE;
1315
1316   return SUCCESS;
1317 }
1318
1319
1320 try
1321 gfc_check_range (gfc_expr * x)
1322 {
1323
1324   if (numeric_check (x, 0) == FAILURE)
1325     return FAILURE;
1326
1327   return SUCCESS;
1328 }
1329
1330
1331 /* real, float, sngl.  */
1332 try
1333 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1334 {
1335
1336   if (numeric_check (a, 0) == FAILURE)
1337     return FAILURE;
1338
1339   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1340     return FAILURE;
1341
1342   return SUCCESS;
1343 }
1344
1345
1346 try
1347 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1348 {
1349
1350   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1351     return FAILURE;
1352
1353   if (scalar_check (x, 0) == FAILURE)
1354     return FAILURE;
1355
1356   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1357     return FAILURE;
1358
1359   if (scalar_check (y, 1) == FAILURE)
1360     return FAILURE;
1361
1362   return SUCCESS;
1363 }
1364
1365
1366 try
1367 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1368                    gfc_expr * pad, gfc_expr * order)
1369 {
1370   mpz_t size;
1371   int m;
1372
1373   if (array_check (source, 0) == FAILURE)
1374     return FAILURE;
1375
1376   if (rank_check (shape, 1, 1) == FAILURE)
1377     return FAILURE;
1378
1379   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1380     return FAILURE;
1381
1382   if (gfc_array_size (shape, &size) != SUCCESS)
1383     {
1384       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1385                  "array of constant size", &shape->where);
1386       return FAILURE;
1387     }
1388
1389   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1390   mpz_clear (size);
1391
1392   if (m > 0)
1393     {
1394       gfc_error
1395         ("'shape' argument of 'reshape' intrinsic at %L has more than "
1396          stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1397       return FAILURE;
1398     }
1399
1400   if (pad != NULL)
1401     {
1402       if (same_type_check (source, 0, pad, 2) == FAILURE)
1403         return FAILURE;
1404       if (array_check (pad, 2) == FAILURE)
1405         return FAILURE;
1406     }
1407
1408   if (order != NULL && array_check (order, 3) == FAILURE)
1409     return FAILURE;
1410
1411   return SUCCESS;
1412 }
1413
1414
1415 try
1416 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1417 {
1418
1419   if (type_check (x, 0, BT_REAL) == FAILURE)
1420     return FAILURE;
1421
1422   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1423     return FAILURE;
1424
1425   return SUCCESS;
1426 }
1427
1428
1429 try
1430 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1431 {
1432
1433   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1434     return FAILURE;
1435
1436   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1437     return FAILURE;
1438
1439   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1440     return FAILURE;
1441
1442   if (same_type_check (x, 0, y, 1) == FAILURE)
1443     return FAILURE;
1444
1445   return SUCCESS;
1446 }
1447
1448
1449 try
1450 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1451 {
1452
1453   if (p == NULL && r == NULL)
1454     {
1455       gfc_error ("Missing arguments to %s intrinsic at %L",
1456                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1457
1458       return FAILURE;
1459     }
1460
1461   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1462     return FAILURE;
1463
1464   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1465     return FAILURE;
1466
1467   return SUCCESS;
1468 }
1469
1470
1471 try
1472 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1473 {
1474
1475   if (type_check (x, 0, BT_REAL) == FAILURE)
1476     return FAILURE;
1477
1478   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1479     return FAILURE;
1480
1481   return SUCCESS;
1482 }
1483
1484
1485 try
1486 gfc_check_shape (gfc_expr * source)
1487 {
1488   gfc_array_ref *ar;
1489
1490   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1491     return SUCCESS;
1492
1493   ar = gfc_find_array_ref (source);
1494
1495   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1496     {
1497       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1498                  "an assumed size array", &source->where);
1499       return FAILURE;
1500     }
1501
1502   return SUCCESS;
1503 }
1504
1505
1506 try
1507 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1508 {
1509
1510   if (array_check (array, 0) == FAILURE)
1511     return FAILURE;
1512
1513   if (dim != NULL)
1514     {
1515       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1516         return FAILURE;
1517
1518       if (kind_value_check (dim, 1, gfc_default_integer_kind ()) == FAILURE)
1519         return FAILURE;
1520
1521       if (dim_rank_check (dim, array, 0) == FAILURE)
1522         return FAILURE;
1523     }
1524
1525   return SUCCESS;
1526 }
1527
1528
1529 try
1530 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1531 {
1532
1533   if (int_or_real_check (a, 0) == FAILURE)
1534     return FAILURE;
1535
1536   if (same_type_check (a, 0, b, 1) == FAILURE)
1537     return FAILURE;
1538
1539   return SUCCESS;
1540 }
1541
1542
1543 try
1544 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1545 {
1546
1547   if (source->rank >= GFC_MAX_DIMENSIONS)
1548     {
1549       must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1550       return FAILURE;
1551     }
1552
1553   if (dim_check (dim, 1, 0) == FAILURE)
1554     return FAILURE;
1555
1556   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1557     return FAILURE;
1558   if (scalar_check (ncopies, 2) == FAILURE)
1559     return FAILURE;
1560
1561   return SUCCESS;
1562 }
1563
1564
1565 try
1566 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1567                     gfc_expr * mold ATTRIBUTE_UNUSED,
1568                     gfc_expr * size)
1569 {
1570
1571   if (size != NULL)
1572     {
1573       if (type_check (size, 2, BT_INTEGER) == FAILURE)
1574         return FAILURE;
1575
1576       if (scalar_check (size, 2) == FAILURE)
1577         return FAILURE;
1578
1579       if (nonoptional_check (size, 2) == FAILURE)
1580         return FAILURE;
1581     }
1582
1583   return SUCCESS;
1584 }
1585
1586
1587 try
1588 gfc_check_transpose (gfc_expr * matrix)
1589 {
1590
1591   if (rank_check (matrix, 0, 2) == FAILURE)
1592     return FAILURE;
1593
1594   return SUCCESS;
1595 }
1596
1597
1598 try
1599 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
1600 {
1601
1602   if (array_check (array, 0) == FAILURE)
1603     return FAILURE;
1604
1605   if (dim != NULL)
1606     {
1607       if (dim_check (dim, 1, 1) == FAILURE)
1608         return FAILURE;
1609
1610       if (dim_rank_check (dim, array, 0) == FAILURE)
1611         return FAILURE;
1612     }
1613   return SUCCESS;
1614 }
1615
1616
1617 try
1618 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1619 {
1620
1621   if (rank_check (vector, 0, 1) == FAILURE)
1622     return FAILURE;
1623
1624   if (array_check (mask, 1) == FAILURE)
1625     return FAILURE;
1626
1627   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1628     return FAILURE;
1629
1630   if (same_type_check (vector, 0, field, 2) == FAILURE)
1631     return FAILURE;
1632
1633   return SUCCESS;
1634 }
1635
1636
1637 try
1638 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1639 {
1640
1641   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1642     return FAILURE;
1643
1644   if (same_type_check (x, 0, y, 1) == FAILURE)
1645     return FAILURE;
1646
1647   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1648     return FAILURE;
1649
1650   return SUCCESS;
1651 }
1652
1653
1654 try
1655 gfc_check_trim (gfc_expr * x)
1656 {
1657   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1658     return FAILURE;
1659
1660   if (scalar_check (x, 0) == FAILURE)
1661     return FAILURE;
1662
1663    return SUCCESS;
1664 }
1665
1666
1667 /* Common check function for the half a dozen intrinsics that have a
1668    single real argument.  */
1669
1670 try
1671 gfc_check_x (gfc_expr * x)
1672 {
1673
1674   if (type_check (x, 0, BT_REAL) == FAILURE)
1675     return FAILURE;
1676
1677   return SUCCESS;
1678 }
1679
1680
1681 /************* Check functions for intrinsic subroutines *************/
1682
1683 try
1684 gfc_check_cpu_time (gfc_expr * time)
1685 {
1686
1687   if (scalar_check (time, 0) == FAILURE)
1688     return FAILURE;
1689
1690   if (type_check (time, 0, BT_REAL) == FAILURE)
1691     return FAILURE;
1692
1693   if (variable_check (time, 0) == FAILURE)
1694     return FAILURE;
1695
1696   return SUCCESS;
1697 }
1698
1699
1700 try
1701 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1702                          gfc_expr * zone, gfc_expr * values)
1703 {
1704
1705   if (date != NULL)
1706     {
1707       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1708         return FAILURE;
1709       if (scalar_check (date, 0) == FAILURE)
1710         return FAILURE;
1711       if (variable_check (date, 0) == FAILURE)
1712         return FAILURE;
1713     }
1714
1715   if (time != NULL)
1716     {
1717       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1718         return FAILURE;
1719       if (scalar_check (time, 1) == FAILURE)
1720         return FAILURE;
1721       if (variable_check (time, 1) == FAILURE)
1722         return FAILURE;
1723     }
1724
1725   if (zone != NULL)
1726     {
1727       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1728         return FAILURE;
1729       if (scalar_check (zone, 2) == FAILURE)
1730         return FAILURE;
1731       if (variable_check (zone, 2) == FAILURE)
1732         return FAILURE;
1733     }
1734
1735   if (values != NULL)
1736     {
1737       if (type_check (values, 3, BT_INTEGER) == FAILURE)
1738         return FAILURE;
1739       if (array_check (values, 3) == FAILURE)
1740         return FAILURE;
1741       if (rank_check (values, 3, 1) == FAILURE)
1742         return FAILURE;
1743       if (variable_check (values, 3) == FAILURE)
1744         return FAILURE;
1745     }
1746
1747   return SUCCESS;
1748 }
1749
1750
1751 try
1752 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1753                   gfc_expr * to, gfc_expr * topos)
1754 {
1755
1756   if (type_check (from, 0, BT_INTEGER) == FAILURE)
1757     return FAILURE;
1758
1759   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1760     return FAILURE;
1761
1762   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1763     return FAILURE;
1764
1765   if (same_type_check (from, 0, to, 3) == FAILURE)
1766     return FAILURE;
1767
1768   if (variable_check (to, 3) == FAILURE)
1769     return FAILURE;
1770
1771   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1772     return FAILURE;
1773
1774   return SUCCESS;
1775 }
1776
1777
1778 try
1779 gfc_check_random_number (gfc_expr * harvest)
1780 {
1781
1782   if (type_check (harvest, 0, BT_REAL) == FAILURE)
1783     return FAILURE;
1784
1785   if (variable_check (harvest, 0) == FAILURE)
1786     return FAILURE;
1787
1788   return SUCCESS;
1789 }
1790
1791
1792 try
1793 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1794 {
1795
1796   if (size != NULL)
1797     {
1798       if (scalar_check (size, 0) == FAILURE)
1799         return FAILURE;
1800
1801       if (type_check (size, 0, BT_INTEGER) == FAILURE)
1802         return FAILURE;
1803
1804       if (variable_check (size, 0) == FAILURE)
1805         return FAILURE;
1806
1807       if (kind_value_check (size, 0, gfc_default_integer_kind ()) == FAILURE)
1808         return FAILURE;
1809     }
1810
1811   if (put != NULL)
1812     {
1813
1814       if (size != NULL)
1815         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
1816                     &put->where);
1817
1818       if (array_check (put, 1) == FAILURE)
1819         return FAILURE;
1820
1821       if (rank_check (put, 1, 1) == FAILURE)
1822         return FAILURE;
1823
1824       if (type_check (put, 1, BT_INTEGER) == FAILURE)
1825         return FAILURE;
1826
1827       if (kind_value_check (put, 1, gfc_default_integer_kind ()) == FAILURE)
1828         return FAILURE;
1829     }
1830
1831   if (get != NULL)
1832     {
1833
1834       if (size != NULL || put != NULL)
1835         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
1836                     &get->where);
1837
1838       if (array_check (get, 2) == FAILURE)
1839         return FAILURE;
1840
1841       if (rank_check (get, 2, 1) == FAILURE)
1842         return FAILURE;
1843
1844       if (type_check (get, 2, BT_INTEGER) == FAILURE)
1845         return FAILURE;
1846
1847       if (variable_check (get, 2) == FAILURE)
1848         return FAILURE;
1849
1850       if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE)
1851         return FAILURE;
1852     }
1853
1854   return SUCCESS;
1855 }
1856
1857 try
1858 gfc_check_second_sub (gfc_expr * time)
1859 {
1860
1861   if (scalar_check (time, 0) == FAILURE)
1862     return FAILURE;
1863
1864   if (type_check (time, 0, BT_REAL) == FAILURE)
1865     return FAILURE;
1866
1867   if (kind_value_check(time, 0, 4) == FAILURE)
1868     return FAILURE;
1869
1870   return SUCCESS;
1871 }
1872
1873
1874 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
1875    count, count_rate, and count_max are all optional arguments */
1876
1877 try
1878 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
1879                         gfc_expr * count_max)
1880 {
1881
1882   if (count != NULL)
1883     {
1884       if (scalar_check (count, 0) == FAILURE)
1885         return FAILURE;
1886
1887       if (type_check (count, 0, BT_INTEGER) == FAILURE)
1888         return FAILURE;
1889
1890       if (variable_check (count, 0) == FAILURE)
1891         return FAILURE;
1892     }
1893
1894   if (count_rate != NULL)
1895     {
1896       if (scalar_check (count_rate, 1) == FAILURE)
1897         return FAILURE;
1898
1899       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
1900         return FAILURE;
1901
1902       if (variable_check (count_rate, 1) == FAILURE)
1903         return FAILURE;
1904
1905       if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
1906         return FAILURE;
1907
1908     }
1909
1910   if (count_max != NULL)
1911     {
1912       if (scalar_check (count_max, 2) == FAILURE)
1913         return FAILURE;
1914
1915       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
1916         return FAILURE;
1917
1918       if (variable_check (count_max, 2) == FAILURE)
1919         return FAILURE;
1920
1921       if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
1922         return FAILURE;
1923
1924       if (count_rate != NULL
1925           && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
1926         return FAILURE;
1927
1928    }
1929
1930     return SUCCESS;
1931 }
1932
1933 try
1934 gfc_check_irand (gfc_expr * x)
1935 {
1936   if (scalar_check (x, 0) == FAILURE)
1937     return FAILURE;
1938
1939   if (type_check (x, 0, BT_INTEGER) == FAILURE)
1940     return FAILURE;
1941
1942   if (kind_value_check(x, 0, 4) == FAILURE)
1943     return FAILURE;
1944
1945   return SUCCESS;
1946 }
1947
1948 try
1949 gfc_check_rand (gfc_expr * x)
1950 {
1951   if (scalar_check (x, 0) == FAILURE)
1952     return FAILURE;
1953
1954   if (type_check (x, 0, BT_INTEGER) == FAILURE)
1955     return FAILURE;
1956
1957   if (kind_value_check(x, 0, 4) == FAILURE)
1958     return FAILURE;
1959
1960   return SUCCESS;
1961 }
1962
1963 try
1964 gfc_check_srand (gfc_expr * x)
1965 {
1966   if (scalar_check (x, 0) == FAILURE)
1967     return FAILURE;
1968
1969   if (type_check (x, 0, BT_INTEGER) == FAILURE)
1970     return FAILURE;
1971
1972   if (kind_value_check(x, 0, 4) == FAILURE)
1973     return FAILURE;
1974
1975   return SUCCESS;
1976 }
1977
1978 try
1979 gfc_check_etime (gfc_expr * x)
1980 {
1981   if (array_check (x, 0) == FAILURE)
1982     return FAILURE;
1983
1984   if (rank_check (x, 0, 1) == FAILURE)
1985     return FAILURE;
1986
1987   if (variable_check (x, 0) == FAILURE)
1988     return FAILURE;
1989
1990   if (type_check (x, 0, BT_REAL) == FAILURE)
1991     return FAILURE;
1992
1993   if (kind_value_check(x, 0, 4) == FAILURE)
1994     return FAILURE;
1995
1996   return SUCCESS;
1997 }
1998
1999 try
2000 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2001 {
2002   if (array_check (values, 0) == FAILURE)
2003     return FAILURE;
2004
2005   if (rank_check (values, 0, 1) == FAILURE)
2006     return FAILURE;
2007
2008   if (variable_check (values, 0) == FAILURE)
2009     return FAILURE;
2010
2011   if (type_check (values, 0, BT_REAL) == FAILURE)
2012     return FAILURE;
2013
2014   if (kind_value_check(values, 0, 4) == FAILURE)
2015     return FAILURE;
2016
2017   if (scalar_check (time, 1) == FAILURE)
2018     return FAILURE;
2019
2020   if (type_check (time, 1, BT_REAL) == FAILURE)
2021     return FAILURE;
2022
2023   if (kind_value_check(time, 1, 4) == FAILURE)
2024     return FAILURE;
2025
2026   return SUCCESS;
2027 }