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