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 try
1215 gfc_check_loc (gfc_expr *expr)
1216 {
1217   return variable_check (expr, 0);
1218 }
1219
1220
1221 try
1222 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
1223 {
1224   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1225     return FAILURE;
1226
1227   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1228     return FAILURE;
1229
1230   return SUCCESS;
1231 }
1232
1233
1234 try
1235 gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1236 {
1237   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1238     return FAILURE;
1239
1240   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1241     return FAILURE;
1242
1243   if (status == NULL)
1244     return SUCCESS;
1245
1246   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1247     return FAILURE;
1248
1249   if (scalar_check (status, 2) == FAILURE)
1250     return FAILURE;
1251
1252   return SUCCESS;
1253 }
1254
1255
1256 try
1257 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1258 {
1259   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1260     return FAILURE;
1261   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1262     return FAILURE;
1263
1264   return SUCCESS;
1265 }
1266
1267
1268 /* Min/max family.  */
1269
1270 static try
1271 min_max_args (gfc_actual_arglist * arg)
1272 {
1273   if (arg == NULL || arg->next == NULL)
1274     {
1275       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1276                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1277       return FAILURE;
1278     }
1279
1280   return SUCCESS;
1281 }
1282
1283
1284 static try
1285 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1286 {
1287   gfc_expr *x;
1288   int n;
1289
1290   if (min_max_args (arg) == FAILURE)
1291     return FAILURE;
1292
1293   n = 1;
1294
1295   for (; arg; arg = arg->next, n++)
1296     {
1297       x = arg->expr;
1298       if (x->ts.type != type || x->ts.kind != kind)
1299         {
1300           if (x->ts.type == type)
1301             {
1302               if (gfc_notify_std (GFC_STD_GNU,
1303                     "Extension: Different type kinds at %L", &x->where)
1304                   == FAILURE)
1305                 return FAILURE;
1306             }
1307           else
1308             {
1309               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1310                          n, gfc_current_intrinsic, &x->where,
1311                          gfc_basic_typename (type), kind);
1312               return FAILURE;
1313             }
1314         }
1315     }
1316
1317   return SUCCESS;
1318 }
1319
1320
1321 try
1322 gfc_check_min_max (gfc_actual_arglist * arg)
1323 {
1324   gfc_expr *x;
1325
1326   if (min_max_args (arg) == FAILURE)
1327     return FAILURE;
1328
1329   x = arg->expr;
1330
1331   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1332     {
1333       gfc_error
1334         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1335          gfc_current_intrinsic, &x->where);
1336       return FAILURE;
1337     }
1338
1339   return check_rest (x->ts.type, x->ts.kind, arg);
1340 }
1341
1342
1343 try
1344 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1345 {
1346   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1347 }
1348
1349
1350 try
1351 gfc_check_min_max_real (gfc_actual_arglist * arg)
1352 {
1353   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1354 }
1355
1356
1357 try
1358 gfc_check_min_max_double (gfc_actual_arglist * arg)
1359 {
1360   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1361 }
1362
1363 /* End of min/max family.  */
1364
1365 try
1366 gfc_check_malloc (gfc_expr * size)
1367 {
1368   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1369     return FAILURE;
1370
1371   if (scalar_check (size, 0) == FAILURE)
1372     return FAILURE;
1373
1374   return SUCCESS;
1375 }
1376
1377
1378 try
1379 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1380 {
1381   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1382     {
1383       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1384                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1385                  gfc_current_intrinsic, &matrix_a->where);
1386       return FAILURE;
1387     }
1388
1389   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1390     {
1391       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1392                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1393                  gfc_current_intrinsic, &matrix_b->where);
1394       return FAILURE;
1395     }
1396
1397   switch (matrix_a->rank)
1398     {
1399     case 1:
1400       if (rank_check (matrix_b, 1, 2) == FAILURE)
1401         return FAILURE;
1402       break;
1403
1404     case 2:
1405       if (matrix_b->rank == 2)
1406         break;
1407       if (rank_check (matrix_b, 1, 1) == FAILURE)
1408         return FAILURE;
1409       break;
1410
1411     default:
1412       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1413                  "1 or 2", gfc_current_intrinsic_arg[0],
1414                  gfc_current_intrinsic, &matrix_a->where);
1415       return FAILURE;
1416     }
1417
1418   return SUCCESS;
1419 }
1420
1421
1422 /* Whoever came up with this interface was probably on something.
1423    The possibilities for the occupation of the second and third
1424    parameters are:
1425
1426          Arg #2     Arg #3
1427          NULL       NULL
1428          DIM        NULL
1429          MASK       NULL
1430          NULL       MASK             minloc(array, mask=m)
1431          DIM        MASK
1432
1433    I.e. in the case of minloc(array,mask), mask will be in the second
1434    position of the argument list and we'll have to fix that up.  */
1435
1436 try
1437 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1438 {
1439   gfc_expr *a, *m, *d;
1440
1441   a = ap->expr;
1442   if (int_or_real_check (a, 0) == FAILURE
1443       || array_check (a, 0) == FAILURE)
1444     return FAILURE;
1445
1446   d = ap->next->expr;
1447   m = ap->next->next->expr;
1448
1449   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1450       && ap->next->name == NULL)
1451     {
1452       m = d;
1453       d = NULL;
1454
1455       ap->next->expr = NULL;
1456       ap->next->next->expr = m;
1457     }
1458
1459   if (d != NULL
1460       && (scalar_check (d, 1) == FAILURE
1461       || type_check (d, 1, BT_INTEGER) == FAILURE))
1462     return FAILURE;
1463
1464   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1465     return FAILURE;
1466
1467   return SUCCESS;
1468 }
1469
1470
1471 /* Similar to minloc/maxloc, the argument list might need to be
1472    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1473    difference is that MINLOC/MAXLOC take an additional KIND argument.
1474    The possibilities are:
1475
1476          Arg #2     Arg #3
1477          NULL       NULL
1478          DIM        NULL
1479          MASK       NULL
1480          NULL       MASK             minval(array, mask=m)
1481          DIM        MASK
1482
1483    I.e. in the case of minval(array,mask), mask will be in the second
1484    position of the argument list and we'll have to fix that up.  */
1485
1486 static try
1487 check_reduction (gfc_actual_arglist * ap)
1488 {
1489   gfc_expr *m, *d;
1490
1491   d = ap->next->expr;
1492   m = ap->next->next->expr;
1493
1494   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1495       && ap->next->name == NULL)
1496     {
1497       m = d;
1498       d = NULL;
1499
1500       ap->next->expr = NULL;
1501       ap->next->next->expr = m;
1502     }
1503
1504   if (d != NULL
1505       && (scalar_check (d, 1) == FAILURE
1506       || type_check (d, 1, BT_INTEGER) == FAILURE))
1507     return FAILURE;
1508
1509   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1510     return FAILURE;
1511
1512   return SUCCESS;
1513 }
1514
1515
1516 try
1517 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1518 {
1519   if (int_or_real_check (ap->expr, 0) == FAILURE
1520       || array_check (ap->expr, 0) == FAILURE)
1521     return FAILURE;
1522
1523   return check_reduction (ap);
1524 }
1525
1526
1527 try
1528 gfc_check_product_sum (gfc_actual_arglist * ap)
1529 {
1530   if (numeric_check (ap->expr, 0) == FAILURE
1531       || array_check (ap->expr, 0) == FAILURE)
1532     return FAILURE;
1533
1534   return check_reduction (ap);
1535 }
1536
1537
1538 try
1539 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1540 {
1541   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1542     return FAILURE;
1543
1544   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1545     return FAILURE;
1546
1547   return SUCCESS;
1548 }
1549
1550
1551 try
1552 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1553 {
1554   if (type_check (x, 0, BT_REAL) == FAILURE)
1555     return FAILURE;
1556
1557   if (type_check (s, 1, BT_REAL) == FAILURE)
1558     return FAILURE;
1559
1560   return SUCCESS;
1561 }
1562
1563
1564 try
1565 gfc_check_null (gfc_expr * mold)
1566 {
1567   symbol_attribute attr;
1568
1569   if (mold == NULL)
1570     return SUCCESS;
1571
1572   if (variable_check (mold, 0) == FAILURE)
1573     return FAILURE;
1574
1575   attr = gfc_variable_attr (mold, NULL);
1576
1577   if (!attr.pointer)
1578     {
1579       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1580                  gfc_current_intrinsic_arg[0],
1581                  gfc_current_intrinsic, &mold->where);
1582       return FAILURE;
1583     }
1584
1585   return SUCCESS;
1586 }
1587
1588
1589 try
1590 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1591 {
1592   if (array_check (array, 0) == FAILURE)
1593     return FAILURE;
1594
1595   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1596     return FAILURE;
1597
1598   if (mask->rank != 0 && mask->rank != array->rank)
1599     {
1600       gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
1601                  "with '%s' argument", gfc_current_intrinsic_arg[0],
1602                  gfc_current_intrinsic, &array->where,
1603                  gfc_current_intrinsic_arg[1]);
1604       return FAILURE;
1605     }
1606
1607   if (vector != NULL)
1608     {
1609       if (same_type_check (array, 0, vector, 2) == FAILURE)
1610         return FAILURE;
1611
1612       if (rank_check (vector, 2, 1) == FAILURE)
1613         return FAILURE;
1614
1615       /* TODO: More constraints here.  */
1616     }
1617
1618   return SUCCESS;
1619 }
1620
1621
1622 try
1623 gfc_check_precision (gfc_expr * x)
1624 {
1625   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1626     {
1627       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1628                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1629                  gfc_current_intrinsic, &x->where);
1630       return FAILURE;
1631     }
1632
1633   return SUCCESS;
1634 }
1635
1636
1637 try
1638 gfc_check_present (gfc_expr * a)
1639 {
1640   gfc_symbol *sym;
1641
1642   if (variable_check (a, 0) == FAILURE)
1643     return FAILURE;
1644
1645   sym = a->symtree->n.sym;
1646   if (!sym->attr.dummy)
1647     {
1648       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1649                  "dummy variable", gfc_current_intrinsic_arg[0],
1650                  gfc_current_intrinsic, &a->where);
1651       return FAILURE;
1652     }
1653
1654   if (!sym->attr.optional)
1655     {
1656       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1657                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1658                  gfc_current_intrinsic, &a->where);
1659       return FAILURE;
1660     }
1661
1662   return SUCCESS;
1663 }
1664
1665
1666 try
1667 gfc_check_radix (gfc_expr * x)
1668 {
1669   if (int_or_real_check (x, 0) == FAILURE)
1670     return FAILURE;
1671
1672   return SUCCESS;
1673 }
1674
1675
1676 try
1677 gfc_check_range (gfc_expr * x)
1678 {
1679   if (numeric_check (x, 0) == FAILURE)
1680     return FAILURE;
1681
1682   return SUCCESS;
1683 }
1684
1685
1686 /* real, float, sngl.  */
1687 try
1688 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1689 {
1690   if (numeric_check (a, 0) == FAILURE)
1691     return FAILURE;
1692
1693   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1694     return FAILURE;
1695
1696   return SUCCESS;
1697 }
1698
1699
1700 try
1701 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
1702 {
1703   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1704     return FAILURE;
1705
1706   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1707     return FAILURE;
1708
1709   return SUCCESS;
1710 }
1711
1712
1713 try
1714 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1715 {
1716   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1717     return FAILURE;
1718
1719   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1720     return FAILURE;
1721
1722   if (status == NULL)
1723     return SUCCESS;
1724
1725   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1726     return FAILURE;
1727
1728   if (scalar_check (status, 2) == FAILURE)
1729     return FAILURE;
1730
1731   return SUCCESS;
1732 }
1733
1734
1735 try
1736 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1737 {
1738   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1739     return FAILURE;
1740
1741   if (scalar_check (x, 0) == FAILURE)
1742     return FAILURE;
1743
1744   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1745     return FAILURE;
1746
1747   if (scalar_check (y, 1) == FAILURE)
1748     return FAILURE;
1749
1750   return SUCCESS;
1751 }
1752
1753
1754 try
1755 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1756                    gfc_expr * pad, gfc_expr * order)
1757 {
1758   mpz_t size;
1759   int m;
1760
1761   if (array_check (source, 0) == FAILURE)
1762     return FAILURE;
1763
1764   if (rank_check (shape, 1, 1) == FAILURE)
1765     return FAILURE;
1766
1767   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1768     return FAILURE;
1769
1770   if (gfc_array_size (shape, &size) != SUCCESS)
1771     {
1772       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1773                  "array of constant size", &shape->where);
1774       return FAILURE;
1775     }
1776
1777   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1778   mpz_clear (size);
1779
1780   if (m > 0)
1781     {
1782       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
1783                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
1784       return FAILURE;
1785     }
1786
1787   if (pad != NULL)
1788     {
1789       if (same_type_check (source, 0, pad, 2) == FAILURE)
1790         return FAILURE;
1791       if (array_check (pad, 2) == FAILURE)
1792         return FAILURE;
1793     }
1794
1795   if (order != NULL && array_check (order, 3) == FAILURE)
1796     return FAILURE;
1797
1798   return SUCCESS;
1799 }
1800
1801
1802 try
1803 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1804 {
1805   if (type_check (x, 0, BT_REAL) == FAILURE)
1806     return FAILURE;
1807
1808   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1809     return FAILURE;
1810
1811   return SUCCESS;
1812 }
1813
1814
1815 try
1816 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1817 {
1818   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1819     return FAILURE;
1820
1821   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1822     return FAILURE;
1823
1824   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1825     return FAILURE;
1826
1827   if (same_type_check (x, 0, y, 1) == FAILURE)
1828     return FAILURE;
1829
1830   return SUCCESS;
1831 }
1832
1833
1834 try
1835 gfc_check_selected_int_kind (gfc_expr * r)
1836 {
1837
1838   if (type_check (r, 0, BT_INTEGER) == FAILURE)
1839     return FAILURE;
1840
1841   if (scalar_check (r, 0) == FAILURE)
1842     return FAILURE;
1843
1844   return SUCCESS;
1845 }
1846
1847
1848 try
1849 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1850 {
1851   if (p == NULL && r == NULL)
1852     {
1853       gfc_error ("Missing arguments to %s intrinsic at %L",
1854                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1855
1856       return FAILURE;
1857     }
1858
1859   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1860     return FAILURE;
1861
1862   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1863     return FAILURE;
1864
1865   return SUCCESS;
1866 }
1867
1868
1869 try
1870 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1871 {
1872   if (type_check (x, 0, BT_REAL) == FAILURE)
1873     return FAILURE;
1874
1875   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1876     return FAILURE;
1877
1878   return SUCCESS;
1879 }
1880
1881
1882 try
1883 gfc_check_shape (gfc_expr * source)
1884 {
1885   gfc_array_ref *ar;
1886
1887   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1888     return SUCCESS;
1889
1890   ar = gfc_find_array_ref (source);
1891
1892   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1893     {
1894       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1895                  "an assumed size array", &source->where);
1896       return FAILURE;
1897     }
1898
1899   return SUCCESS;
1900 }
1901
1902
1903 try
1904 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1905 {
1906   if (int_or_real_check (a, 0) == FAILURE)
1907     return FAILURE;
1908
1909   if (same_type_check (a, 0, b, 1) == FAILURE)
1910     return FAILURE;
1911
1912   return SUCCESS;
1913 }
1914
1915
1916 try
1917 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1918 {
1919   if (array_check (array, 0) == FAILURE)
1920     return FAILURE;
1921
1922   if (dim != NULL)
1923     {
1924       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1925         return FAILURE;
1926
1927       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1928         return FAILURE;
1929
1930       if (dim_rank_check (dim, array, 0) == FAILURE)
1931         return FAILURE;
1932     }
1933
1934   return SUCCESS;
1935 }
1936
1937
1938 try
1939 gfc_check_sleep_sub (gfc_expr * seconds)
1940 {
1941   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
1942     return FAILURE;
1943
1944   if (scalar_check (seconds, 0) == FAILURE)
1945     return FAILURE;
1946
1947   return SUCCESS;
1948 }
1949
1950
1951 try
1952 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1953 {
1954   if (source->rank >= GFC_MAX_DIMENSIONS)
1955     {
1956       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
1957                  "than rank %d", gfc_current_intrinsic_arg[0],
1958                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
1959
1960       return FAILURE;
1961     }
1962
1963   if (dim_check (dim, 1, 0) == FAILURE)
1964     return FAILURE;
1965
1966   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1967     return FAILURE;
1968
1969   if (scalar_check (ncopies, 2) == FAILURE)
1970     return FAILURE;
1971
1972   return SUCCESS;
1973 }
1974
1975
1976 try
1977 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
1978 {
1979   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1980     return FAILURE;
1981
1982   if (scalar_check (unit, 0) == FAILURE)
1983     return FAILURE;
1984
1985   if (type_check (array, 1, BT_INTEGER) == FAILURE
1986       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
1987     return FAILURE;
1988
1989   if (array_check (array, 1) == FAILURE)
1990     return FAILURE;
1991
1992   return SUCCESS;
1993 }
1994
1995
1996 try
1997 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
1998 {
1999   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2000     return FAILURE;
2001
2002   if (scalar_check (unit, 0) == FAILURE)
2003     return FAILURE;
2004
2005   if (type_check (array, 1, BT_INTEGER) == FAILURE
2006       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2007     return FAILURE;
2008
2009   if (array_check (array, 1) == FAILURE)
2010     return FAILURE;
2011
2012   if (status == NULL)
2013     return SUCCESS;
2014
2015   if (type_check (status, 2, BT_INTEGER) == FAILURE
2016       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2017     return FAILURE;
2018
2019   if (scalar_check (status, 2) == FAILURE)
2020     return FAILURE;
2021
2022   return SUCCESS;
2023 }
2024
2025
2026 try
2027 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2028 {
2029   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2030     return FAILURE;
2031
2032   if (type_check (array, 1, BT_INTEGER) == FAILURE
2033       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2034     return FAILURE;
2035
2036   if (array_check (array, 1) == FAILURE)
2037     return FAILURE;
2038
2039   return SUCCESS;
2040 }
2041
2042
2043 try
2044 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2045 {
2046   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2047     return FAILURE;
2048
2049   if (type_check (array, 1, BT_INTEGER) == FAILURE
2050       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2051     return FAILURE;
2052
2053   if (array_check (array, 1) == FAILURE)
2054     return FAILURE;
2055
2056   if (status == NULL)
2057     return SUCCESS;
2058
2059   if (type_check (status, 2, BT_INTEGER) == FAILURE
2060       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2061     return FAILURE;
2062
2063   if (scalar_check (status, 2) == FAILURE)
2064     return FAILURE;
2065
2066   return SUCCESS;
2067 }
2068
2069
2070 try
2071 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2072                     gfc_expr * mold ATTRIBUTE_UNUSED,
2073                     gfc_expr * size)
2074 {
2075   if (size != NULL)
2076     {
2077       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2078         return FAILURE;
2079
2080       if (scalar_check (size, 2) == FAILURE)
2081         return FAILURE;
2082
2083       if (nonoptional_check (size, 2) == FAILURE)
2084         return FAILURE;
2085     }
2086
2087   return SUCCESS;
2088 }
2089
2090
2091 try
2092 gfc_check_transpose (gfc_expr * matrix)
2093 {
2094   if (rank_check (matrix, 0, 2) == FAILURE)
2095     return FAILURE;
2096
2097   return SUCCESS;
2098 }
2099
2100
2101 try
2102 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2103 {
2104   if (array_check (array, 0) == FAILURE)
2105     return FAILURE;
2106
2107   if (dim != NULL)
2108     {
2109       if (dim_check (dim, 1, 1) == FAILURE)
2110         return FAILURE;
2111
2112       if (dim_rank_check (dim, array, 0) == FAILURE)
2113         return FAILURE;
2114     }
2115
2116   return SUCCESS;
2117 }
2118
2119
2120 try
2121 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2122 {
2123   if (rank_check (vector, 0, 1) == FAILURE)
2124     return FAILURE;
2125
2126   if (array_check (mask, 1) == FAILURE)
2127     return FAILURE;
2128
2129   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2130     return FAILURE;
2131
2132   if (same_type_check (vector, 0, field, 2) == FAILURE)
2133     return FAILURE;
2134
2135   return SUCCESS;
2136 }
2137
2138
2139 try
2140 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2141 {
2142   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2143     return FAILURE;
2144
2145   if (same_type_check (x, 0, y, 1) == FAILURE)
2146     return FAILURE;
2147
2148   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2149     return FAILURE;
2150
2151   return SUCCESS;
2152 }
2153
2154
2155 try
2156 gfc_check_trim (gfc_expr * x)
2157 {
2158   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2159     return FAILURE;
2160
2161   if (scalar_check (x, 0) == FAILURE)
2162     return FAILURE;
2163
2164    return SUCCESS;
2165 }
2166
2167
2168 /* Common check function for the half a dozen intrinsics that have a
2169    single real argument.  */
2170
2171 try
2172 gfc_check_x (gfc_expr * x)
2173 {
2174   if (type_check (x, 0, BT_REAL) == FAILURE)
2175     return FAILURE;
2176
2177   return SUCCESS;
2178 }
2179
2180
2181 /************* Check functions for intrinsic subroutines *************/
2182
2183 try
2184 gfc_check_cpu_time (gfc_expr * time)
2185 {
2186   if (scalar_check (time, 0) == FAILURE)
2187     return FAILURE;
2188
2189   if (type_check (time, 0, BT_REAL) == FAILURE)
2190     return FAILURE;
2191
2192   if (variable_check (time, 0) == FAILURE)
2193     return FAILURE;
2194
2195   return SUCCESS;
2196 }
2197
2198
2199 try
2200 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2201                          gfc_expr * zone, gfc_expr * values)
2202 {
2203   if (date != NULL)
2204     {
2205       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2206         return FAILURE;
2207       if (scalar_check (date, 0) == FAILURE)
2208         return FAILURE;
2209       if (variable_check (date, 0) == FAILURE)
2210         return FAILURE;
2211     }
2212
2213   if (time != NULL)
2214     {
2215       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2216         return FAILURE;
2217       if (scalar_check (time, 1) == FAILURE)
2218         return FAILURE;
2219       if (variable_check (time, 1) == FAILURE)
2220         return FAILURE;
2221     }
2222
2223   if (zone != NULL)
2224     {
2225       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2226         return FAILURE;
2227       if (scalar_check (zone, 2) == FAILURE)
2228         return FAILURE;
2229       if (variable_check (zone, 2) == FAILURE)
2230         return FAILURE;
2231     }
2232
2233   if (values != NULL)
2234     {
2235       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2236         return FAILURE;
2237       if (array_check (values, 3) == FAILURE)
2238         return FAILURE;
2239       if (rank_check (values, 3, 1) == FAILURE)
2240         return FAILURE;
2241       if (variable_check (values, 3) == FAILURE)
2242         return FAILURE;
2243     }
2244
2245   return SUCCESS;
2246 }
2247
2248
2249 try
2250 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2251                   gfc_expr * to, gfc_expr * topos)
2252 {
2253   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2254     return FAILURE;
2255
2256   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2257     return FAILURE;
2258
2259   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2260     return FAILURE;
2261
2262   if (same_type_check (from, 0, to, 3) == FAILURE)
2263     return FAILURE;
2264
2265   if (variable_check (to, 3) == FAILURE)
2266     return FAILURE;
2267
2268   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2269     return FAILURE;
2270
2271   return SUCCESS;
2272 }
2273
2274
2275 try
2276 gfc_check_random_number (gfc_expr * harvest)
2277 {
2278   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2279     return FAILURE;
2280
2281   if (variable_check (harvest, 0) == FAILURE)
2282     return FAILURE;
2283
2284   return SUCCESS;
2285 }
2286
2287
2288 try
2289 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2290 {
2291   if (size != NULL)
2292     {
2293       if (scalar_check (size, 0) == FAILURE)
2294         return FAILURE;
2295
2296       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2297         return FAILURE;
2298
2299       if (variable_check (size, 0) == FAILURE)
2300         return FAILURE;
2301
2302       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2303         return FAILURE;
2304     }
2305
2306   if (put != NULL)
2307     {
2308
2309       if (size != NULL)
2310         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2311                     &put->where);
2312
2313       if (array_check (put, 1) == FAILURE)
2314         return FAILURE;
2315
2316       if (rank_check (put, 1, 1) == FAILURE)
2317         return FAILURE;
2318
2319       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2320         return FAILURE;
2321
2322       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2323         return FAILURE;
2324     }
2325
2326   if (get != NULL)
2327     {
2328
2329       if (size != NULL || put != NULL)
2330         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2331                     &get->where);
2332
2333       if (array_check (get, 2) == FAILURE)
2334         return FAILURE;
2335
2336       if (rank_check (get, 2, 1) == FAILURE)
2337         return FAILURE;
2338
2339       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2340         return FAILURE;
2341
2342       if (variable_check (get, 2) == FAILURE)
2343         return FAILURE;
2344
2345       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2346         return FAILURE;
2347     }
2348
2349   return SUCCESS;
2350 }
2351
2352 try
2353 gfc_check_second_sub (gfc_expr * time)
2354 {
2355   if (scalar_check (time, 0) == FAILURE)
2356     return FAILURE;
2357
2358   if (type_check (time, 0, BT_REAL) == FAILURE)
2359     return FAILURE;
2360
2361   if (kind_value_check(time, 0, 4) == FAILURE)
2362     return FAILURE;
2363
2364   return SUCCESS;
2365 }
2366
2367
2368 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2369    count, count_rate, and count_max are all optional arguments */
2370
2371 try
2372 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2373                         gfc_expr * count_max)
2374 {
2375   if (count != NULL)
2376     {
2377       if (scalar_check (count, 0) == FAILURE)
2378         return FAILURE;
2379
2380       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2381         return FAILURE;
2382
2383       if (variable_check (count, 0) == FAILURE)
2384         return FAILURE;
2385     }
2386
2387   if (count_rate != NULL)
2388     {
2389       if (scalar_check (count_rate, 1) == FAILURE)
2390         return FAILURE;
2391
2392       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2393         return FAILURE;
2394
2395       if (variable_check (count_rate, 1) == FAILURE)
2396         return FAILURE;
2397
2398       if (count != NULL
2399           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2400         return FAILURE;
2401
2402     }
2403
2404   if (count_max != NULL)
2405     {
2406       if (scalar_check (count_max, 2) == FAILURE)
2407         return FAILURE;
2408
2409       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2410         return FAILURE;
2411
2412       if (variable_check (count_max, 2) == FAILURE)
2413         return FAILURE;
2414
2415       if (count != NULL
2416           && same_type_check (count, 0, count_max, 2) == FAILURE)
2417         return FAILURE;
2418
2419       if (count_rate != NULL
2420           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2421         return FAILURE;
2422     }
2423
2424   return SUCCESS;
2425 }
2426
2427 try
2428 gfc_check_irand (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
2446 try
2447 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2448 {
2449   if (scalar_check (seconds, 0) == FAILURE)
2450     return FAILURE;
2451
2452   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2453     return FAILURE;
2454
2455   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2456     {
2457       gfc_error (
2458         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2459         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2460       return FAILURE;
2461     }
2462
2463   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2464     return FAILURE;
2465
2466   if (status == NULL)
2467     return SUCCESS;
2468
2469   if (scalar_check (status, 2) == FAILURE)
2470     return FAILURE;
2471
2472   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2473     return FAILURE;
2474
2475   return SUCCESS;
2476 }
2477
2478
2479 try
2480 gfc_check_rand (gfc_expr * x)
2481 {
2482   if (x == NULL)
2483     return SUCCESS;
2484
2485   if (scalar_check (x, 0) == FAILURE)
2486     return FAILURE;
2487
2488   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2489     return FAILURE;
2490
2491   if (kind_value_check(x, 0, 4) == FAILURE)
2492     return FAILURE;
2493
2494   return SUCCESS;
2495 }
2496
2497 try
2498 gfc_check_srand (gfc_expr * x)
2499 {
2500   if (scalar_check (x, 0) == FAILURE)
2501     return FAILURE;
2502
2503   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2504     return FAILURE;
2505
2506   if (kind_value_check(x, 0, 4) == FAILURE)
2507     return FAILURE;
2508
2509   return SUCCESS;
2510 }
2511
2512 try
2513 gfc_check_etime (gfc_expr * x)
2514 {
2515   if (array_check (x, 0) == FAILURE)
2516     return FAILURE;
2517
2518   if (rank_check (x, 0, 1) == FAILURE)
2519     return FAILURE;
2520
2521   if (variable_check (x, 0) == FAILURE)
2522     return FAILURE;
2523
2524   if (type_check (x, 0, BT_REAL) == FAILURE)
2525     return FAILURE;
2526
2527   if (kind_value_check(x, 0, 4) == FAILURE)
2528     return FAILURE;
2529
2530   return SUCCESS;
2531 }
2532
2533 try
2534 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2535 {
2536   if (array_check (values, 0) == FAILURE)
2537     return FAILURE;
2538
2539   if (rank_check (values, 0, 1) == FAILURE)
2540     return FAILURE;
2541
2542   if (variable_check (values, 0) == FAILURE)
2543     return FAILURE;
2544
2545   if (type_check (values, 0, BT_REAL) == FAILURE)
2546     return FAILURE;
2547
2548   if (kind_value_check(values, 0, 4) == FAILURE)
2549     return FAILURE;
2550
2551   if (scalar_check (time, 1) == FAILURE)
2552     return FAILURE;
2553
2554   if (type_check (time, 1, BT_REAL) == FAILURE)
2555     return FAILURE;
2556
2557   if (kind_value_check(time, 1, 4) == FAILURE)
2558     return FAILURE;
2559
2560   return SUCCESS;
2561 }
2562
2563
2564 try
2565 gfc_check_gerror (gfc_expr * msg)
2566 {
2567   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2568     return FAILURE;
2569
2570   return SUCCESS;
2571 }
2572
2573
2574 try
2575 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2576 {
2577   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2578     return FAILURE;
2579
2580   if (status == NULL)
2581     return SUCCESS;
2582
2583   if (scalar_check (status, 1) == FAILURE)
2584     return FAILURE;
2585
2586   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2587     return FAILURE;
2588
2589   return SUCCESS;
2590 }
2591
2592
2593 try
2594 gfc_check_getlog (gfc_expr * msg)
2595 {
2596   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2597     return FAILURE;
2598
2599   return SUCCESS;
2600 }
2601
2602
2603 try
2604 gfc_check_exit (gfc_expr * status)
2605 {
2606   if (status == NULL)
2607     return SUCCESS;
2608
2609   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2610     return FAILURE;
2611
2612   if (scalar_check (status, 0) == FAILURE)
2613     return FAILURE;
2614
2615   return SUCCESS;
2616 }
2617
2618
2619 try
2620 gfc_check_flush (gfc_expr * unit)
2621 {
2622   if (unit == NULL)
2623     return SUCCESS;
2624
2625   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2626     return FAILURE;
2627
2628   if (scalar_check (unit, 0) == FAILURE)
2629     return FAILURE;
2630
2631   return SUCCESS;
2632 }
2633
2634
2635 try
2636 gfc_check_free (gfc_expr * i)
2637 {
2638   if (type_check (i, 0, BT_INTEGER) == FAILURE)
2639     return FAILURE;
2640
2641   if (scalar_check (i, 0) == FAILURE)
2642     return FAILURE;
2643
2644   return SUCCESS;
2645 }
2646
2647
2648 try
2649 gfc_check_hostnm (gfc_expr * name)
2650 {
2651   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2652     return FAILURE;
2653
2654   return SUCCESS;
2655 }
2656
2657
2658 try
2659 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
2660 {
2661   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2662     return FAILURE;
2663
2664   if (status == NULL)
2665     return SUCCESS;
2666
2667   if (scalar_check (status, 1) == FAILURE)
2668     return FAILURE;
2669
2670   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2671     return FAILURE;
2672
2673   return SUCCESS;
2674 }
2675
2676
2677 try
2678 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
2679 {
2680   if (scalar_check (unit, 0) == FAILURE)
2681     return FAILURE;
2682
2683   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2684     return FAILURE;
2685
2686   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
2687     return FAILURE;
2688
2689   return SUCCESS;
2690 }
2691
2692
2693 try
2694 gfc_check_isatty (gfc_expr * unit)
2695 {
2696   if (unit == NULL)
2697     return FAILURE;
2698
2699   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2700     return FAILURE;
2701
2702   if (scalar_check (unit, 0) == FAILURE)
2703     return FAILURE;
2704
2705   return SUCCESS;
2706 }
2707
2708
2709 try
2710 gfc_check_perror (gfc_expr * string)
2711 {
2712   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
2713     return FAILURE;
2714
2715   return SUCCESS;
2716 }
2717
2718
2719 try
2720 gfc_check_umask (gfc_expr * mask)
2721 {
2722   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2723     return FAILURE;
2724
2725   if (scalar_check (mask, 0) == FAILURE)
2726     return FAILURE;
2727
2728   return SUCCESS;
2729 }
2730
2731
2732 try
2733 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2734 {
2735   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2736     return FAILURE;
2737
2738   if (scalar_check (mask, 0) == FAILURE)
2739     return FAILURE;
2740
2741   if (old == NULL)
2742     return SUCCESS;
2743
2744   if (scalar_check (old, 1) == FAILURE)
2745     return FAILURE;
2746
2747   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2748     return FAILURE;
2749
2750   return SUCCESS;
2751 }
2752
2753
2754 try
2755 gfc_check_unlink (gfc_expr * name)
2756 {
2757   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2758     return FAILURE;
2759
2760   return SUCCESS;
2761 }
2762
2763
2764 try
2765 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2766 {
2767   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2768     return FAILURE;
2769
2770   if (status == NULL)
2771     return SUCCESS;
2772
2773   if (scalar_check (status, 1) == FAILURE)
2774     return FAILURE;
2775
2776   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2777     return FAILURE;
2778
2779   return SUCCESS;
2780 }
2781
2782
2783 try
2784 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
2785 {
2786   if (scalar_check (number, 0) == FAILURE)
2787     return FAILURE;
2788
2789   if (type_check (number, 0, BT_INTEGER) == FAILURE)
2790     return FAILURE;
2791
2792   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2793     {
2794       gfc_error (
2795         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2796         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2797       return FAILURE;
2798     }
2799
2800   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2801     return FAILURE;
2802
2803   return SUCCESS;
2804 }
2805
2806
2807 try
2808 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
2809 {
2810   if (scalar_check (number, 0) == FAILURE)
2811     return FAILURE;
2812
2813   if (type_check (number, 0, BT_INTEGER) == FAILURE)
2814     return FAILURE;
2815
2816   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2817     {
2818       gfc_error (
2819         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2820         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2821       return FAILURE;
2822     }
2823
2824   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2825     return FAILURE;
2826
2827   if (status == NULL)
2828     return SUCCESS;
2829
2830   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2831     return FAILURE;
2832
2833   if (scalar_check (status, 2) == FAILURE)
2834     return FAILURE;
2835
2836   return SUCCESS;
2837 }
2838
2839
2840 try
2841 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2842 {
2843   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2844     return FAILURE;
2845
2846   if (scalar_check (status, 1) == FAILURE)
2847     return FAILURE;
2848
2849   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2850     return FAILURE;
2851
2852   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
2853     return FAILURE;
2854
2855   return SUCCESS;
2856 }