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