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