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_ctime (gfc_expr * time)
 671 {
 672   if (scalar_check (time, 0) == FAILURE)
 673     return FAILURE;
 674
 675   if (type_check (time, 0, BT_INTEGER) == FAILURE)
 676     return FAILURE;
 677
 678   return SUCCESS;
 679 }
 680
 681
 682 try
 683 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 684 {
 685   if (numeric_check (x, 0) == FAILURE)
 686     return FAILURE;
 687
 688   if (y != NULL)
 689     {
 690       if (numeric_check (y, 1) == FAILURE)
 691         return FAILURE;
 692
 693       if (x->ts.type == BT_COMPLEX)
 694         {
 695           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 696                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 697                      gfc_current_intrinsic, &y->where);
 698           return FAILURE;
 699         }
 700     }
 701
 702   return SUCCESS;
 703 }
 704
 705
 706 try
 707 gfc_check_dble (gfc_expr * x)
 708 {
 709   if (numeric_check (x, 0) == FAILURE)
 710     return FAILURE;
 711
 712   return SUCCESS;
 713 }
 714
 715
 716 try
 717 gfc_check_digits (gfc_expr * x)
 718 {
 719   if (int_or_real_check (x, 0) == FAILURE)
 720     return FAILURE;
 721
 722   return SUCCESS;
 723 }
 724
 725
 726 try
 727 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
 728 {
 729   switch (vector_a->ts.type)
 730     {
 731     case BT_LOGICAL:
 732       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 733         return FAILURE;
 734       break;
 735
 736     case BT_INTEGER:
 737     case BT_REAL:
 738     case BT_COMPLEX:
 739       if (numeric_check (vector_b, 1) == FAILURE)
 740         return FAILURE;
 741       break;
 742
 743     default:
 744       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
 745                  "or LOGICAL", gfc_current_intrinsic_arg[0],
 746                  gfc_current_intrinsic, &vector_a->where);
 747       return FAILURE;
 748     }
 749
 750   if (rank_check (vector_a, 0, 1) == FAILURE)
 751     return FAILURE;
 752
 753   if (rank_check (vector_b, 1, 1) == FAILURE)
 754     return FAILURE;
 755
 756   return SUCCESS;
 757 }
 758
 759
 760 try
 761 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
 762                    gfc_expr * dim)
 763 {
 764   if (array_check (array, 0) == FAILURE)
 765     return FAILURE;
 766
 767   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 768     return FAILURE;
 769
 770   if (array->rank == 1)
 771     {
 772       if (scalar_check (shift, 2) == FAILURE)
 773         return FAILURE;
 774     }
 775   else
 776     {
 777       /* TODO: more weird restrictions on shift.  */
 778     }
 779
 780   if (boundary != NULL)
 781     {
 782       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 783         return FAILURE;
 784
 785       /* TODO: more restrictions on boundary.  */
 786     }
 787
 788   if (dim_check (dim, 1, 1) == FAILURE)
 789     return FAILURE;
 790
 791   return SUCCESS;
 792 }
 793
 794
 795 /* A single complex argument.  */
 796
 797 try
 798 gfc_check_fn_c (gfc_expr * a)
 799 {
 800   if (type_check (a, 0, BT_COMPLEX) == FAILURE)
 801     return FAILURE;
 802
 803   return SUCCESS;
 804 }
 805
 806
 807 /* A single real argument.  */
 808
 809 try
 810 gfc_check_fn_r (gfc_expr * a)
 811 {
 812   if (type_check (a, 0, BT_REAL) == FAILURE)
 813     return FAILURE;
 814
 815   return SUCCESS;
 816 }
 817
 818
 819 /* A single real or complex argument.  */
 820
 821 try
 822 gfc_check_fn_rc (gfc_expr * a)
 823 {
 824   if (real_or_complex_check (a, 0) == FAILURE)
 825     return FAILURE;
 826
 827   return SUCCESS;
 828 }
 829
 830
 831 try
 832 gfc_check_fnum (gfc_expr * unit)
 833 {
 834   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
 835     return FAILURE;
 836
 837   if (scalar_check (unit, 0) == FAILURE)
 838     return FAILURE;
 839
 840   return SUCCESS;
 841 }
 842
 843
 844 /* This is used for the g77 one-argument Bessel functions, and the
 845    error function.  */
 846
 847 try
 848 gfc_check_g77_math1 (gfc_expr * x)
 849 {
 850   if (scalar_check (x, 0) == FAILURE)
 851     return FAILURE;
 852
 853   if (type_check (x, 0, BT_REAL) == FAILURE)
 854     return FAILURE;
 855
 856   return SUCCESS;
 857 }
 858
 859
 860 try
 861 gfc_check_huge (gfc_expr * x)
 862 {
 863   if (int_or_real_check (x, 0) == FAILURE)
 864     return FAILURE;
 865
 866   return SUCCESS;
 867 }
 868
 869
 870 /* Check that the single argument is an integer.  */
 871
 872 try
 873 gfc_check_i (gfc_expr * i)
 874 {
 875   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 876     return FAILURE;
 877
 878   return SUCCESS;
 879 }
 880
 881
 882 try
 883 gfc_check_iand (gfc_expr * i, gfc_expr * j)
 884 {
 885   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 886     return FAILURE;
 887
 888   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 889     return FAILURE;
 890
 891   if (i->ts.kind != j->ts.kind)
 892     {
 893       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 894                           &i->where) == FAILURE)
 895         return FAILURE;
 896     }
 897
 898   return SUCCESS;
 899 }
 900
 901
 902 try
 903 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
 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   return SUCCESS;
 912 }
 913
 914
 915 try
 916 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
 917 {
 918   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 919     return FAILURE;
 920
 921   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 922     return FAILURE;
 923
 924   if (type_check (len, 2, BT_INTEGER) == FAILURE)
 925     return FAILURE;
 926
 927   return SUCCESS;
 928 }
 929
 930
 931 try
 932 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
 933 {
 934   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 935     return FAILURE;
 936
 937   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 938     return FAILURE;
 939
 940   return SUCCESS;
 941 }
 942
 943
 944 try
 945 gfc_check_ichar_iachar (gfc_expr * c)
 946 {
 947   int i;
 948
 949   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
 950     return FAILURE;
 951
 952   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
 953     {
 954       gfc_expr *start;
 955       gfc_expr *end;
 956       gfc_ref *ref;
 957
 958       /* Substring references don't have the charlength set.  */
 959       ref = c->ref;
 960       while (ref && ref->type != REF_SUBSTRING)
 961         ref = ref->next;
 962
 963       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
 964
 965       if (!ref)
 966         {
 967           /* Check that the argument is length one.  Non-constant lengths
 968              can't be checked here, so assume thay are ok.  */
 969           if (c->ts.cl && c->ts.cl->length)
 970             {
 971               /* If we already have a length for this expression then use it.  */
 972               if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
 973                 return SUCCESS;
 974               i = mpz_get_si (c->ts.cl->length->value.integer);
 975             }
 976           else
 977             return SUCCESS;
 978         }
 979       else
 980         {
 981           start = ref->u.ss.start;
 982           end = ref->u.ss.end;
 983
 984           gcc_assert (start);
 985           if (end == NULL || end->expr_type != EXPR_CONSTANT
 986               || start->expr_type != EXPR_CONSTANT)
 987             return SUCCESS;
 988
 989           i = mpz_get_si (end->value.integer) + 1
 990               - mpz_get_si (start->value.integer);
 991         }
 992     }
 993   else
 994     return SUCCESS;
 995
 996   if (i != 1)
 997     {
 998       gfc_error ("Argument of %s at %L must be of length one",
 999                  gfc_current_intrinsic, &c->where);
1000       return FAILURE;
1001     }
1002
1003   return SUCCESS;
1004 }
1005
1006
1007 try
1008 gfc_check_idnint (gfc_expr * a)
1009 {
1010   if (double_check (a, 0) == FAILURE)
1011     return FAILURE;
1012
1013   return SUCCESS;
1014 }
1015
1016
1017 try
1018 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
1019 {
1020   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1021     return FAILURE;
1022
1023   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1024     return FAILURE;
1025
1026   if (i->ts.kind != j->ts.kind)
1027     {
1028       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1029                           &i->where) == FAILURE)
1030         return FAILURE;
1031     }
1032
1033   return SUCCESS;
1034 }
1035
1036
1037 try
1038 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
1039 {
1040   if (type_check (string, 0, BT_CHARACTER) == FAILURE
1041       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1042     return FAILURE;
1043
1044
1045   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1046     return FAILURE;
1047
1048   if (string->ts.kind != substring->ts.kind)
1049     {
1050       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1051                  "kind as '%s'", gfc_current_intrinsic_arg[1],
1052                  gfc_current_intrinsic, &substring->where,
1053                  gfc_current_intrinsic_arg[0]);
1054       return FAILURE;
1055     }
1056
1057   return SUCCESS;
1058 }
1059
1060
1061 try
1062 gfc_check_int (gfc_expr * x, gfc_expr * kind)
1063 {
1064   if (numeric_check (x, 0) == FAILURE)
1065     return FAILURE;
1066
1067   if (kind != NULL)
1068     {
1069       if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1070     return FAILURE;
1071
1072       if (scalar_check (kind, 1) == FAILURE)
1073         return FAILURE;
1074     }
1075
1076   return SUCCESS;
1077 }
1078
1079
1080 try
1081 gfc_check_ior (gfc_expr * i, gfc_expr * j)
1082 {
1083   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1084     return FAILURE;
1085
1086   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1087     return FAILURE;
1088
1089   if (i->ts.kind != j->ts.kind)
1090     {
1091       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1092                           &i->where) == FAILURE)
1093     return FAILURE;
1094     }
1095
1096   return SUCCESS;
1097 }
1098
1099
1100 try
1101 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
1102 {
1103   if (type_check (i, 0, BT_INTEGER) == FAILURE
1104       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1105     return FAILURE;
1106
1107   return SUCCESS;
1108 }
1109
1110
1111 try
1112 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
1113 {
1114   if (type_check (i, 0, BT_INTEGER) == FAILURE
1115       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1116     return FAILURE;
1117
1118   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1119     return FAILURE;
1120
1121   return SUCCESS;
1122 }
1123
1124
1125 try
1126 gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
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   return SUCCESS;
1135 }
1136
1137
1138 try
1139 gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
1140 {
1141   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1142     return FAILURE;
1143
1144   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1145     return FAILURE;
1146
1147   if (status == NULL)
1148     return SUCCESS;
1149
1150   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1151     return FAILURE;
1152
1153   if (scalar_check (status, 2) == FAILURE)
1154     return FAILURE;
1155
1156   return SUCCESS;
1157 }
1158
1159
1160 try
1161 gfc_check_kind (gfc_expr * x)
1162 {
1163   if (x->ts.type == BT_DERIVED)
1164     {
1165       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1166                  "non-derived type", gfc_current_intrinsic_arg[0],
1167                  gfc_current_intrinsic, &x->where);
1168       return FAILURE;
1169     }
1170
1171   return SUCCESS;
1172 }
1173
1174
1175 try
1176 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1177 {
1178   if (array_check (array, 0) == FAILURE)
1179     return FAILURE;
1180
1181   if (dim != NULL)
1182     {
1183       if (dim_check (dim, 1, 1) == FAILURE)
1184         return FAILURE;
1185
1186       if (dim_rank_check (dim, array, 1) == FAILURE)
1187         return FAILURE;
1188     }
1189   return SUCCESS;
1190 }
1191
1192
1193 try
1194 gfc_check_link (gfc_expr * path1, gfc_expr * path2)
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   return SUCCESS;
1203 }
1204
1205
1206 try
1207 gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1208 {
1209   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1210     return FAILURE;
1211
1212   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1213     return FAILURE;
1214
1215   if (status == NULL)
1216     return SUCCESS;
1217
1218   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1219     return FAILURE;
1220
1221   if (scalar_check (status, 2) == FAILURE)
1222     return FAILURE;
1223
1224   return SUCCESS;
1225 }
1226
1227 try
1228 gfc_check_loc (gfc_expr *expr)
1229 {
1230   return variable_check (expr, 0);
1231 }
1232
1233
1234 try
1235 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
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   return SUCCESS;
1244 }
1245
1246
1247 try
1248 gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1249 {
1250   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1251     return FAILURE;
1252
1253   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1254     return FAILURE;
1255
1256   if (status == NULL)
1257     return SUCCESS;
1258
1259   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1260     return FAILURE;
1261
1262   if (scalar_check (status, 2) == FAILURE)
1263     return FAILURE;
1264
1265   return SUCCESS;
1266 }
1267
1268
1269 try
1270 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1271 {
1272   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1273     return FAILURE;
1274   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1275     return FAILURE;
1276
1277   return SUCCESS;
1278 }
1279
1280
1281 /* Min/max family.  */
1282
1283 static try
1284 min_max_args (gfc_actual_arglist * arg)
1285 {
1286   if (arg == NULL || arg->next == NULL)
1287     {
1288       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1289                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1290       return FAILURE;
1291     }
1292
1293   return SUCCESS;
1294 }
1295
1296
1297 static try
1298 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1299 {
1300   gfc_expr *x;
1301   int n;
1302
1303   if (min_max_args (arg) == FAILURE)
1304     return FAILURE;
1305
1306   n = 1;
1307
1308   for (; arg; arg = arg->next, n++)
1309     {
1310       x = arg->expr;
1311       if (x->ts.type != type || x->ts.kind != kind)
1312         {
1313           if (x->ts.type == type)
1314             {
1315               if (gfc_notify_std (GFC_STD_GNU,
1316                     "Extension: Different type kinds at %L", &x->where)
1317                   == FAILURE)
1318                 return FAILURE;
1319             }
1320           else
1321             {
1322               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1323                          n, gfc_current_intrinsic, &x->where,
1324                          gfc_basic_typename (type), kind);
1325               return FAILURE;
1326             }
1327         }
1328     }
1329
1330   return SUCCESS;
1331 }
1332
1333
1334 try
1335 gfc_check_min_max (gfc_actual_arglist * arg)
1336 {
1337   gfc_expr *x;
1338
1339   if (min_max_args (arg) == FAILURE)
1340     return FAILURE;
1341
1342   x = arg->expr;
1343
1344   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1345     {
1346       gfc_error
1347         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1348          gfc_current_intrinsic, &x->where);
1349       return FAILURE;
1350     }
1351
1352   return check_rest (x->ts.type, x->ts.kind, arg);
1353 }
1354
1355
1356 try
1357 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1358 {
1359   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1360 }
1361
1362
1363 try
1364 gfc_check_min_max_real (gfc_actual_arglist * arg)
1365 {
1366   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1367 }
1368
1369
1370 try
1371 gfc_check_min_max_double (gfc_actual_arglist * arg)
1372 {
1373   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1374 }
1375
1376 /* End of min/max family.  */
1377
1378 try
1379 gfc_check_malloc (gfc_expr * size)
1380 {
1381   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1382     return FAILURE;
1383
1384   if (scalar_check (size, 0) == FAILURE)
1385     return FAILURE;
1386
1387   return SUCCESS;
1388 }
1389
1390
1391 try
1392 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1393 {
1394   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1395     {
1396       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1397                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1398                  gfc_current_intrinsic, &matrix_a->where);
1399       return FAILURE;
1400     }
1401
1402   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1403     {
1404       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1405                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1406                  gfc_current_intrinsic, &matrix_b->where);
1407       return FAILURE;
1408     }
1409
1410   switch (matrix_a->rank)
1411     {
1412     case 1:
1413       if (rank_check (matrix_b, 1, 2) == FAILURE)
1414         return FAILURE;
1415       break;
1416
1417     case 2:
1418       if (matrix_b->rank == 2)
1419         break;
1420       if (rank_check (matrix_b, 1, 1) == FAILURE)
1421         return FAILURE;
1422       break;
1423
1424     default:
1425       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1426                  "1 or 2", gfc_current_intrinsic_arg[0],
1427                  gfc_current_intrinsic, &matrix_a->where);
1428       return FAILURE;
1429     }
1430
1431   return SUCCESS;
1432 }
1433
1434
1435 /* Whoever came up with this interface was probably on something.
1436    The possibilities for the occupation of the second and third
1437    parameters are:
1438
1439          Arg #2     Arg #3
1440          NULL       NULL
1441          DIM        NULL
1442          MASK       NULL
1443          NULL       MASK             minloc(array, mask=m)
1444          DIM        MASK
1445
1446    I.e. in the case of minloc(array,mask), mask will be in the second
1447    position of the argument list and we'll have to fix that up.  */
1448
1449 try
1450 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1451 {
1452   gfc_expr *a, *m, *d;
1453
1454   a = ap->expr;
1455   if (int_or_real_check (a, 0) == FAILURE
1456       || array_check (a, 0) == FAILURE)
1457     return FAILURE;
1458
1459   d = ap->next->expr;
1460   m = ap->next->next->expr;
1461
1462   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1463       && ap->next->name == NULL)
1464     {
1465       m = d;
1466       d = NULL;
1467
1468       ap->next->expr = NULL;
1469       ap->next->next->expr = m;
1470     }
1471
1472   if (d != NULL
1473       && (scalar_check (d, 1) == FAILURE
1474       || type_check (d, 1, BT_INTEGER) == FAILURE))
1475     return FAILURE;
1476
1477   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1478     return FAILURE;
1479
1480   return SUCCESS;
1481 }
1482
1483
1484 /* Similar to minloc/maxloc, the argument list might need to be
1485    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1486    difference is that MINLOC/MAXLOC take an additional KIND argument.
1487    The possibilities are:
1488
1489          Arg #2     Arg #3
1490          NULL       NULL
1491          DIM        NULL
1492          MASK       NULL
1493          NULL       MASK             minval(array, mask=m)
1494          DIM        MASK
1495
1496    I.e. in the case of minval(array,mask), mask will be in the second
1497    position of the argument list and we'll have to fix that up.  */
1498
1499 static try
1500 check_reduction (gfc_actual_arglist * ap)
1501 {
1502   gfc_expr *m, *d;
1503
1504   d = ap->next->expr;
1505   m = ap->next->next->expr;
1506
1507   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1508       && ap->next->name == NULL)
1509     {
1510       m = d;
1511       d = NULL;
1512
1513       ap->next->expr = NULL;
1514       ap->next->next->expr = m;
1515     }
1516
1517   if (d != NULL
1518       && (scalar_check (d, 1) == FAILURE
1519       || type_check (d, 1, BT_INTEGER) == FAILURE))
1520     return FAILURE;
1521
1522   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1523     return FAILURE;
1524
1525   return SUCCESS;
1526 }
1527
1528
1529 try
1530 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1531 {
1532   if (int_or_real_check (ap->expr, 0) == FAILURE
1533       || array_check (ap->expr, 0) == FAILURE)
1534     return FAILURE;
1535
1536   return check_reduction (ap);
1537 }
1538
1539
1540 try
1541 gfc_check_product_sum (gfc_actual_arglist * ap)
1542 {
1543   if (numeric_check (ap->expr, 0) == FAILURE
1544       || array_check (ap->expr, 0) == FAILURE)
1545     return FAILURE;
1546
1547   return check_reduction (ap);
1548 }
1549
1550
1551 try
1552 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1553 {
1554   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1555     return FAILURE;
1556
1557   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1558     return FAILURE;
1559
1560   return SUCCESS;
1561 }
1562
1563
1564 try
1565 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1566 {
1567   if (type_check (x, 0, BT_REAL) == FAILURE)
1568     return FAILURE;
1569
1570   if (type_check (s, 1, BT_REAL) == FAILURE)
1571     return FAILURE;
1572
1573   return SUCCESS;
1574 }
1575
1576
1577 try
1578 gfc_check_null (gfc_expr * mold)
1579 {
1580   symbol_attribute attr;
1581
1582   if (mold == NULL)
1583     return SUCCESS;
1584
1585   if (variable_check (mold, 0) == FAILURE)
1586     return FAILURE;
1587
1588   attr = gfc_variable_attr (mold, NULL);
1589
1590   if (!attr.pointer)
1591     {
1592       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1593                  gfc_current_intrinsic_arg[0],
1594                  gfc_current_intrinsic, &mold->where);
1595       return FAILURE;
1596     }
1597
1598   return SUCCESS;
1599 }
1600
1601
1602 try
1603 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1604 {
1605   if (array_check (array, 0) == FAILURE)
1606     return FAILURE;
1607
1608   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1609     return FAILURE;
1610
1611   if (mask->rank != 0 && mask->rank != array->rank)
1612     {
1613       gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
1614                  "with '%s' argument", gfc_current_intrinsic_arg[0],
1615                  gfc_current_intrinsic, &array->where,
1616                  gfc_current_intrinsic_arg[1]);
1617       return FAILURE;
1618     }
1619
1620   if (vector != NULL)
1621     {
1622       if (same_type_check (array, 0, vector, 2) == FAILURE)
1623         return FAILURE;
1624
1625       if (rank_check (vector, 2, 1) == FAILURE)
1626         return FAILURE;
1627
1628       /* TODO: More constraints here.  */
1629     }
1630
1631   return SUCCESS;
1632 }
1633
1634
1635 try
1636 gfc_check_precision (gfc_expr * x)
1637 {
1638   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1639     {
1640       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1641                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1642                  gfc_current_intrinsic, &x->where);
1643       return FAILURE;
1644     }
1645
1646   return SUCCESS;
1647 }
1648
1649
1650 try
1651 gfc_check_present (gfc_expr * a)
1652 {
1653   gfc_symbol *sym;
1654
1655   if (variable_check (a, 0) == FAILURE)
1656     return FAILURE;
1657
1658   sym = a->symtree->n.sym;
1659   if (!sym->attr.dummy)
1660     {
1661       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1662                  "dummy variable", gfc_current_intrinsic_arg[0],
1663                  gfc_current_intrinsic, &a->where);
1664       return FAILURE;
1665     }
1666
1667   if (!sym->attr.optional)
1668     {
1669       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1670                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1671                  gfc_current_intrinsic, &a->where);
1672       return FAILURE;
1673     }
1674
1675   return SUCCESS;
1676 }
1677
1678
1679 try
1680 gfc_check_radix (gfc_expr * x)
1681 {
1682   if (int_or_real_check (x, 0) == FAILURE)
1683     return FAILURE;
1684
1685   return SUCCESS;
1686 }
1687
1688
1689 try
1690 gfc_check_range (gfc_expr * x)
1691 {
1692   if (numeric_check (x, 0) == FAILURE)
1693     return FAILURE;
1694
1695   return SUCCESS;
1696 }
1697
1698
1699 /* real, float, sngl.  */
1700 try
1701 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1702 {
1703   if (numeric_check (a, 0) == FAILURE)
1704     return FAILURE;
1705
1706   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1707     return FAILURE;
1708
1709   return SUCCESS;
1710 }
1711
1712
1713 try
1714 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
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   return SUCCESS;
1723 }
1724
1725
1726 try
1727 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1728 {
1729   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1730     return FAILURE;
1731
1732   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1733     return FAILURE;
1734
1735   if (status == NULL)
1736     return SUCCESS;
1737
1738   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1739     return FAILURE;
1740
1741   if (scalar_check (status, 2) == FAILURE)
1742     return FAILURE;
1743
1744   return SUCCESS;
1745 }
1746
1747
1748 try
1749 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1750 {
1751   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1752     return FAILURE;
1753
1754   if (scalar_check (x, 0) == FAILURE)
1755     return FAILURE;
1756
1757   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1758     return FAILURE;
1759
1760   if (scalar_check (y, 1) == FAILURE)
1761     return FAILURE;
1762
1763   return SUCCESS;
1764 }
1765
1766
1767 try
1768 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1769                    gfc_expr * pad, gfc_expr * order)
1770 {
1771   mpz_t size;
1772   int m;
1773
1774   if (array_check (source, 0) == FAILURE)
1775     return FAILURE;
1776
1777   if (rank_check (shape, 1, 1) == FAILURE)
1778     return FAILURE;
1779
1780   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1781     return FAILURE;
1782
1783   if (gfc_array_size (shape, &size) != SUCCESS)
1784     {
1785       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1786                  "array of constant size", &shape->where);
1787       return FAILURE;
1788     }
1789
1790   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1791   mpz_clear (size);
1792
1793   if (m > 0)
1794     {
1795       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
1796                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
1797       return FAILURE;
1798     }
1799
1800   if (pad != NULL)
1801     {
1802       if (same_type_check (source, 0, pad, 2) == FAILURE)
1803         return FAILURE;
1804       if (array_check (pad, 2) == FAILURE)
1805         return FAILURE;
1806     }
1807
1808   if (order != NULL && array_check (order, 3) == FAILURE)
1809     return FAILURE;
1810
1811   return SUCCESS;
1812 }
1813
1814
1815 try
1816 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1817 {
1818   if (type_check (x, 0, BT_REAL) == FAILURE)
1819     return FAILURE;
1820
1821   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1822     return FAILURE;
1823
1824   return SUCCESS;
1825 }
1826
1827
1828 try
1829 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1830 {
1831   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1832     return FAILURE;
1833
1834   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1835     return FAILURE;
1836
1837   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1838     return FAILURE;
1839
1840   if (same_type_check (x, 0, y, 1) == FAILURE)
1841     return FAILURE;
1842
1843   return SUCCESS;
1844 }
1845
1846
1847 try
1848 gfc_check_secnds (gfc_expr * r)
1849 {
1850
1851   if (type_check (r, 0, BT_REAL) == FAILURE)
1852     return FAILURE;
1853
1854   if (kind_value_check (r, 0, 4) == FAILURE)
1855     return FAILURE;
1856
1857   if (scalar_check (r, 0) == FAILURE)
1858     return FAILURE;
1859
1860   return SUCCESS;
1861 }
1862
1863
1864 try
1865 gfc_check_selected_int_kind (gfc_expr * r)
1866 {
1867
1868   if (type_check (r, 0, BT_INTEGER) == FAILURE)
1869     return FAILURE;
1870
1871   if (scalar_check (r, 0) == FAILURE)
1872     return FAILURE;
1873
1874   return SUCCESS;
1875 }
1876
1877
1878 try
1879 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1880 {
1881   if (p == NULL && r == NULL)
1882     {
1883       gfc_error ("Missing arguments to %s intrinsic at %L",
1884                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1885
1886       return FAILURE;
1887     }
1888
1889   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1890     return FAILURE;
1891
1892   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1893     return FAILURE;
1894
1895   return SUCCESS;
1896 }
1897
1898
1899 try
1900 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1901 {
1902   if (type_check (x, 0, BT_REAL) == FAILURE)
1903     return FAILURE;
1904
1905   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1906     return FAILURE;
1907
1908   return SUCCESS;
1909 }
1910
1911
1912 try
1913 gfc_check_shape (gfc_expr * source)
1914 {
1915   gfc_array_ref *ar;
1916
1917   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1918     return SUCCESS;
1919
1920   ar = gfc_find_array_ref (source);
1921
1922   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1923     {
1924       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1925                  "an assumed size array", &source->where);
1926       return FAILURE;
1927     }
1928
1929   return SUCCESS;
1930 }
1931
1932
1933 try
1934 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1935 {
1936   if (int_or_real_check (a, 0) == FAILURE)
1937     return FAILURE;
1938
1939   if (same_type_check (a, 0, b, 1) == FAILURE)
1940     return FAILURE;
1941
1942   return SUCCESS;
1943 }
1944
1945
1946 try
1947 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1948 {
1949   if (array_check (array, 0) == FAILURE)
1950     return FAILURE;
1951
1952   if (dim != NULL)
1953     {
1954       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1955         return FAILURE;
1956
1957       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1958         return FAILURE;
1959
1960       if (dim_rank_check (dim, array, 0) == FAILURE)
1961         return FAILURE;
1962     }
1963
1964   return SUCCESS;
1965 }
1966
1967
1968 try
1969 gfc_check_sleep_sub (gfc_expr * seconds)
1970 {
1971   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
1972     return FAILURE;
1973
1974   if (scalar_check (seconds, 0) == FAILURE)
1975     return FAILURE;
1976
1977   return SUCCESS;
1978 }
1979
1980
1981 try
1982 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1983 {
1984   if (source->rank >= GFC_MAX_DIMENSIONS)
1985     {
1986       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
1987                  "than rank %d", gfc_current_intrinsic_arg[0],
1988                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
1989
1990       return FAILURE;
1991     }
1992
1993   if (dim_check (dim, 1, 0) == FAILURE)
1994     return FAILURE;
1995
1996   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1997     return FAILURE;
1998
1999   if (scalar_check (ncopies, 2) == FAILURE)
2000     return FAILURE;
2001
2002   return SUCCESS;
2003 }
2004
2005
2006 try
2007 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2008 {
2009   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2010     return FAILURE;
2011
2012   if (scalar_check (unit, 0) == FAILURE)
2013     return FAILURE;
2014
2015   if (type_check (array, 1, BT_INTEGER) == FAILURE
2016       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2017     return FAILURE;
2018
2019   if (array_check (array, 1) == FAILURE)
2020     return FAILURE;
2021
2022   return SUCCESS;
2023 }
2024
2025
2026 try
2027 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2028 {
2029   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2030     return FAILURE;
2031
2032   if (scalar_check (unit, 0) == FAILURE)
2033     return FAILURE;
2034
2035   if (type_check (array, 1, BT_INTEGER) == FAILURE
2036       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2037     return FAILURE;
2038
2039   if (array_check (array, 1) == FAILURE)
2040     return FAILURE;
2041
2042   if (status == NULL)
2043     return SUCCESS;
2044
2045   if (type_check (status, 2, BT_INTEGER) == FAILURE
2046       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2047     return FAILURE;
2048
2049   if (scalar_check (status, 2) == FAILURE)
2050     return FAILURE;
2051
2052   return SUCCESS;
2053 }
2054
2055
2056 try
2057 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2058 {
2059   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2060     return FAILURE;
2061
2062   if (type_check (array, 1, BT_INTEGER) == FAILURE
2063       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2064     return FAILURE;
2065
2066   if (array_check (array, 1) == FAILURE)
2067     return FAILURE;
2068
2069   return SUCCESS;
2070 }
2071
2072
2073 try
2074 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2075 {
2076   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2077     return FAILURE;
2078
2079   if (type_check (array, 1, BT_INTEGER) == FAILURE
2080       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2081     return FAILURE;
2082
2083   if (array_check (array, 1) == FAILURE)
2084     return FAILURE;
2085
2086   if (status == NULL)
2087     return SUCCESS;
2088
2089   if (type_check (status, 2, BT_INTEGER) == FAILURE
2090       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2091     return FAILURE;
2092
2093   if (scalar_check (status, 2) == FAILURE)
2094     return FAILURE;
2095
2096   return SUCCESS;
2097 }
2098
2099
2100 try
2101 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2102                     gfc_expr * mold ATTRIBUTE_UNUSED,
2103                     gfc_expr * size)
2104 {
2105   if (size != NULL)
2106     {
2107       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2108         return FAILURE;
2109
2110       if (scalar_check (size, 2) == FAILURE)
2111         return FAILURE;
2112
2113       if (nonoptional_check (size, 2) == FAILURE)
2114         return FAILURE;
2115     }
2116
2117   return SUCCESS;
2118 }
2119
2120
2121 try
2122 gfc_check_transpose (gfc_expr * matrix)
2123 {
2124   if (rank_check (matrix, 0, 2) == FAILURE)
2125     return FAILURE;
2126
2127   return SUCCESS;
2128 }
2129
2130
2131 try
2132 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2133 {
2134   if (array_check (array, 0) == FAILURE)
2135     return FAILURE;
2136
2137   if (dim != NULL)
2138     {
2139       if (dim_check (dim, 1, 1) == FAILURE)
2140         return FAILURE;
2141
2142       if (dim_rank_check (dim, array, 0) == FAILURE)
2143         return FAILURE;
2144     }
2145
2146   return SUCCESS;
2147 }
2148
2149
2150 try
2151 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2152 {
2153   if (rank_check (vector, 0, 1) == FAILURE)
2154     return FAILURE;
2155
2156   if (array_check (mask, 1) == FAILURE)
2157     return FAILURE;
2158
2159   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2160     return FAILURE;
2161
2162   if (same_type_check (vector, 0, field, 2) == FAILURE)
2163     return FAILURE;
2164
2165   return SUCCESS;
2166 }
2167
2168
2169 try
2170 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2171 {
2172   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2173     return FAILURE;
2174
2175   if (same_type_check (x, 0, y, 1) == FAILURE)
2176     return FAILURE;
2177
2178   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2179     return FAILURE;
2180
2181   return SUCCESS;
2182 }
2183
2184
2185 try
2186 gfc_check_trim (gfc_expr * x)
2187 {
2188   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2189     return FAILURE;
2190
2191   if (scalar_check (x, 0) == FAILURE)
2192     return FAILURE;
2193
2194    return SUCCESS;
2195 }
2196
2197
2198 try
2199 gfc_check_ttynam (gfc_expr * unit)
2200 {
2201   if (scalar_check (unit, 0) == FAILURE)
2202     return FAILURE;
2203
2204   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2205     return FAILURE;
2206
2207   return SUCCESS;
2208 }
2209
2210
2211 /* Common check function for the half a dozen intrinsics that have a
2212    single real argument.  */
2213
2214 try
2215 gfc_check_x (gfc_expr * x)
2216 {
2217   if (type_check (x, 0, BT_REAL) == FAILURE)
2218     return FAILURE;
2219
2220   return SUCCESS;
2221 }
2222
2223
2224 /************* Check functions for intrinsic subroutines *************/
2225
2226 try
2227 gfc_check_cpu_time (gfc_expr * time)
2228 {
2229   if (scalar_check (time, 0) == FAILURE)
2230     return FAILURE;
2231
2232   if (type_check (time, 0, BT_REAL) == FAILURE)
2233     return FAILURE;
2234
2235   if (variable_check (time, 0) == FAILURE)
2236     return FAILURE;
2237
2238   return SUCCESS;
2239 }
2240
2241
2242 try
2243 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2244                          gfc_expr * zone, gfc_expr * values)
2245 {
2246   if (date != NULL)
2247     {
2248       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2249         return FAILURE;
2250       if (scalar_check (date, 0) == FAILURE)
2251         return FAILURE;
2252       if (variable_check (date, 0) == FAILURE)
2253         return FAILURE;
2254     }
2255
2256   if (time != NULL)
2257     {
2258       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2259         return FAILURE;
2260       if (scalar_check (time, 1) == FAILURE)
2261         return FAILURE;
2262       if (variable_check (time, 1) == FAILURE)
2263         return FAILURE;
2264     }
2265
2266   if (zone != NULL)
2267     {
2268       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2269         return FAILURE;
2270       if (scalar_check (zone, 2) == FAILURE)
2271         return FAILURE;
2272       if (variable_check (zone, 2) == FAILURE)
2273         return FAILURE;
2274     }
2275
2276   if (values != NULL)
2277     {
2278       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2279         return FAILURE;
2280       if (array_check (values, 3) == FAILURE)
2281         return FAILURE;
2282       if (rank_check (values, 3, 1) == FAILURE)
2283         return FAILURE;
2284       if (variable_check (values, 3) == FAILURE)
2285         return FAILURE;
2286     }
2287
2288   return SUCCESS;
2289 }
2290
2291
2292 try
2293 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2294                   gfc_expr * to, gfc_expr * topos)
2295 {
2296   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2297     return FAILURE;
2298
2299   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2300     return FAILURE;
2301
2302   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2303     return FAILURE;
2304
2305   if (same_type_check (from, 0, to, 3) == FAILURE)
2306     return FAILURE;
2307
2308   if (variable_check (to, 3) == FAILURE)
2309     return FAILURE;
2310
2311   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2312     return FAILURE;
2313
2314   return SUCCESS;
2315 }
2316
2317
2318 try
2319 gfc_check_random_number (gfc_expr * harvest)
2320 {
2321   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2322     return FAILURE;
2323
2324   if (variable_check (harvest, 0) == FAILURE)
2325     return FAILURE;
2326
2327   return SUCCESS;
2328 }
2329
2330
2331 try
2332 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2333 {
2334   if (size != NULL)
2335     {
2336       if (scalar_check (size, 0) == FAILURE)
2337         return FAILURE;
2338
2339       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2340         return FAILURE;
2341
2342       if (variable_check (size, 0) == FAILURE)
2343         return FAILURE;
2344
2345       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2346         return FAILURE;
2347     }
2348
2349   if (put != NULL)
2350     {
2351
2352       if (size != NULL)
2353         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2354                     &put->where);
2355
2356       if (array_check (put, 1) == FAILURE)
2357         return FAILURE;
2358
2359       if (rank_check (put, 1, 1) == FAILURE)
2360         return FAILURE;
2361
2362       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2363         return FAILURE;
2364
2365       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2366         return FAILURE;
2367     }
2368
2369   if (get != NULL)
2370     {
2371
2372       if (size != NULL || put != NULL)
2373         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2374                     &get->where);
2375
2376       if (array_check (get, 2) == FAILURE)
2377         return FAILURE;
2378
2379       if (rank_check (get, 2, 1) == FAILURE)
2380         return FAILURE;
2381
2382       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2383         return FAILURE;
2384
2385       if (variable_check (get, 2) == FAILURE)
2386         return FAILURE;
2387
2388       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2389         return FAILURE;
2390     }
2391
2392   return SUCCESS;
2393 }
2394
2395 try
2396 gfc_check_second_sub (gfc_expr * time)
2397 {
2398   if (scalar_check (time, 0) == FAILURE)
2399     return FAILURE;
2400
2401   if (type_check (time, 0, BT_REAL) == FAILURE)
2402     return FAILURE;
2403
2404   if (kind_value_check(time, 0, 4) == FAILURE)
2405     return FAILURE;
2406
2407   return SUCCESS;
2408 }
2409
2410
2411 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2412    count, count_rate, and count_max are all optional arguments */
2413
2414 try
2415 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2416                         gfc_expr * count_max)
2417 {
2418   if (count != NULL)
2419     {
2420       if (scalar_check (count, 0) == FAILURE)
2421         return FAILURE;
2422
2423       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2424         return FAILURE;
2425
2426       if (variable_check (count, 0) == FAILURE)
2427         return FAILURE;
2428     }
2429
2430   if (count_rate != NULL)
2431     {
2432       if (scalar_check (count_rate, 1) == FAILURE)
2433         return FAILURE;
2434
2435       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2436         return FAILURE;
2437
2438       if (variable_check (count_rate, 1) == FAILURE)
2439         return FAILURE;
2440
2441       if (count != NULL
2442           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2443         return FAILURE;
2444
2445     }
2446
2447   if (count_max != NULL)
2448     {
2449       if (scalar_check (count_max, 2) == FAILURE)
2450         return FAILURE;
2451
2452       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2453         return FAILURE;
2454
2455       if (variable_check (count_max, 2) == FAILURE)
2456         return FAILURE;
2457
2458       if (count != NULL
2459           && same_type_check (count, 0, count_max, 2) == FAILURE)
2460         return FAILURE;
2461
2462       if (count_rate != NULL
2463           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2464         return FAILURE;
2465     }
2466
2467   return SUCCESS;
2468 }
2469
2470 try
2471 gfc_check_irand (gfc_expr * x)
2472 {
2473   if (x == NULL)
2474     return SUCCESS;
2475
2476   if (scalar_check (x, 0) == FAILURE)
2477     return FAILURE;
2478
2479   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2480     return FAILURE;
2481
2482   if (kind_value_check(x, 0, 4) == FAILURE)
2483     return FAILURE;
2484
2485   return SUCCESS;
2486 }
2487
2488
2489 try
2490 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2491 {
2492   if (scalar_check (seconds, 0) == FAILURE)
2493     return FAILURE;
2494
2495   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2496     return FAILURE;
2497
2498   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2499     {
2500       gfc_error (
2501         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2502         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2503       return FAILURE;
2504     }
2505
2506   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2507     return FAILURE;
2508
2509   if (status == NULL)
2510     return SUCCESS;
2511
2512   if (scalar_check (status, 2) == FAILURE)
2513     return FAILURE;
2514
2515   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2516     return FAILURE;
2517
2518   return SUCCESS;
2519 }
2520
2521
2522 try
2523 gfc_check_rand (gfc_expr * x)
2524 {
2525   if (x == NULL)
2526     return SUCCESS;
2527
2528   if (scalar_check (x, 0) == FAILURE)
2529     return FAILURE;
2530
2531   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2532     return FAILURE;
2533
2534   if (kind_value_check(x, 0, 4) == FAILURE)
2535     return FAILURE;
2536
2537   return SUCCESS;
2538 }
2539
2540 try
2541 gfc_check_srand (gfc_expr * x)
2542 {
2543   if (scalar_check (x, 0) == FAILURE)
2544     return FAILURE;
2545
2546   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2547     return FAILURE;
2548
2549   if (kind_value_check(x, 0, 4) == FAILURE)
2550     return FAILURE;
2551
2552   return SUCCESS;
2553 }
2554
2555 try
2556 gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
2557 {
2558   if (scalar_check (time, 0) == FAILURE)
2559     return FAILURE;
2560
2561   if (type_check (time, 0, BT_INTEGER) == FAILURE)
2562     return FAILURE;
2563
2564   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
2565     return FAILURE;
2566
2567   return SUCCESS;
2568 }
2569
2570 try
2571 gfc_check_etime (gfc_expr * x)
2572 {
2573   if (array_check (x, 0) == FAILURE)
2574     return FAILURE;
2575
2576   if (rank_check (x, 0, 1) == FAILURE)
2577     return FAILURE;
2578
2579   if (variable_check (x, 0) == FAILURE)
2580     return FAILURE;
2581
2582   if (type_check (x, 0, BT_REAL) == FAILURE)
2583     return FAILURE;
2584
2585   if (kind_value_check(x, 0, 4) == FAILURE)
2586     return FAILURE;
2587
2588   return SUCCESS;
2589 }
2590
2591 try
2592 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2593 {
2594   if (array_check (values, 0) == FAILURE)
2595     return FAILURE;
2596
2597   if (rank_check (values, 0, 1) == FAILURE)
2598     return FAILURE;
2599
2600   if (variable_check (values, 0) == FAILURE)
2601     return FAILURE;
2602
2603   if (type_check (values, 0, BT_REAL) == FAILURE)
2604     return FAILURE;
2605
2606   if (kind_value_check(values, 0, 4) == FAILURE)
2607     return FAILURE;
2608
2609   if (scalar_check (time, 1) == FAILURE)
2610     return FAILURE;
2611
2612   if (type_check (time, 1, BT_REAL) == FAILURE)
2613     return FAILURE;
2614
2615   if (kind_value_check(time, 1, 4) == FAILURE)
2616     return FAILURE;
2617
2618   return SUCCESS;
2619 }
2620
2621
2622 try
2623 gfc_check_fdate_sub (gfc_expr * date)
2624 {
2625   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2626     return FAILURE;
2627
2628   return SUCCESS;
2629 }
2630
2631
2632 try
2633 gfc_check_gerror (gfc_expr * msg)
2634 {
2635   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2636     return FAILURE;
2637
2638   return SUCCESS;
2639 }
2640
2641
2642 try
2643 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2644 {
2645   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2646     return FAILURE;
2647
2648   if (status == NULL)
2649     return SUCCESS;
2650
2651   if (scalar_check (status, 1) == FAILURE)
2652     return FAILURE;
2653
2654   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2655     return FAILURE;
2656
2657   return SUCCESS;
2658 }
2659
2660
2661 try
2662 gfc_check_getlog (gfc_expr * msg)
2663 {
2664   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2665     return FAILURE;
2666
2667   return SUCCESS;
2668 }
2669
2670
2671 try
2672 gfc_check_exit (gfc_expr * status)
2673 {
2674   if (status == NULL)
2675     return SUCCESS;
2676
2677   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2678     return FAILURE;
2679
2680   if (scalar_check (status, 0) == FAILURE)
2681     return FAILURE;
2682
2683   return SUCCESS;
2684 }
2685
2686
2687 try
2688 gfc_check_flush (gfc_expr * unit)
2689 {
2690   if (unit == NULL)
2691     return SUCCESS;
2692
2693   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2694     return FAILURE;
2695
2696   if (scalar_check (unit, 0) == FAILURE)
2697     return FAILURE;
2698
2699   return SUCCESS;
2700 }
2701
2702
2703 try
2704 gfc_check_free (gfc_expr * i)
2705 {
2706   if (type_check (i, 0, BT_INTEGER) == FAILURE)
2707     return FAILURE;
2708
2709   if (scalar_check (i, 0) == FAILURE)
2710     return FAILURE;
2711
2712   return SUCCESS;
2713 }
2714
2715
2716 try
2717 gfc_check_hostnm (gfc_expr * name)
2718 {
2719   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2720     return FAILURE;
2721
2722   return SUCCESS;
2723 }
2724
2725
2726 try
2727 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
2728 {
2729   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2730     return FAILURE;
2731
2732   if (status == NULL)
2733     return SUCCESS;
2734
2735   if (scalar_check (status, 1) == FAILURE)
2736     return FAILURE;
2737
2738   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2739     return FAILURE;
2740
2741   return SUCCESS;
2742 }
2743
2744
2745 try
2746 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
2747 {
2748   if (scalar_check (unit, 0) == FAILURE)
2749     return FAILURE;
2750
2751   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2752     return FAILURE;
2753
2754   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
2755     return FAILURE;
2756
2757   return SUCCESS;
2758 }
2759
2760
2761 try
2762 gfc_check_isatty (gfc_expr * unit)
2763 {
2764   if (unit == NULL)
2765     return FAILURE;
2766
2767   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2768     return FAILURE;
2769
2770   if (scalar_check (unit, 0) == FAILURE)
2771     return FAILURE;
2772
2773   return SUCCESS;
2774 }
2775
2776
2777 try
2778 gfc_check_perror (gfc_expr * string)
2779 {
2780   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
2781     return FAILURE;
2782
2783   return SUCCESS;
2784 }
2785
2786
2787 try
2788 gfc_check_umask (gfc_expr * mask)
2789 {
2790   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2791     return FAILURE;
2792
2793   if (scalar_check (mask, 0) == FAILURE)
2794     return FAILURE;
2795
2796   return SUCCESS;
2797 }
2798
2799
2800 try
2801 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2802 {
2803   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2804     return FAILURE;
2805
2806   if (scalar_check (mask, 0) == FAILURE)
2807     return FAILURE;
2808
2809   if (old == NULL)
2810     return SUCCESS;
2811
2812   if (scalar_check (old, 1) == FAILURE)
2813     return FAILURE;
2814
2815   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2816     return FAILURE;
2817
2818   return SUCCESS;
2819 }
2820
2821
2822 try
2823 gfc_check_unlink (gfc_expr * name)
2824 {
2825   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2826     return FAILURE;
2827
2828   return SUCCESS;
2829 }
2830
2831
2832 try
2833 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2834 {
2835   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2836     return FAILURE;
2837
2838   if (status == NULL)
2839     return SUCCESS;
2840
2841   if (scalar_check (status, 1) == FAILURE)
2842     return FAILURE;
2843
2844   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2845     return FAILURE;
2846
2847   return SUCCESS;
2848 }
2849
2850
2851 try
2852 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
2853 {
2854   if (scalar_check (number, 0) == FAILURE)
2855     return FAILURE;
2856
2857   if (type_check (number, 0, BT_INTEGER) == FAILURE)
2858     return FAILURE;
2859
2860   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2861     {
2862       gfc_error (
2863         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2864         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2865       return FAILURE;
2866     }
2867
2868   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2869     return FAILURE;
2870
2871   return SUCCESS;
2872 }
2873
2874
2875 try
2876 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
2877 {
2878   if (scalar_check (number, 0) == FAILURE)
2879     return FAILURE;
2880
2881   if (type_check (number, 0, BT_INTEGER) == FAILURE)
2882     return FAILURE;
2883
2884   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2885     {
2886       gfc_error (
2887         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2888         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2889       return FAILURE;
2890     }
2891
2892   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2893     return FAILURE;
2894
2895   if (status == NULL)
2896     return SUCCESS;
2897
2898   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2899     return FAILURE;
2900
2901   if (scalar_check (status, 2) == FAILURE)
2902     return FAILURE;
2903
2904   return SUCCESS;
2905 }
2906
2907
2908 try
2909 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2910 {
2911   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2912     return FAILURE;
2913
2914   if (scalar_check (status, 1) == FAILURE)
2915     return FAILURE;
2916
2917   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2918     return FAILURE;
2919
2920   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
2921     return FAILURE;
2922
2923   return SUCCESS;
2924 }