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