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