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 /* BESJN and BESYN functions.  */
 529
 530 try
 531 gfc_check_besn (gfc_expr * n, gfc_expr * x)
 532 {
 533
 534   if (scalar_check (n, 0) == FAILURE)
 535     return FAILURE;
 536
 537   if (type_check (n, 0, BT_INTEGER) == FAILURE)
 538     return FAILURE;
 539
 540   if (scalar_check (x, 1) == FAILURE)
 541     return FAILURE;
 542
 543   if (type_check (x, 1, BT_REAL) == FAILURE)
 544     return FAILURE;
 545
 546   return SUCCESS;
 547 }
 548
 549
 550 try
 551 gfc_check_btest (gfc_expr * i, gfc_expr * pos)
 552 {
 553
 554   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 555     return FAILURE;
 556   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 557     return FAILURE;
 558
 559   return SUCCESS;
 560 }
 561
 562
 563 try
 564 gfc_check_char (gfc_expr * i, gfc_expr * kind)
 565 {
 566
 567   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 568     return FAILURE;
 569   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 570     return FAILURE;
 571
 572   return SUCCESS;
 573 }
 574
 575
 576 try
 577 gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 578 {
 579
 580   if (numeric_check (x, 0) == FAILURE)
 581     return FAILURE;
 582
 583   if (y != NULL)
 584     {
 585       if (numeric_check (y, 1) == FAILURE)
 586         return FAILURE;
 587
 588       if (x->ts.type == BT_COMPLEX)
 589         {
 590           must_be (y, 1, "not be present if 'x' is COMPLEX");
 591           return FAILURE;
 592         }
 593     }
 594
 595   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 596     return FAILURE;
 597
 598   return SUCCESS;
 599 }
 600
 601
 602 try
 603 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
 604 {
 605
 606   if (logical_array_check (mask, 0) == FAILURE)
 607     return FAILURE;
 608   if (dim_check (dim, 1, 1) == FAILURE)
 609     return FAILURE;
 610
 611   return SUCCESS;
 612 }
 613
 614
 615 try
 616 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
 617 {
 618
 619   if (array_check (array, 0) == FAILURE)
 620     return FAILURE;
 621
 622   if (array->rank == 1)
 623     {
 624       if (scalar_check (shift, 1) == FAILURE)
 625         return FAILURE;
 626     }
 627   else
 628     {
 629       /* TODO: more requirements on shift parameter.  */
 630     }
 631
 632   if (dim_check (dim, 2, 1) == FAILURE)
 633     return FAILURE;
 634
 635   return SUCCESS;
 636 }
 637
 638
 639 try
 640 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 641 {
 642
 643   if (numeric_check (x, 0) == FAILURE)
 644     return FAILURE;
 645
 646   if (y != NULL)
 647     {
 648       if (numeric_check (y, 1) == FAILURE)
 649         return FAILURE;
 650
 651       if (x->ts.type == BT_COMPLEX)
 652         {
 653           must_be (y, 1, "not be present if 'x' is COMPLEX");
 654           return FAILURE;
 655         }
 656     }
 657
 658   return SUCCESS;
 659 }
 660
 661
 662 try
 663 gfc_check_dble (gfc_expr * x)
 664 {
 665
 666   if (numeric_check (x, 0) == FAILURE)
 667     return FAILURE;
 668
 669   return SUCCESS;
 670 }
 671
 672
 673 try
 674 gfc_check_digits (gfc_expr * x)
 675 {
 676
 677   if (int_or_real_check (x, 0) == FAILURE)
 678     return FAILURE;
 679
 680   return SUCCESS;
 681 }
 682
 683
 684 try
 685 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
 686 {
 687
 688   switch (vector_a->ts.type)
 689     {
 690     case BT_LOGICAL:
 691       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 692         return FAILURE;
 693       break;
 694
 695     case BT_INTEGER:
 696     case BT_REAL:
 697     case BT_COMPLEX:
 698       if (numeric_check (vector_b, 1) == FAILURE)
 699         return FAILURE;
 700       break;
 701
 702     default:
 703       must_be (vector_a, 0, "numeric or LOGICAL");
 704       return FAILURE;
 705     }
 706
 707   if (rank_check (vector_a, 0, 1) == FAILURE)
 708     return FAILURE;
 709
 710   if (rank_check (vector_b, 1, 1) == FAILURE)
 711     return FAILURE;
 712
 713   return SUCCESS;
 714 }
 715
 716
 717 try
 718 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
 719                    gfc_expr * dim)
 720 {
 721
 722   if (array_check (array, 0) == FAILURE)
 723     return FAILURE;
 724
 725   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 726     return FAILURE;
 727
 728   if (array->rank == 1)
 729     {
 730       if (scalar_check (shift, 2) == FAILURE)
 731         return FAILURE;
 732     }
 733   else
 734     {
 735       /* TODO: more weird restrictions on shift.  */
 736     }
 737
 738   if (boundary != NULL)
 739     {
 740       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 741         return FAILURE;
 742
 743       /* TODO: more restrictions on boundary.  */
 744     }
 745
 746   if (dim_check (dim, 1, 1) == FAILURE)
 747     return FAILURE;
 748
 749   return SUCCESS;
 750 }
 751
 752
 753 /* This is used for the g77 one-argument Bessel functions, and the
 754    error function.  */
 755
 756 try
 757 gfc_check_g77_math1 (gfc_expr * x)
 758 {
 759
 760   if (scalar_check (x, 0) == FAILURE)
 761     return FAILURE;
 762
 763   if (type_check (x, 0, BT_REAL) == FAILURE)
 764     return FAILURE;
 765
 766   return SUCCESS;
 767 }
 768
 769
 770 try
 771 gfc_check_huge (gfc_expr * x)
 772 {
 773
 774   if (int_or_real_check (x, 0) == FAILURE)
 775     return FAILURE;
 776
 777   return SUCCESS;
 778 }
 779
 780
 781 /* Check that the single argument is an integer.  */
 782
 783 try
 784 gfc_check_i (gfc_expr * i)
 785 {
 786
 787   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 788     return FAILURE;
 789
 790   return SUCCESS;
 791 }
 792
 793
 794 try
 795 gfc_check_iand (gfc_expr * i, gfc_expr * j)
 796 {
 797
 798   if (type_check (i, 0, BT_INTEGER) == FAILURE
 799       || type_check (j, 1, BT_INTEGER) == FAILURE)
 800     return FAILURE;
 801
 802   if (same_type_check (i, 0, j, 1) == FAILURE)
 803     return FAILURE;
 804
 805   return SUCCESS;
 806 }
 807
 808
 809 try
 810 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
 811 {
 812
 813   if (type_check (i, 0, BT_INTEGER) == FAILURE
 814       || type_check (pos, 1, BT_INTEGER) == FAILURE
 815       || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE)
 816     return FAILURE;
 817
 818   return SUCCESS;
 819 }
 820
 821
 822 try
 823 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
 824 {
 825
 826   if (type_check (i, 0, BT_INTEGER) == FAILURE
 827       || type_check (pos, 1, BT_INTEGER) == FAILURE
 828       || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE
 829       || type_check (len, 2, BT_INTEGER) == FAILURE)
 830     return FAILURE;
 831
 832   return SUCCESS;
 833 }
 834
 835
 836 try
 837 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
 838 {
 839
 840   if (type_check (i, 0, BT_INTEGER) == FAILURE
 841       || type_check (pos, 1, BT_INTEGER) == FAILURE
 842       || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE)
 843     return FAILURE;
 844
 845   return SUCCESS;
 846 }
 847
 848
 849 try
 850 gfc_check_idnint (gfc_expr * a)
 851 {
 852
 853   if (double_check (a, 0) == FAILURE)
 854     return FAILURE;
 855
 856   return SUCCESS;
 857 }
 858
 859
 860 try
 861 gfc_check_ieor (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_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
 877 {
 878
 879   if (type_check (string, 0, BT_CHARACTER) == FAILURE
 880       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
 881     return FAILURE;
 882
 883
 884   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
 885     return FAILURE;
 886
 887   if (string->ts.kind != substring->ts.kind)
 888     {
 889       must_be (substring, 1, "the same kind as 'string'");
 890       return FAILURE;
 891     }
 892
 893   return SUCCESS;
 894 }
 895
 896
 897 try
 898 gfc_check_int (gfc_expr * x, gfc_expr * kind)
 899 {
 900
 901   if (numeric_check (x, 0) == FAILURE
 902       || kind_check (kind, 1, BT_INTEGER) == FAILURE)
 903     return FAILURE;
 904
 905   return SUCCESS;
 906 }
 907
 908
 909 try
 910 gfc_check_ior (gfc_expr * i, gfc_expr * j)
 911 {
 912
 913   if (type_check (i, 0, BT_INTEGER) == FAILURE
 914       || type_check (j, 1, BT_INTEGER) == FAILURE)
 915     return FAILURE;
 916
 917   if (same_type_check (i, 0, j, 1) == FAILURE)
 918     return FAILURE;
 919
 920   return SUCCESS;
 921 }
 922
 923
 924 try
 925 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
 926 {
 927
 928   if (type_check (i, 0, BT_INTEGER) == FAILURE
 929       || type_check (shift, 1, BT_INTEGER) == FAILURE)
 930     return FAILURE;
 931
 932   return SUCCESS;
 933 }
 934
 935
 936 try
 937 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
 938 {
 939
 940   if (type_check (i, 0, BT_INTEGER) == FAILURE
 941       || type_check (shift, 1, BT_INTEGER) == FAILURE)
 942     return FAILURE;
 943
 944   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
 945     return FAILURE;
 946
 947   return SUCCESS;
 948 }
 949
 950
 951 try
 952 gfc_check_kind (gfc_expr * x)
 953 {
 954
 955   if (x->ts.type == BT_DERIVED)
 956     {
 957       must_be (x, 0, "a non-derived type");
 958       return FAILURE;
 959     }
 960
 961   return SUCCESS;
 962 }
 963
 964
 965 try
 966 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
 967 {
 968
 969   if (array_check (array, 0) == FAILURE)
 970     return FAILURE;
 971
 972   if (dim != NULL)
 973     {
 974       if (dim_check (dim, 1, 1) == FAILURE)
 975         return FAILURE;
 976
 977       if (dim_rank_check (dim, array, 1) == FAILURE)
 978         return FAILURE;
 979     }
 980   return SUCCESS;
 981 }
 982
 983
 984 try
 985 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
 986 {
 987
 988   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
 989     return FAILURE;
 990   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
 991     return FAILURE;
 992
 993   return SUCCESS;
 994 }
 995
 996
 997 /* Min/max family.  */
 998
 999 static try
1000 min_max_args (gfc_actual_arglist * arg)
1001 {
1002
1003   if (arg == NULL || arg->next == NULL)
1004     {
1005       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1006                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1007       return FAILURE;
1008     }
1009
1010   return SUCCESS;
1011 }
1012
1013
1014 static try
1015 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1016 {
1017   gfc_expr *x;
1018   int n;
1019
1020   if (min_max_args (arg) == FAILURE)
1021     return FAILURE;
1022
1023   n = 1;
1024
1025   for (; arg; arg = arg->next, n++)
1026     {
1027       x = arg->expr;
1028       if (x->ts.type != type || x->ts.kind != kind)
1029         {
1030           if (x->ts.type == type)
1031             {
1032               if (gfc_notify_std (GFC_STD_GNU,
1033                     "Extension: Different type kinds at %L", &x->where)
1034                   == FAILURE)
1035                 return FAILURE;
1036             }
1037           else
1038             {
1039               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1040                          n, gfc_current_intrinsic, &x->where,
1041                          gfc_basic_typename (type), kind);
1042               return FAILURE;
1043             }
1044         }
1045     }
1046
1047   return SUCCESS;
1048 }
1049
1050
1051 try
1052 gfc_check_min_max (gfc_actual_arglist * arg)
1053 {
1054   gfc_expr *x;
1055
1056   if (min_max_args (arg) == FAILURE)
1057     return FAILURE;
1058
1059   x = arg->expr;
1060
1061   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1062     {
1063       gfc_error
1064         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1065          gfc_current_intrinsic, &x->where);
1066       return FAILURE;
1067     }
1068
1069   return check_rest (x->ts.type, x->ts.kind, arg);
1070 }
1071
1072
1073 try
1074 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1075 {
1076
1077   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1078 }
1079
1080
1081 try
1082 gfc_check_min_max_real (gfc_actual_arglist * arg)
1083 {
1084
1085   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1086 }
1087
1088
1089 try
1090 gfc_check_min_max_double (gfc_actual_arglist * arg)
1091 {
1092
1093   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1094 }
1095
1096 /* End of min/max family.  */
1097
1098
1099 try
1100 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1101 {
1102
1103   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1104     {
1105       must_be (matrix_a, 0, "numeric or LOGICAL");
1106       return FAILURE;
1107     }
1108
1109   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1110     {
1111       must_be (matrix_b, 0, "numeric or LOGICAL");
1112       return FAILURE;
1113     }
1114
1115   switch (matrix_a->rank)
1116     {
1117     case 1:
1118       if (rank_check (matrix_b, 1, 2) == FAILURE)
1119         return FAILURE;
1120       break;
1121
1122     case 2:
1123       if (matrix_b->rank == 2)
1124         break;
1125       if (rank_check (matrix_b, 1, 1) == FAILURE)
1126         return FAILURE;
1127       break;
1128
1129     default:
1130       must_be (matrix_a, 0, "of rank 1 or 2");
1131       return FAILURE;
1132     }
1133
1134   return SUCCESS;
1135 }
1136
1137
1138 /* Whoever came up with this interface was probably on something.
1139    The possibilities for the occupation of the second and third
1140    parameters are:
1141
1142          Arg #2     Arg #3
1143          NULL       NULL
1144          DIM        NULL
1145          MASK       NULL
1146          NULL       MASK             minloc(array, mask=m)
1147          DIM        MASK
1148
1149    I.e. in the case of minloc(array,mask), mask will be in the second
1150    position of the argument list and we'll have to fix that up.  */
1151
1152 try
1153 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1154 {
1155   gfc_expr *a, *m, *d;
1156
1157   a = ap->expr;
1158   if (int_or_real_check (a, 0) == FAILURE
1159       || array_check (a, 0) == FAILURE)
1160     return FAILURE;
1161
1162   d = ap->next->expr;
1163   m = ap->next->next->expr;
1164
1165   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1166       && ap->next->name[0] == '\0')
1167     {
1168       m = d;
1169       d = NULL;
1170
1171       ap->next->expr = NULL;
1172       ap->next->next->expr = m;
1173     }
1174
1175   if (d != NULL
1176       && (scalar_check (d, 1) == FAILURE
1177       || type_check (d, 1, BT_INTEGER) == FAILURE))
1178     return FAILURE;
1179
1180   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1181     return FAILURE;
1182
1183   return SUCCESS;
1184 }
1185
1186
1187 /* Similar to minloc/maxloc, the argument list might need to be
1188    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1189    difference is that MINLOC/MAXLOC take an additional KIND argument.
1190    The possibilities are:
1191
1192          Arg #2     Arg #3
1193          NULL       NULL
1194          DIM        NULL
1195          MASK       NULL
1196          NULL       MASK             minval(array, mask=m)
1197          DIM        MASK
1198
1199    I.e. in the case of minval(array,mask), mask will be in the second
1200    position of the argument list and we'll have to fix that up.  */
1201
1202 static try
1203 check_reduction (gfc_actual_arglist * ap)
1204 {
1205   gfc_expr *m, *d;
1206
1207   d = ap->next->expr;
1208   m = ap->next->next->expr;
1209
1210   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1211       && ap->next->name[0] == '\0')
1212     {
1213       m = d;
1214       d = NULL;
1215
1216       ap->next->expr = NULL;
1217       ap->next->next->expr = m;
1218     }
1219
1220   if (d != NULL
1221       && (scalar_check (d, 1) == FAILURE
1222       || type_check (d, 1, BT_INTEGER) == FAILURE))
1223     return FAILURE;
1224
1225   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1226     return FAILURE;
1227
1228   return SUCCESS;
1229 }
1230
1231
1232 try
1233 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1234 {
1235
1236   if (int_or_real_check (ap->expr, 0) == FAILURE
1237       || array_check (ap->expr, 0) == FAILURE)
1238     return FAILURE;
1239
1240   return check_reduction (ap);
1241 }
1242
1243
1244 try
1245 gfc_check_product_sum (gfc_actual_arglist * ap)
1246 {
1247
1248   if (numeric_check (ap->expr, 0) == FAILURE
1249       || array_check (ap->expr, 0) == FAILURE)
1250     return FAILURE;
1251
1252   return check_reduction (ap);
1253 }
1254
1255
1256 try
1257 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1258 {
1259
1260   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1261     return FAILURE;
1262
1263   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1264     return FAILURE;
1265
1266   return SUCCESS;
1267 }
1268
1269
1270 try
1271 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1272 {
1273
1274   if (type_check (x, 0, BT_REAL) == FAILURE)
1275     return FAILURE;
1276
1277   if (type_check (s, 1, BT_REAL) == FAILURE)
1278     return FAILURE;
1279
1280   return SUCCESS;
1281 }
1282
1283
1284 try
1285 gfc_check_null (gfc_expr * mold)
1286 {
1287   symbol_attribute attr;
1288
1289   if (mold == NULL)
1290     return SUCCESS;
1291
1292   if (variable_check (mold, 0) == FAILURE)
1293     return FAILURE;
1294
1295   attr = gfc_variable_attr (mold, NULL);
1296
1297   if (!attr.pointer)
1298     {
1299       must_be (mold, 0, "a POINTER");
1300       return FAILURE;
1301     }
1302
1303   return SUCCESS;
1304 }
1305
1306
1307 try
1308 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1309 {
1310
1311   if (array_check (array, 0) == FAILURE)
1312     return FAILURE;
1313
1314   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1315     return FAILURE;
1316
1317   if (mask->rank != 0 && mask->rank != array->rank)
1318     {
1319       must_be (array, 0, "conformable with 'mask' argument");
1320       return FAILURE;
1321     }
1322
1323   if (vector != NULL)
1324     {
1325       if (same_type_check (array, 0, vector, 2) == FAILURE)
1326         return FAILURE;
1327
1328       if (rank_check (vector, 2, 1) == FAILURE)
1329         return FAILURE;
1330
1331       /* TODO: More constraints here.  */
1332     }
1333
1334   return SUCCESS;
1335 }
1336
1337
1338 try
1339 gfc_check_precision (gfc_expr * x)
1340 {
1341
1342   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1343     {
1344       must_be (x, 0, "of type REAL or COMPLEX");
1345       return FAILURE;
1346     }
1347
1348   return SUCCESS;
1349 }
1350
1351
1352 try
1353 gfc_check_present (gfc_expr * a)
1354 {
1355   gfc_symbol *sym;
1356
1357   if (variable_check (a, 0) == FAILURE)
1358     return FAILURE;
1359
1360   sym = a->symtree->n.sym;
1361   if (!sym->attr.dummy)
1362     {
1363       must_be (a, 0, "a dummy variable");
1364       return FAILURE;
1365     }
1366
1367   if (!sym->attr.optional)
1368     {
1369       must_be (a, 0, "an OPTIONAL dummy variable");
1370       return FAILURE;
1371     }
1372
1373   return SUCCESS;
1374 }
1375
1376
1377 try
1378 gfc_check_radix (gfc_expr * x)
1379 {
1380
1381   if (int_or_real_check (x, 0) == FAILURE)
1382     return FAILURE;
1383
1384   return SUCCESS;
1385 }
1386
1387
1388 try
1389 gfc_check_range (gfc_expr * x)
1390 {
1391
1392   if (numeric_check (x, 0) == FAILURE)
1393     return FAILURE;
1394
1395   return SUCCESS;
1396 }
1397
1398
1399 /* real, float, sngl.  */
1400 try
1401 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1402 {
1403
1404   if (numeric_check (a, 0) == FAILURE)
1405     return FAILURE;
1406
1407   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1408     return FAILURE;
1409
1410   return SUCCESS;
1411 }
1412
1413
1414 try
1415 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1416 {
1417
1418   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1419     return FAILURE;
1420
1421   if (scalar_check (x, 0) == FAILURE)
1422     return FAILURE;
1423
1424   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1425     return FAILURE;
1426
1427   if (scalar_check (y, 1) == FAILURE)
1428     return FAILURE;
1429
1430   return SUCCESS;
1431 }
1432
1433
1434 try
1435 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1436                    gfc_expr * pad, gfc_expr * order)
1437 {
1438   mpz_t size;
1439   int m;
1440
1441   if (array_check (source, 0) == FAILURE)
1442     return FAILURE;
1443
1444   if (rank_check (shape, 1, 1) == FAILURE)
1445     return FAILURE;
1446
1447   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1448     return FAILURE;
1449
1450   if (gfc_array_size (shape, &size) != SUCCESS)
1451     {
1452       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1453                  "array of constant size", &shape->where);
1454       return FAILURE;
1455     }
1456
1457   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1458   mpz_clear (size);
1459
1460   if (m > 0)
1461     {
1462       gfc_error
1463         ("'shape' argument of 'reshape' intrinsic at %L has more than "
1464          stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1465       return FAILURE;
1466     }
1467
1468   if (pad != NULL)
1469     {
1470       if (same_type_check (source, 0, pad, 2) == FAILURE)
1471         return FAILURE;
1472       if (array_check (pad, 2) == FAILURE)
1473         return FAILURE;
1474     }
1475
1476   if (order != NULL && array_check (order, 3) == FAILURE)
1477     return FAILURE;
1478
1479   return SUCCESS;
1480 }
1481
1482
1483 try
1484 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1485 {
1486
1487   if (type_check (x, 0, BT_REAL) == FAILURE)
1488     return FAILURE;
1489
1490   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1491     return FAILURE;
1492
1493   return SUCCESS;
1494 }
1495
1496
1497 try
1498 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1499 {
1500
1501   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1502     return FAILURE;
1503
1504   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1505     return FAILURE;
1506
1507   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1508     return FAILURE;
1509
1510   if (same_type_check (x, 0, y, 1) == FAILURE)
1511     return FAILURE;
1512
1513   return SUCCESS;
1514 }
1515
1516
1517 try
1518 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1519 {
1520
1521   if (p == NULL && r == NULL)
1522     {
1523       gfc_error ("Missing arguments to %s intrinsic at %L",
1524                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1525
1526       return FAILURE;
1527     }
1528
1529   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1530     return FAILURE;
1531
1532   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1533     return FAILURE;
1534
1535   return SUCCESS;
1536 }
1537
1538
1539 try
1540 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1541 {
1542
1543   if (type_check (x, 0, BT_REAL) == FAILURE)
1544     return FAILURE;
1545
1546   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1547     return FAILURE;
1548
1549   return SUCCESS;
1550 }
1551
1552
1553 try
1554 gfc_check_shape (gfc_expr * source)
1555 {
1556   gfc_array_ref *ar;
1557
1558   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1559     return SUCCESS;
1560
1561   ar = gfc_find_array_ref (source);
1562
1563   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1564     {
1565       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1566                  "an assumed size array", &source->where);
1567       return FAILURE;
1568     }
1569
1570   return SUCCESS;
1571 }
1572
1573
1574 try
1575 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1576 {
1577
1578   if (array_check (array, 0) == FAILURE)
1579     return FAILURE;
1580
1581   if (dim != NULL)
1582     {
1583       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1584         return FAILURE;
1585
1586       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1587         return FAILURE;
1588
1589       if (dim_rank_check (dim, array, 0) == FAILURE)
1590         return FAILURE;
1591     }
1592
1593   return SUCCESS;
1594 }
1595
1596
1597 try
1598 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1599 {
1600
1601   if (int_or_real_check (a, 0) == FAILURE)
1602     return FAILURE;
1603
1604   if (same_type_check (a, 0, b, 1) == FAILURE)
1605     return FAILURE;
1606
1607   return SUCCESS;
1608 }
1609
1610
1611 try
1612 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1613 {
1614
1615   if (source->rank >= GFC_MAX_DIMENSIONS)
1616     {
1617       must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1618       return FAILURE;
1619     }
1620
1621   if (dim_check (dim, 1, 0) == FAILURE)
1622     return FAILURE;
1623
1624   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1625     return FAILURE;
1626   if (scalar_check (ncopies, 2) == FAILURE)
1627     return FAILURE;
1628
1629   return SUCCESS;
1630 }
1631
1632
1633 try
1634 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1635                     gfc_expr * mold ATTRIBUTE_UNUSED,
1636                     gfc_expr * size)
1637 {
1638
1639   if (size != NULL)
1640     {
1641       if (type_check (size, 2, BT_INTEGER) == FAILURE)
1642         return FAILURE;
1643
1644       if (scalar_check (size, 2) == FAILURE)
1645         return FAILURE;
1646
1647       if (nonoptional_check (size, 2) == FAILURE)
1648         return FAILURE;
1649     }
1650
1651   return SUCCESS;
1652 }
1653
1654
1655 try
1656 gfc_check_transpose (gfc_expr * matrix)
1657 {
1658
1659   if (rank_check (matrix, 0, 2) == FAILURE)
1660     return FAILURE;
1661
1662   return SUCCESS;
1663 }
1664
1665
1666 try
1667 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
1668 {
1669
1670   if (array_check (array, 0) == FAILURE)
1671     return FAILURE;
1672
1673   if (dim != NULL)
1674     {
1675       if (dim_check (dim, 1, 1) == FAILURE)
1676         return FAILURE;
1677
1678       if (dim_rank_check (dim, array, 0) == FAILURE)
1679         return FAILURE;
1680     }
1681   return SUCCESS;
1682 }
1683
1684
1685 try
1686 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1687 {
1688
1689   if (rank_check (vector, 0, 1) == FAILURE)
1690     return FAILURE;
1691
1692   if (array_check (mask, 1) == FAILURE)
1693     return FAILURE;
1694
1695   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1696     return FAILURE;
1697
1698   if (same_type_check (vector, 0, field, 2) == FAILURE)
1699     return FAILURE;
1700
1701   return SUCCESS;
1702 }
1703
1704
1705 try
1706 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1707 {
1708
1709   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1710     return FAILURE;
1711
1712   if (same_type_check (x, 0, y, 1) == FAILURE)
1713     return FAILURE;
1714
1715   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1716     return FAILURE;
1717
1718   return SUCCESS;
1719 }
1720
1721
1722 try
1723 gfc_check_trim (gfc_expr * x)
1724 {
1725   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1726     return FAILURE;
1727
1728   if (scalar_check (x, 0) == FAILURE)
1729     return FAILURE;
1730
1731    return SUCCESS;
1732 }
1733
1734
1735 /* Common check function for the half a dozen intrinsics that have a
1736    single real argument.  */
1737
1738 try
1739 gfc_check_x (gfc_expr * x)
1740 {
1741
1742   if (type_check (x, 0, BT_REAL) == FAILURE)
1743     return FAILURE;
1744
1745   return SUCCESS;
1746 }
1747
1748
1749 /************* Check functions for intrinsic subroutines *************/
1750
1751 try
1752 gfc_check_cpu_time (gfc_expr * time)
1753 {
1754
1755   if (scalar_check (time, 0) == FAILURE)
1756     return FAILURE;
1757
1758   if (type_check (time, 0, BT_REAL) == FAILURE)
1759     return FAILURE;
1760
1761   if (variable_check (time, 0) == FAILURE)
1762     return FAILURE;
1763
1764   return SUCCESS;
1765 }
1766
1767
1768 try
1769 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1770                          gfc_expr * zone, gfc_expr * values)
1771 {
1772
1773   if (date != NULL)
1774     {
1775       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1776         return FAILURE;
1777       if (scalar_check (date, 0) == FAILURE)
1778         return FAILURE;
1779       if (variable_check (date, 0) == FAILURE)
1780         return FAILURE;
1781     }
1782
1783   if (time != NULL)
1784     {
1785       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1786         return FAILURE;
1787       if (scalar_check (time, 1) == FAILURE)
1788         return FAILURE;
1789       if (variable_check (time, 1) == FAILURE)
1790         return FAILURE;
1791     }
1792
1793   if (zone != NULL)
1794     {
1795       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1796         return FAILURE;
1797       if (scalar_check (zone, 2) == FAILURE)
1798         return FAILURE;
1799       if (variable_check (zone, 2) == FAILURE)
1800         return FAILURE;
1801     }
1802
1803   if (values != NULL)
1804     {
1805       if (type_check (values, 3, BT_INTEGER) == FAILURE)
1806         return FAILURE;
1807       if (array_check (values, 3) == FAILURE)
1808         return FAILURE;
1809       if (rank_check (values, 3, 1) == FAILURE)
1810         return FAILURE;
1811       if (variable_check (values, 3) == FAILURE)
1812         return FAILURE;
1813     }
1814
1815   return SUCCESS;
1816 }
1817
1818
1819 try
1820 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1821                   gfc_expr * to, gfc_expr * topos)
1822 {
1823
1824   if (type_check (from, 0, BT_INTEGER) == FAILURE)
1825     return FAILURE;
1826
1827   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1828     return FAILURE;
1829
1830   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1831     return FAILURE;
1832
1833   if (same_type_check (from, 0, to, 3) == FAILURE)
1834     return FAILURE;
1835
1836   if (variable_check (to, 3) == FAILURE)
1837     return FAILURE;
1838
1839   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1840     return FAILURE;
1841
1842   return SUCCESS;
1843 }
1844
1845
1846 try
1847 gfc_check_random_number (gfc_expr * harvest)
1848 {
1849
1850   if (type_check (harvest, 0, BT_REAL) == FAILURE)
1851     return FAILURE;
1852
1853   if (variable_check (harvest, 0) == FAILURE)
1854     return FAILURE;
1855
1856   return SUCCESS;
1857 }
1858
1859
1860 try
1861 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1862 {
1863
1864   if (size != NULL)
1865     {
1866       if (scalar_check (size, 0) == FAILURE)
1867         return FAILURE;
1868
1869       if (type_check (size, 0, BT_INTEGER) == FAILURE)
1870         return FAILURE;
1871
1872       if (variable_check (size, 0) == FAILURE)
1873         return FAILURE;
1874
1875       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
1876         return FAILURE;
1877     }
1878
1879   if (put != NULL)
1880     {
1881
1882       if (size != NULL)
1883         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
1884                     &put->where);
1885
1886       if (array_check (put, 1) == FAILURE)
1887         return FAILURE;
1888
1889       if (rank_check (put, 1, 1) == FAILURE)
1890         return FAILURE;
1891
1892       if (type_check (put, 1, BT_INTEGER) == FAILURE)
1893         return FAILURE;
1894
1895       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
1896         return FAILURE;
1897     }
1898
1899   if (get != NULL)
1900     {
1901
1902       if (size != NULL || put != NULL)
1903         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
1904                     &get->where);
1905
1906       if (array_check (get, 2) == FAILURE)
1907         return FAILURE;
1908
1909       if (rank_check (get, 2, 1) == FAILURE)
1910         return FAILURE;
1911
1912       if (type_check (get, 2, BT_INTEGER) == FAILURE)
1913         return FAILURE;
1914
1915       if (variable_check (get, 2) == FAILURE)
1916         return FAILURE;
1917
1918       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
1919         return FAILURE;
1920     }
1921
1922   return SUCCESS;
1923 }
1924
1925 try
1926 gfc_check_second_sub (gfc_expr * time)
1927 {
1928
1929   if (scalar_check (time, 0) == FAILURE)
1930     return FAILURE;
1931
1932   if (type_check (time, 0, BT_REAL) == FAILURE)
1933     return FAILURE;
1934
1935   if (kind_value_check(time, 0, 4) == FAILURE)
1936     return FAILURE;
1937
1938   return SUCCESS;
1939 }
1940
1941
1942 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
1943    count, count_rate, and count_max are all optional arguments */
1944
1945 try
1946 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
1947                         gfc_expr * count_max)
1948 {
1949
1950   if (count != NULL)
1951     {
1952       if (scalar_check (count, 0) == FAILURE)
1953         return FAILURE;
1954
1955       if (type_check (count, 0, BT_INTEGER) == FAILURE)
1956         return FAILURE;
1957
1958       if (variable_check (count, 0) == FAILURE)
1959         return FAILURE;
1960     }
1961
1962   if (count_rate != NULL)
1963     {
1964       if (scalar_check (count_rate, 1) == FAILURE)
1965         return FAILURE;
1966
1967       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
1968         return FAILURE;
1969
1970       if (variable_check (count_rate, 1) == FAILURE)
1971         return FAILURE;
1972
1973       if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
1974         return FAILURE;
1975
1976     }
1977
1978   if (count_max != NULL)
1979     {
1980       if (scalar_check (count_max, 2) == FAILURE)
1981         return FAILURE;
1982
1983       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
1984         return FAILURE;
1985
1986       if (variable_check (count_max, 2) == FAILURE)
1987         return FAILURE;
1988
1989       if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
1990         return FAILURE;
1991
1992       if (count_rate != NULL
1993           && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
1994         return FAILURE;
1995
1996    }
1997
1998     return SUCCESS;
1999 }
2000
2001 try
2002 gfc_check_irand (gfc_expr * x)
2003 {
2004   if (x == NULL)
2005     return SUCCESS;
2006
2007   if (scalar_check (x, 0) == FAILURE)
2008     return FAILURE;
2009
2010   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2011     return FAILURE;
2012
2013   if (kind_value_check(x, 0, 4) == FAILURE)
2014     return FAILURE;
2015
2016   return SUCCESS;
2017 }
2018
2019 try
2020 gfc_check_rand (gfc_expr * x)
2021 {
2022   if (x == NULL)
2023     return SUCCESS;
2024
2025   if (scalar_check (x, 0) == FAILURE)
2026     return FAILURE;
2027
2028   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2029     return FAILURE;
2030
2031   if (kind_value_check(x, 0, 4) == FAILURE)
2032     return FAILURE;
2033
2034   return SUCCESS;
2035 }
2036
2037 try
2038 gfc_check_srand (gfc_expr * x)
2039 {
2040   if (scalar_check (x, 0) == FAILURE)
2041     return FAILURE;
2042
2043   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2044     return FAILURE;
2045
2046   if (kind_value_check(x, 0, 4) == FAILURE)
2047     return FAILURE;
2048
2049   return SUCCESS;
2050 }
2051
2052 try
2053 gfc_check_etime (gfc_expr * x)
2054 {
2055   if (array_check (x, 0) == FAILURE)
2056     return FAILURE;
2057
2058   if (rank_check (x, 0, 1) == FAILURE)
2059     return FAILURE;
2060
2061   if (variable_check (x, 0) == FAILURE)
2062     return FAILURE;
2063
2064   if (type_check (x, 0, BT_REAL) == FAILURE)
2065     return FAILURE;
2066
2067   if (kind_value_check(x, 0, 4) == FAILURE)
2068     return FAILURE;
2069
2070   return SUCCESS;
2071 }
2072
2073 try
2074 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2075 {
2076   if (array_check (values, 0) == FAILURE)
2077     return FAILURE;
2078
2079   if (rank_check (values, 0, 1) == FAILURE)
2080     return FAILURE;
2081
2082   if (variable_check (values, 0) == FAILURE)
2083     return FAILURE;
2084
2085   if (type_check (values, 0, BT_REAL) == FAILURE)
2086     return FAILURE;
2087
2088   if (kind_value_check(values, 0, 4) == FAILURE)
2089     return FAILURE;
2090
2091   if (scalar_check (time, 1) == FAILURE)
2092     return FAILURE;
2093
2094   if (type_check (time, 1, BT_REAL) == FAILURE)
2095     return FAILURE;
2096
2097   if (kind_value_check(time, 1, 4) == FAILURE)
2098     return FAILURE;
2099
2100   return SUCCESS;
2101 }
2102
2103
2104 try
2105 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2106 {
2107
2108   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2109     return FAILURE;
2110
2111   if (status == NULL)
2112     return SUCCESS;
2113
2114   if (scalar_check (status, 1) == FAILURE)
2115     return FAILURE;
2116
2117   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2118     return FAILURE;
2119
2120   return SUCCESS;
2121 }
2122
2123
2124 try
2125 gfc_check_exit (gfc_expr * status)
2126 {
2127
2128   if (status == NULL)
2129   return SUCCESS;
2130
2131   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2132     return FAILURE;
2133
2134   if (scalar_check (status, 0) == FAILURE)
2135     return FAILURE;
2136
2137   return SUCCESS;
2138 }
2139
2140
2141 try
2142 gfc_check_umask (gfc_expr * mask)
2143 {
2144
2145   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2146     return FAILURE;
2147
2148   if (scalar_check (mask, 0) == FAILURE)
2149     return FAILURE;
2150
2151   return SUCCESS;
2152 }
2153
2154
2155 try
2156 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2157 {
2158
2159   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2160     return FAILURE;
2161
2162   if (scalar_check (mask, 0) == FAILURE)
2163     return FAILURE;
2164
2165   if (old == NULL)
2166     return SUCCESS;
2167
2168   if (scalar_check (old, 1) == FAILURE)
2169     return FAILURE;
2170
2171   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2172     return FAILURE;
2173
2174   return SUCCESS;
2175 }
2176
2177
2178 try
2179 gfc_check_unlink (gfc_expr * name)
2180 {
2181
2182   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2183     return FAILURE;
2184
2185   return SUCCESS;
2186 }
2187
2188
2189 try
2190 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2191 {
2192
2193   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2194     return FAILURE;
2195
2196   if (status == NULL)
2197     return SUCCESS;
2198
2199   if (scalar_check (status, 1) == FAILURE)
2200     return FAILURE;
2201
2202   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2203     return FAILURE;
2204
2205   return SUCCESS;
2206 }
2207
2208
2209 try
2210 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2211 {
2212   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2213     return FAILURE;
2214
2215   if (scalar_check (status, 1) == FAILURE)
2216     return FAILURE;
2217
2218   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2219     return FAILURE;
2220
2221   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
2222     return FAILURE;
2223
2224   return SUCCESS;
2225 }