gcc/fortran/check.c

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