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