gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006 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 && dim == NULL)
 299     return SUCCESS;
 300
 301   if (dim == NULL)
 302     {
 303       gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
 304                  gfc_current_intrinsic, gfc_current_intrinsic_where);
 305       return FAILURE;
 306     }
 307
 308   if (type_check (dim, n, BT_INTEGER) == FAILURE)
 309     return FAILURE;
 310
 311   if (scalar_check (dim, n) == FAILURE)
 312     return FAILURE;
 313
 314   if (nonoptional_check (dim, n) == FAILURE)
 315     return FAILURE;
 316
 317   return SUCCESS;
 318 }
 319
 320
 321 /* If a DIM parameter is a constant, make sure that it is greater than
 322    zero and less than or equal to the rank of the given array.  If
 323    allow_assumed is zero then dim must be less than the rank of the array
 324    for assumed size arrays.  */
 325
 326 static try
 327 dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
 328 {
 329   gfc_array_ref *ar;
 330   int rank;
 331
 332   if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
 333     return SUCCESS;
 334
 335   ar = gfc_find_array_ref (array);
 336   rank = array->rank;
 337   if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
 338     rank--;
 339
 340   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 341       || mpz_cmp_ui (dim->value.integer, rank) > 0)
 342     {
 343       gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
 344                  "dimension index", gfc_current_intrinsic, &dim->where);
 345
 346       return FAILURE;
 347     }
 348
 349   return SUCCESS;
 350 }
 351
 352 /* Compare the size of a along dimension ai with the size of b along
 353    dimension bi, returning 0 if they are known not to be identical,
 354    and 1 if they are identical, or if this cannot be determined.  */
 355
 356 static int
 357 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 358 {
 359   mpz_t a_size, b_size;
 360   int ret;
 361
 362   gcc_assert (a->rank > ai);
 363   gcc_assert (b->rank > bi);
 364
 365   ret = 1;
 366
 367   if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
 368     {
 369       if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
 370         {
 371           if (mpz_cmp (a_size, b_size) != 0)
 372             ret = 0;
 373
 374           mpz_clear (b_size);
 375         }
 376       mpz_clear (a_size);
 377     }
 378   return ret;
 379 }
 380
 381 /* Error return for transformational intrinsics not allowed in
 382    initialization expressions.  */
 383
 384 static try
 385 non_init_transformational (void)
 386 {
 387   gfc_error ("transformational intrinsic '%s' at %L is not permitted "
 388              "in an initialization expression", gfc_current_intrinsic,
 389              gfc_current_intrinsic_where);
 390   return FAILURE;
 391 }
 392
 393 /***** Check functions *****/
 394
 395 /* Check subroutine suitable for intrinsics taking a real argument and
 396    a kind argument for the result.  */
 397
 398 static try
 399 check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
 400 {
 401   if (type_check (a, 0, BT_REAL) == FAILURE)
 402     return FAILURE;
 403   if (kind_check (kind, 1, type) == FAILURE)
 404     return FAILURE;
 405
 406   return SUCCESS;
 407 }
 408
 409 /* Check subroutine suitable for ceiling, floor and nint.  */
 410
 411 try
 412 gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
 413 {
 414   return check_a_kind (a, kind, BT_INTEGER);
 415 }
 416
 417 /* Check subroutine suitable for aint, anint.  */
 418
 419 try
 420 gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
 421 {
 422   return check_a_kind (a, kind, BT_REAL);
 423 }
 424
 425 try
 426 gfc_check_abs (gfc_expr * a)
 427 {
 428   if (numeric_check (a, 0) == FAILURE)
 429     return FAILURE;
 430
 431   return SUCCESS;
 432 }
 433
 434 try
 435 gfc_check_achar (gfc_expr * a)
 436 {
 437
 438   if (type_check (a, 0, BT_INTEGER) == FAILURE)
 439     return FAILURE;
 440
 441   return SUCCESS;
 442 }
 443
 444
 445 try
 446 gfc_check_access_func (gfc_expr * name, gfc_expr * mode)
 447 {
 448   if (type_check (name, 0, BT_CHARACTER) == FAILURE
 449       || scalar_check (name, 0) == FAILURE)
 450     return FAILURE;
 451
 452
 453   if (type_check (mode, 1, BT_CHARACTER) == FAILURE
 454       || scalar_check (mode, 1) == FAILURE)
 455     return FAILURE;
 456
 457   return SUCCESS;
 458 }
 459
 460
 461 try
 462 gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
 463 {
 464   if (logical_array_check (mask, 0) == FAILURE)
 465     return FAILURE;
 466
 467   if (dim_check (dim, 1, 1) == FAILURE)
 468     return FAILURE;
 469
 470   if (gfc_init_expr)
 471     return non_init_transformational ();
 472
 473   return SUCCESS;
 474 }
 475
 476
 477 try
 478 gfc_check_allocated (gfc_expr * array)
 479 {
 480   symbol_attribute attr;
 481
 482   if (variable_check (array, 0) == FAILURE)
 483     return FAILURE;
 484
 485   if (array_check (array, 0) == FAILURE)
 486     return FAILURE;
 487
 488   attr = gfc_variable_attr (array, NULL);
 489   if (!attr.allocatable)
 490     {
 491       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
 492                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 493                  &array->where);
 494       return FAILURE;
 495     }
 496
 497   return SUCCESS;
 498 }
 499
 500
 501 /* Common check function where the first argument must be real or
 502    integer and the second argument must be the same as the first.  */
 503
 504 try
 505 gfc_check_a_p (gfc_expr * a, gfc_expr * p)
 506 {
 507   if (int_or_real_check (a, 0) == FAILURE)
 508     return FAILURE;
 509
 510   if (a->ts.type != p->ts.type)
 511     {
 512       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
 513                 "have the same type", gfc_current_intrinsic_arg[0],
 514                 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
 515                 &p->where);
 516       return FAILURE;
 517     }
 518
 519   if (a->ts.kind != p->ts.kind)
 520     {
 521       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 522                           &p->where) == FAILURE)
 523        return FAILURE;
 524     }
 525
 526   return SUCCESS;
 527 }
 528
 529
 530 try
 531 gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
 532 {
 533   symbol_attribute attr;
 534   int i;
 535   try t;
 536   locus *where;
 537
 538   where = &pointer->where;
 539
 540   if (pointer->expr_type == EXPR_VARIABLE)
 541     attr = gfc_variable_attr (pointer, NULL);
 542   else if (pointer->expr_type == EXPR_FUNCTION)
 543     attr = pointer->symtree->n.sym->attr;
 544   else if (pointer->expr_type == EXPR_NULL)
 545     goto null_arg;
 546   else
 547     gcc_assert (0); /* Pointer must be a variable or a function.  */
 548
 549   if (!attr.pointer)
 550     {
 551       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
 552                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 553                  &pointer->where);
 554       return FAILURE;
 555     }
 556
 557   /* Target argument is optional.  */
 558   if (target == NULL)
 559     return SUCCESS;
 560
 561   where = &target->where;
 562   if (target->expr_type == EXPR_NULL)
 563     goto null_arg;
 564
 565   if (target->expr_type == EXPR_VARIABLE)
 566     attr = gfc_variable_attr (target, NULL);
 567   else if (target->expr_type == EXPR_FUNCTION)
 568     attr = target->symtree->n.sym->attr;
 569   else
 570     {
 571       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
 572                  "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
 573                  gfc_current_intrinsic, &target->where);
 574       return FAILURE;
 575     }
 576
 577   if (!attr.pointer && !attr.target)
 578     {
 579       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
 580                  "or a TARGET", gfc_current_intrinsic_arg[1],
 581                  gfc_current_intrinsic, &target->where);
 582       return FAILURE;
 583     }
 584
 585   t = SUCCESS;
 586   if (same_type_check (pointer, 0, target, 1) == FAILURE)
 587     t = FAILURE;
 588   if (rank_check (target, 0, pointer->rank) == FAILURE)
 589     t = FAILURE;
 590   if (target->rank > 0)
 591     {
 592       for (i = 0; i < target->rank; i++)
 593         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 594           {
 595             gfc_error ("Array section with a vector subscript at %L shall not "
 596                        "be the target of a pointer",
 597                        &target->where);
 598             t = FAILURE;
 599             break;
 600           }
 601     }
 602   return t;
 603
 604 null_arg:
 605
 606   gfc_error ("NULL pointer at %L is not permitted as actual argument "
 607              "of '%s' intrinsic function", where, gfc_current_intrinsic);
 608   return FAILURE;
 609
 610 }
 611
 612
 613 try
 614 gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
 615 {
 616   if (type_check (y, 0, BT_REAL) == FAILURE)
 617     return FAILURE;
 618   if (same_type_check (y, 0, x, 1) == FAILURE)
 619     return FAILURE;
 620
 621   return SUCCESS;
 622 }
 623
 624
 625 /* BESJN and BESYN functions.  */
 626
 627 try
 628 gfc_check_besn (gfc_expr * n, gfc_expr * x)
 629 {
 630   if (scalar_check (n, 0) == FAILURE)
 631     return FAILURE;
 632
 633   if (type_check (n, 0, BT_INTEGER) == FAILURE)
 634     return FAILURE;
 635
 636   if (scalar_check (x, 1) == FAILURE)
 637     return FAILURE;
 638
 639   if (type_check (x, 1, BT_REAL) == FAILURE)
 640     return FAILURE;
 641
 642   return SUCCESS;
 643 }
 644
 645
 646 try
 647 gfc_check_btest (gfc_expr * i, gfc_expr * pos)
 648 {
 649   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 650     return FAILURE;
 651   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 652     return FAILURE;
 653
 654   return SUCCESS;
 655 }
 656
 657
 658 try
 659 gfc_check_char (gfc_expr * i, gfc_expr * kind)
 660 {
 661   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 662     return FAILURE;
 663   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 664     return FAILURE;
 665
 666   return SUCCESS;
 667 }
 668
 669
 670 try
 671 gfc_check_chdir (gfc_expr * dir)
 672 {
 673   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 674     return FAILURE;
 675
 676   return SUCCESS;
 677 }
 678
 679
 680 try
 681 gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
 682 {
 683   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 684     return FAILURE;
 685
 686   if (status == NULL)
 687     return SUCCESS;
 688
 689   if (type_check (status, 1, BT_INTEGER) == FAILURE)
 690     return FAILURE;
 691
 692   if (scalar_check (status, 1) == FAILURE)
 693     return FAILURE;
 694
 695   return SUCCESS;
 696 }
 697
 698
 699 try
 700 gfc_check_chmod (gfc_expr * name, gfc_expr * mode)
 701 {
 702   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
 703     return FAILURE;
 704
 705   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
 706     return FAILURE;
 707
 708   return SUCCESS;
 709 }
 710
 711
 712 try
 713 gfc_check_chmod_sub (gfc_expr * name, gfc_expr * mode, gfc_expr * status)
 714 {
 715   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
 716     return FAILURE;
 717
 718   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
 719     return FAILURE;
 720
 721   if (status == NULL)
 722     return SUCCESS;
 723
 724   if (type_check (status, 2, BT_INTEGER) == FAILURE)
 725     return FAILURE;
 726
 727   if (scalar_check (status, 2) == FAILURE)
 728     return FAILURE;
 729
 730   return SUCCESS;
 731 }
 732
 733
 734 try
 735 gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 736 {
 737   if (numeric_check (x, 0) == FAILURE)
 738     return FAILURE;
 739
 740   if (y != NULL)
 741     {
 742       if (numeric_check (y, 1) == FAILURE)
 743         return FAILURE;
 744
 745       if (x->ts.type == BT_COMPLEX)
 746         {
 747           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 748                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 749                      gfc_current_intrinsic, &y->where);
 750           return FAILURE;
 751         }
 752     }
 753
 754   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 755     return FAILURE;
 756
 757   return SUCCESS;
 758 }
 759
 760
 761 try
 762 gfc_check_complex (gfc_expr * x, gfc_expr * y)
 763 {
 764   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
 765     {
 766       gfc_error (
 767         "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
 768         gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
 769       return FAILURE;
 770     }
 771   if (scalar_check (x, 0) == FAILURE)
 772     return FAILURE;
 773
 774   if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
 775     {
 776       gfc_error (
 777         "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
 778         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
 779       return FAILURE;
 780     }
 781   if (scalar_check (y, 1) == FAILURE)
 782     return FAILURE;
 783
 784   return SUCCESS;
 785 }
 786
 787
 788 try
 789 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
 790 {
 791   if (logical_array_check (mask, 0) == FAILURE)
 792     return FAILURE;
 793   if (dim_check (dim, 1, 1) == FAILURE)
 794     return FAILURE;
 795
 796   if (gfc_init_expr)
 797     return non_init_transformational ();
 798
 799   return SUCCESS;
 800 }
 801
 802
 803 try
 804 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
 805 {
 806   if (array_check (array, 0) == FAILURE)
 807     return FAILURE;
 808
 809   if (array->rank == 1)
 810     {
 811       if (scalar_check (shift, 1) == FAILURE)
 812         return FAILURE;
 813     }
 814   else
 815     {
 816       /* TODO: more requirements on shift parameter.  */
 817     }
 818
 819   if (dim_check (dim, 2, 1) == FAILURE)
 820     return FAILURE;
 821
 822   if (gfc_init_expr)
 823     return non_init_transformational ();
 824
 825   return SUCCESS;
 826 }
 827
 828
 829 try
 830 gfc_check_ctime (gfc_expr * time)
 831 {
 832   if (scalar_check (time, 0) == FAILURE)
 833     return FAILURE;
 834
 835   if (type_check (time, 0, BT_INTEGER) == FAILURE)
 836     return FAILURE;
 837
 838   return SUCCESS;
 839 }
 840
 841
 842 try
 843 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 844 {
 845   if (numeric_check (x, 0) == FAILURE)
 846     return FAILURE;
 847
 848   if (y != NULL)
 849     {
 850       if (numeric_check (y, 1) == FAILURE)
 851         return FAILURE;
 852
 853       if (x->ts.type == BT_COMPLEX)
 854         {
 855           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 856                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 857                      gfc_current_intrinsic, &y->where);
 858           return FAILURE;
 859         }
 860     }
 861
 862   return SUCCESS;
 863 }
 864
 865
 866 try
 867 gfc_check_dble (gfc_expr * x)
 868 {
 869   if (numeric_check (x, 0) == FAILURE)
 870     return FAILURE;
 871
 872   return SUCCESS;
 873 }
 874
 875
 876 try
 877 gfc_check_digits (gfc_expr * x)
 878 {
 879   if (int_or_real_check (x, 0) == FAILURE)
 880     return FAILURE;
 881
 882   return SUCCESS;
 883 }
 884
 885
 886 try
 887 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
 888 {
 889   switch (vector_a->ts.type)
 890     {
 891     case BT_LOGICAL:
 892       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 893         return FAILURE;
 894       break;
 895
 896     case BT_INTEGER:
 897     case BT_REAL:
 898     case BT_COMPLEX:
 899       if (numeric_check (vector_b, 1) == FAILURE)
 900         return FAILURE;
 901       break;
 902
 903     default:
 904       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
 905                  "or LOGICAL", gfc_current_intrinsic_arg[0],
 906                  gfc_current_intrinsic, &vector_a->where);
 907       return FAILURE;
 908     }
 909
 910   if (rank_check (vector_a, 0, 1) == FAILURE)
 911     return FAILURE;
 912
 913   if (rank_check (vector_b, 1, 1) == FAILURE)
 914     return FAILURE;
 915
 916   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
 917     {
 918       gfc_error ("different shape for arguments '%s' and '%s' "
 919                  "at %L for intrinsic 'dot_product'",
 920                  gfc_current_intrinsic_arg[0],
 921                  gfc_current_intrinsic_arg[1],
 922                  &vector_a->where);
 923       return FAILURE;
 924     }
 925
 926   if (gfc_init_expr)
 927     return non_init_transformational ();
 928
 929   return SUCCESS;
 930 }
 931
 932
 933 try
 934 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
 935                    gfc_expr * dim)
 936 {
 937   if (array_check (array, 0) == FAILURE)
 938     return FAILURE;
 939
 940   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 941     return FAILURE;
 942
 943   if (array->rank == 1)
 944     {
 945       if (scalar_check (shift, 2) == FAILURE)
 946         return FAILURE;
 947     }
 948   else
 949     {
 950       /* TODO: more weird restrictions on shift.  */
 951     }
 952
 953   if (boundary != NULL)
 954     {
 955       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 956         return FAILURE;
 957
 958       /* TODO: more restrictions on boundary.  */
 959     }
 960
 961   if (dim_check (dim, 1, 1) == FAILURE)
 962     return FAILURE;
 963
 964   if (gfc_init_expr)
 965     return non_init_transformational ();
 966
 967   return SUCCESS;
 968 }
 969
 970
 971 /* A single complex argument.  */
 972
 973 try
 974 gfc_check_fn_c (gfc_expr * a)
 975 {
 976   if (type_check (a, 0, BT_COMPLEX) == FAILURE)
 977     return FAILURE;
 978
 979   return SUCCESS;
 980 }
 981
 982
 983 /* A single real argument.  */
 984
 985 try
 986 gfc_check_fn_r (gfc_expr * a)
 987 {
 988   if (type_check (a, 0, BT_REAL) == FAILURE)
 989     return FAILURE;
 990
 991   return SUCCESS;
 992 }
 993
 994
 995 /* A single real or complex argument.  */
 996
 997 try
 998 gfc_check_fn_rc (gfc_expr * a)
 999 {
1000   if (real_or_complex_check (a, 0) == FAILURE)
1001     return FAILURE;
1002
1003   return SUCCESS;
1004 }
1005
1006
1007 try
1008 gfc_check_fnum (gfc_expr * unit)
1009 {
1010   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1011     return FAILURE;
1012
1013   if (scalar_check (unit, 0) == FAILURE)
1014     return FAILURE;
1015
1016   return SUCCESS;
1017 }
1018
1019
1020 /* This is used for the g77 one-argument Bessel functions, and the
1021    error function.  */
1022
1023 try
1024 gfc_check_g77_math1 (gfc_expr * x)
1025 {
1026   if (scalar_check (x, 0) == FAILURE)
1027     return FAILURE;
1028
1029   if (type_check (x, 0, BT_REAL) == FAILURE)
1030     return FAILURE;
1031
1032   return SUCCESS;
1033 }
1034
1035
1036 try
1037 gfc_check_huge (gfc_expr * x)
1038 {
1039   if (int_or_real_check (x, 0) == FAILURE)
1040     return FAILURE;
1041
1042   return SUCCESS;
1043 }
1044
1045
1046 /* Check that the single argument is an integer.  */
1047
1048 try
1049 gfc_check_i (gfc_expr * i)
1050 {
1051   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1052     return FAILURE;
1053
1054   return SUCCESS;
1055 }
1056
1057
1058 try
1059 gfc_check_iand (gfc_expr * i, gfc_expr * j)
1060 {
1061   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1062     return FAILURE;
1063
1064   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1065     return FAILURE;
1066
1067   if (i->ts.kind != j->ts.kind)
1068     {
1069       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1070                           &i->where) == FAILURE)
1071         return FAILURE;
1072     }
1073
1074   return SUCCESS;
1075 }
1076
1077
1078 try
1079 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
1080 {
1081   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1082     return FAILURE;
1083
1084   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1085     return FAILURE;
1086
1087   return SUCCESS;
1088 }
1089
1090
1091 try
1092 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
1093 {
1094   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1095     return FAILURE;
1096
1097   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1098     return FAILURE;
1099
1100   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1101     return FAILURE;
1102
1103   return SUCCESS;
1104 }
1105
1106
1107 try
1108 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
1109 {
1110   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1111     return FAILURE;
1112
1113   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1114     return FAILURE;
1115
1116   return SUCCESS;
1117 }
1118
1119
1120 try
1121 gfc_check_ichar_iachar (gfc_expr * c)
1122 {
1123   int i;
1124
1125   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1126     return FAILURE;
1127
1128   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1129     {
1130       gfc_expr *start;
1131       gfc_expr *end;
1132       gfc_ref *ref;
1133
1134       /* Substring references don't have the charlength set.  */
1135       ref = c->ref;
1136       while (ref && ref->type != REF_SUBSTRING)
1137         ref = ref->next;
1138
1139       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1140
1141       if (!ref)
1142         {
1143           /* Check that the argument is length one.  Non-constant lengths
1144              can't be checked here, so assume they are ok.  */
1145           if (c->ts.cl && c->ts.cl->length)
1146             {
1147               /* If we already have a length for this expression then use it.  */
1148               if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1149                 return SUCCESS;
1150               i = mpz_get_si (c->ts.cl->length->value.integer);
1151             }
1152           else
1153             return SUCCESS;
1154         }
1155       else
1156         {
1157           start = ref->u.ss.start;
1158           end = ref->u.ss.end;
1159
1160           gcc_assert (start);
1161           if (end == NULL || end->expr_type != EXPR_CONSTANT
1162               || start->expr_type != EXPR_CONSTANT)
1163             return SUCCESS;
1164
1165           i = mpz_get_si (end->value.integer) + 1
1166               - mpz_get_si (start->value.integer);
1167         }
1168     }
1169   else
1170     return SUCCESS;
1171
1172   if (i != 1)
1173     {
1174       gfc_error ("Argument of %s at %L must be of length one",
1175                  gfc_current_intrinsic, &c->where);
1176       return FAILURE;
1177     }
1178
1179   return SUCCESS;
1180 }
1181
1182
1183 try
1184 gfc_check_idnint (gfc_expr * a)
1185 {
1186   if (double_check (a, 0) == FAILURE)
1187     return FAILURE;
1188
1189   return SUCCESS;
1190 }
1191
1192
1193 try
1194 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
1195 {
1196   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1197     return FAILURE;
1198
1199   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1200     return FAILURE;
1201
1202   if (i->ts.kind != j->ts.kind)
1203     {
1204       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1205                           &i->where) == FAILURE)
1206         return FAILURE;
1207     }
1208
1209   return SUCCESS;
1210 }
1211
1212
1213 try
1214 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
1215 {
1216   if (type_check (string, 0, BT_CHARACTER) == FAILURE
1217       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1218     return FAILURE;
1219
1220
1221   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1222     return FAILURE;
1223
1224   if (string->ts.kind != substring->ts.kind)
1225     {
1226       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1227                  "kind as '%s'", gfc_current_intrinsic_arg[1],
1228                  gfc_current_intrinsic, &substring->where,
1229                  gfc_current_intrinsic_arg[0]);
1230       return FAILURE;
1231     }
1232
1233   return SUCCESS;
1234 }
1235
1236
1237 try
1238 gfc_check_int (gfc_expr * x, gfc_expr * kind)
1239 {
1240   if (numeric_check (x, 0) == FAILURE)
1241     return FAILURE;
1242
1243   if (kind != NULL)
1244     {
1245       if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1246     return FAILURE;
1247
1248       if (scalar_check (kind, 1) == FAILURE)
1249         return FAILURE;
1250     }
1251
1252   return SUCCESS;
1253 }
1254
1255
1256 try
1257 gfc_check_intconv (gfc_expr * x)
1258 {
1259   if (numeric_check (x, 0) == FAILURE)
1260     return FAILURE;
1261
1262   return SUCCESS;
1263 }
1264
1265
1266 try
1267 gfc_check_ior (gfc_expr * i, gfc_expr * j)
1268 {
1269   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1270     return FAILURE;
1271
1272   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1273     return FAILURE;
1274
1275   if (i->ts.kind != j->ts.kind)
1276     {
1277       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1278                           &i->where) == FAILURE)
1279     return FAILURE;
1280     }
1281
1282   return SUCCESS;
1283 }
1284
1285
1286 try
1287 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
1288 {
1289   if (type_check (i, 0, BT_INTEGER) == FAILURE
1290       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1291     return FAILURE;
1292
1293   return SUCCESS;
1294 }
1295
1296
1297 try
1298 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
1299 {
1300   if (type_check (i, 0, BT_INTEGER) == FAILURE
1301       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1302     return FAILURE;
1303
1304   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1305     return FAILURE;
1306
1307   return SUCCESS;
1308 }
1309
1310
1311 try
1312 gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
1313 {
1314   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1315     return FAILURE;
1316
1317   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1318     return FAILURE;
1319
1320   return SUCCESS;
1321 }
1322
1323
1324 try
1325 gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
1326 {
1327   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1328     return FAILURE;
1329
1330   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1331     return FAILURE;
1332
1333   if (status == NULL)
1334     return SUCCESS;
1335
1336   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1337     return FAILURE;
1338
1339   if (scalar_check (status, 2) == FAILURE)
1340     return FAILURE;
1341
1342   return SUCCESS;
1343 }
1344
1345
1346 try
1347 gfc_check_kind (gfc_expr * x)
1348 {
1349   if (x->ts.type == BT_DERIVED)
1350     {
1351       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1352                  "non-derived type", gfc_current_intrinsic_arg[0],
1353                  gfc_current_intrinsic, &x->where);
1354       return FAILURE;
1355     }
1356
1357   return SUCCESS;
1358 }
1359
1360
1361 try
1362 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1363 {
1364   if (array_check (array, 0) == FAILURE)
1365     return FAILURE;
1366
1367   if (dim != NULL)
1368     {
1369       if (dim_check (dim, 1, 1) == FAILURE)
1370         return FAILURE;
1371
1372       if (dim_rank_check (dim, array, 1) == FAILURE)
1373         return FAILURE;
1374     }
1375   return SUCCESS;
1376 }
1377
1378
1379 try
1380 gfc_check_link (gfc_expr * path1, gfc_expr * path2)
1381 {
1382   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1383     return FAILURE;
1384
1385   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1386     return FAILURE;
1387
1388   return SUCCESS;
1389 }
1390
1391
1392 try
1393 gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1394 {
1395   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1396     return FAILURE;
1397
1398   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1399     return FAILURE;
1400
1401   if (status == NULL)
1402     return SUCCESS;
1403
1404   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1405     return FAILURE;
1406
1407   if (scalar_check (status, 2) == FAILURE)
1408     return FAILURE;
1409
1410   return SUCCESS;
1411 }
1412
1413 try
1414 gfc_check_loc (gfc_expr *expr)
1415 {
1416   return variable_check (expr, 0);
1417 }
1418
1419
1420 try
1421 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
1422 {
1423   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1424     return FAILURE;
1425
1426   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1427     return FAILURE;
1428
1429   return SUCCESS;
1430 }
1431
1432
1433 try
1434 gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1435 {
1436   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1437     return FAILURE;
1438
1439   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1440     return FAILURE;
1441
1442   if (status == NULL)
1443     return SUCCESS;
1444
1445   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1446     return FAILURE;
1447
1448   if (scalar_check (status, 2) == FAILURE)
1449     return FAILURE;
1450
1451   return SUCCESS;
1452 }
1453
1454
1455 try
1456 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1457 {
1458   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1459     return FAILURE;
1460   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1461     return FAILURE;
1462
1463   return SUCCESS;
1464 }
1465
1466
1467 /* Min/max family.  */
1468
1469 static try
1470 min_max_args (gfc_actual_arglist * arg)
1471 {
1472   if (arg == NULL || arg->next == NULL)
1473     {
1474       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1475                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1476       return FAILURE;
1477     }
1478
1479   return SUCCESS;
1480 }
1481
1482
1483 static try
1484 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1485 {
1486   gfc_expr *x;
1487   int n;
1488
1489   if (min_max_args (arg) == FAILURE)
1490     return FAILURE;
1491
1492   n = 1;
1493
1494   for (; arg; arg = arg->next, n++)
1495     {
1496       x = arg->expr;
1497       if (x->ts.type != type || x->ts.kind != kind)
1498         {
1499           if (x->ts.type == type)
1500             {
1501               if (gfc_notify_std (GFC_STD_GNU,
1502                     "Extension: Different type kinds at %L", &x->where)
1503                   == FAILURE)
1504                 return FAILURE;
1505             }
1506           else
1507             {
1508               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1509                          n, gfc_current_intrinsic, &x->where,
1510                          gfc_basic_typename (type), kind);
1511               return FAILURE;
1512             }
1513         }
1514     }
1515
1516   return SUCCESS;
1517 }
1518
1519
1520 try
1521 gfc_check_min_max (gfc_actual_arglist * arg)
1522 {
1523   gfc_expr *x;
1524
1525   if (min_max_args (arg) == FAILURE)
1526     return FAILURE;
1527
1528   x = arg->expr;
1529
1530   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1531     {
1532       gfc_error
1533         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1534          gfc_current_intrinsic, &x->where);
1535       return FAILURE;
1536     }
1537
1538   return check_rest (x->ts.type, x->ts.kind, arg);
1539 }
1540
1541
1542 try
1543 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1544 {
1545   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1546 }
1547
1548
1549 try
1550 gfc_check_min_max_real (gfc_actual_arglist * arg)
1551 {
1552   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1553 }
1554
1555
1556 try
1557 gfc_check_min_max_double (gfc_actual_arglist * arg)
1558 {
1559   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1560 }
1561
1562 /* End of min/max family.  */
1563
1564 try
1565 gfc_check_malloc (gfc_expr * size)
1566 {
1567   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1568     return FAILURE;
1569
1570   if (scalar_check (size, 0) == FAILURE)
1571     return FAILURE;
1572
1573   return SUCCESS;
1574 }
1575
1576
1577 try
1578 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1579 {
1580   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1581     {
1582       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1583                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1584                  gfc_current_intrinsic, &matrix_a->where);
1585       return FAILURE;
1586     }
1587
1588   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1589     {
1590       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1591                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1592                  gfc_current_intrinsic, &matrix_b->where);
1593       return FAILURE;
1594     }
1595
1596   switch (matrix_a->rank)
1597     {
1598     case 1:
1599       if (rank_check (matrix_b, 1, 2) == FAILURE)
1600         return FAILURE;
1601       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
1602       if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1603         {
1604           gfc_error ("different shape on dimension 1 for arguments '%s' "
1605                      "and '%s' at %L for intrinsic matmul",
1606                      gfc_current_intrinsic_arg[0],
1607                      gfc_current_intrinsic_arg[1],
1608                      &matrix_a->where);
1609           return FAILURE;
1610         }
1611       break;
1612
1613     case 2:
1614       if (matrix_b->rank != 2)
1615         {
1616           if (rank_check (matrix_b, 1, 1) == FAILURE)
1617             return FAILURE;
1618         }
1619       /* matrix_b has rank 1 or 2 here. Common check for the cases
1620          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1621          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
1622       if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1623         {
1624           gfc_error ("different shape on dimension 2 for argument '%s' and "
1625                      "dimension 1 for argument '%s' at %L for intrinsic "
1626                      "matmul", gfc_current_intrinsic_arg[0],
1627                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1628           return FAILURE;
1629         }
1630       break;
1631
1632     default:
1633       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1634                  "1 or 2", gfc_current_intrinsic_arg[0],
1635                  gfc_current_intrinsic, &matrix_a->where);
1636       return FAILURE;
1637     }
1638
1639   if (gfc_init_expr)
1640     return non_init_transformational ();
1641
1642   return SUCCESS;
1643 }
1644
1645
1646 /* Whoever came up with this interface was probably on something.
1647    The possibilities for the occupation of the second and third
1648    parameters are:
1649
1650          Arg #2     Arg #3
1651          NULL       NULL
1652          DIM        NULL
1653          MASK       NULL
1654          NULL       MASK             minloc(array, mask=m)
1655          DIM        MASK
1656
1657    I.e. in the case of minloc(array,mask), mask will be in the second
1658    position of the argument list and we'll have to fix that up.  */
1659
1660 try
1661 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1662 {
1663   gfc_expr *a, *m, *d;
1664
1665   a = ap->expr;
1666   if (int_or_real_check (a, 0) == FAILURE
1667       || array_check (a, 0) == FAILURE)
1668     return FAILURE;
1669
1670   d = ap->next->expr;
1671   m = ap->next->next->expr;
1672
1673   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1674       && ap->next->name == NULL)
1675     {
1676       m = d;
1677       d = NULL;
1678
1679       ap->next->expr = NULL;
1680       ap->next->next->expr = m;
1681     }
1682
1683   if (dim_check (d, 1, 1) == FAILURE)
1684     return FAILURE;
1685
1686   if (d && dim_rank_check (d, a, 0) == FAILURE)
1687     return FAILURE;
1688
1689   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1690     return FAILURE;
1691
1692   if (m != NULL)
1693     {
1694       char buffer[80];
1695       snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1696                gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1697                gfc_current_intrinsic);
1698       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1699         return FAILURE;
1700     }
1701
1702   if (gfc_init_expr)
1703     return non_init_transformational ();
1704
1705   return SUCCESS;
1706 }
1707
1708
1709 /* Similar to minloc/maxloc, the argument list might need to be
1710    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1711    difference is that MINLOC/MAXLOC take an additional KIND argument.
1712    The possibilities are:
1713
1714          Arg #2     Arg #3
1715          NULL       NULL
1716          DIM        NULL
1717          MASK       NULL
1718          NULL       MASK             minval(array, mask=m)
1719          DIM        MASK
1720
1721    I.e. in the case of minval(array,mask), mask will be in the second
1722    position of the argument list and we'll have to fix that up.  */
1723
1724 static try
1725 check_reduction (gfc_actual_arglist * ap)
1726 {
1727   gfc_expr *a, *m, *d;
1728
1729   a = ap->expr;
1730   d = ap->next->expr;
1731   m = ap->next->next->expr;
1732
1733   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1734       && ap->next->name == NULL)
1735     {
1736       m = d;
1737       d = NULL;
1738
1739       ap->next->expr = NULL;
1740       ap->next->next->expr = m;
1741     }
1742
1743   if (dim_check (d, 1, 1) == FAILURE)
1744     return FAILURE;
1745
1746   if (d && dim_rank_check (d, a, 0) == FAILURE)
1747     return FAILURE;
1748
1749   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1750     return FAILURE;
1751
1752   if (m != NULL)
1753     {
1754       char buffer[80];
1755       snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1756                gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1757                gfc_current_intrinsic);
1758       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1759         return FAILURE;
1760     }
1761
1762   return SUCCESS;
1763 }
1764
1765
1766 try
1767 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1768 {
1769   if (int_or_real_check (ap->expr, 0) == FAILURE
1770       || array_check (ap->expr, 0) == FAILURE)
1771     return FAILURE;
1772
1773   if (gfc_init_expr)
1774     return non_init_transformational ();
1775
1776   return check_reduction (ap);
1777 }
1778
1779
1780 try
1781 gfc_check_product_sum (gfc_actual_arglist * ap)
1782 {
1783   if (numeric_check (ap->expr, 0) == FAILURE
1784       || array_check (ap->expr, 0) == FAILURE)
1785     return FAILURE;
1786
1787   if (gfc_init_expr)
1788     return non_init_transformational ();
1789
1790   return check_reduction (ap);
1791 }
1792
1793
1794 try
1795 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1796 {
1797   char buffer[80];
1798
1799   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1800     return FAILURE;
1801
1802   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1803     return FAILURE;
1804
1805   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1806            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1807            gfc_current_intrinsic);
1808   if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
1809     return FAILURE;
1810
1811   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1812            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1813            gfc_current_intrinsic);
1814   if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
1815     return FAILURE;
1816
1817   return SUCCESS;
1818 }
1819
1820 try
1821 gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
1822 {
1823   symbol_attribute attr;
1824
1825   if (variable_check (from, 0) == FAILURE)
1826     return FAILURE;
1827
1828   if (array_check (from, 0) == FAILURE)
1829     return FAILURE;
1830
1831   attr = gfc_variable_attr (from, NULL);
1832   if (!attr.allocatable)
1833     {
1834       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1835                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1836                  &from->where);
1837       return FAILURE;
1838     }
1839
1840   if (variable_check (to, 0) == FAILURE)
1841     return FAILURE;
1842
1843   if (array_check (to, 0) == FAILURE)
1844     return FAILURE;
1845
1846   attr = gfc_variable_attr (to, NULL);
1847   if (!attr.allocatable)
1848     {
1849       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1850                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1851                  &to->where);
1852       return FAILURE;
1853     }
1854
1855   if (same_type_check (from, 0, to, 1) == FAILURE)
1856     return FAILURE;
1857
1858   if (to->rank != from->rank)
1859     {
1860       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1861                  "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1862                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1863                  &to->where,  from->rank, to->rank);
1864       return FAILURE;
1865     }
1866
1867   if (to->ts.kind != from->ts.kind)
1868     {
1869       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1870                  "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1871                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1872                  &to->where, from->ts.kind, to->ts.kind);
1873       return FAILURE;
1874     }
1875
1876   return SUCCESS;
1877 }
1878
1879 try
1880 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1881 {
1882   if (type_check (x, 0, BT_REAL) == FAILURE)
1883     return FAILURE;
1884
1885   if (type_check (s, 1, BT_REAL) == FAILURE)
1886     return FAILURE;
1887
1888   return SUCCESS;
1889 }
1890
1891 try
1892 gfc_check_new_line (gfc_expr * a)
1893 {
1894   if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1895     return FAILURE;
1896
1897   return SUCCESS;
1898 }
1899
1900 try
1901 gfc_check_null (gfc_expr * mold)
1902 {
1903   symbol_attribute attr;
1904
1905   if (mold == NULL)
1906     return SUCCESS;
1907
1908   if (variable_check (mold, 0) == FAILURE)
1909     return FAILURE;
1910
1911   attr = gfc_variable_attr (mold, NULL);
1912
1913   if (!attr.pointer)
1914     {
1915       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1916                  gfc_current_intrinsic_arg[0],
1917                  gfc_current_intrinsic, &mold->where);
1918       return FAILURE;
1919     }
1920
1921   return SUCCESS;
1922 }
1923
1924
1925 try
1926 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1927 {
1928   char buffer[80];
1929
1930   if (array_check (array, 0) == FAILURE)
1931     return FAILURE;
1932
1933   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1934     return FAILURE;
1935
1936   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1937            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1938            gfc_current_intrinsic);
1939   if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1940     return FAILURE;
1941
1942   if (vector != NULL)
1943     {
1944       if (same_type_check (array, 0, vector, 2) == FAILURE)
1945         return FAILURE;
1946
1947       if (rank_check (vector, 2, 1) == FAILURE)
1948         return FAILURE;
1949
1950       /* TODO: More constraints here.  */
1951     }
1952
1953   if (gfc_init_expr)
1954     return non_init_transformational ();
1955
1956   return SUCCESS;
1957 }
1958
1959
1960 try
1961 gfc_check_precision (gfc_expr * x)
1962 {
1963   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1964     {
1965       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1966                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1967                  gfc_current_intrinsic, &x->where);
1968       return FAILURE;
1969     }
1970
1971   return SUCCESS;
1972 }
1973
1974
1975 try
1976 gfc_check_present (gfc_expr * a)
1977 {
1978   gfc_symbol *sym;
1979
1980   if (variable_check (a, 0) == FAILURE)
1981     return FAILURE;
1982
1983   sym = a->symtree->n.sym;
1984   if (!sym->attr.dummy)
1985     {
1986       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1987                  "dummy variable", gfc_current_intrinsic_arg[0],
1988                  gfc_current_intrinsic, &a->where);
1989       return FAILURE;
1990     }
1991
1992   if (!sym->attr.optional)
1993     {
1994       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1995                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1996                  gfc_current_intrinsic, &a->where);
1997       return FAILURE;
1998     }
1999
2000 /*  13.14.82  PRESENT(A)
2001 ......
2002   Argument.  A shall be the name of an optional dummy argument that is accessible
2003   in the subprogram in which the PRESENT function reference appears...  */
2004
2005   if (a->ref != NULL
2006         && !(a->ref->next == NULL
2007                && a->ref->type == REF_ARRAY
2008                && a->ref->u.ar.type == AR_FULL))
2009     {
2010       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-"
2011                  "object of '%s'", gfc_current_intrinsic_arg[0],
2012                  gfc_current_intrinsic, &a->where, sym->name);
2013       return FAILURE;
2014     }
2015
2016   return SUCCESS;
2017 }
2018
2019
2020 try
2021 gfc_check_radix (gfc_expr * x)
2022 {
2023   if (int_or_real_check (x, 0) == FAILURE)
2024     return FAILURE;
2025
2026   return SUCCESS;
2027 }
2028
2029
2030 try
2031 gfc_check_range (gfc_expr * x)
2032 {
2033   if (numeric_check (x, 0) == FAILURE)
2034     return FAILURE;
2035
2036   return SUCCESS;
2037 }
2038
2039
2040 /* real, float, sngl.  */
2041 try
2042 gfc_check_real (gfc_expr * a, gfc_expr * kind)
2043 {
2044   if (numeric_check (a, 0) == FAILURE)
2045     return FAILURE;
2046
2047   if (kind_check (kind, 1, BT_REAL) == FAILURE)
2048     return FAILURE;
2049
2050   return SUCCESS;
2051 }
2052
2053
2054 try
2055 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
2056 {
2057   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2058     return FAILURE;
2059
2060   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2061     return FAILURE;
2062
2063   return SUCCESS;
2064 }
2065
2066
2067 try
2068 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
2069 {
2070   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2071     return FAILURE;
2072
2073   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2074     return FAILURE;
2075
2076   if (status == NULL)
2077     return SUCCESS;
2078
2079   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2080     return FAILURE;
2081
2082   if (scalar_check (status, 2) == FAILURE)
2083     return FAILURE;
2084
2085   return SUCCESS;
2086 }
2087
2088
2089 try
2090 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
2091 {
2092   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2093     return FAILURE;
2094
2095   if (scalar_check (x, 0) == FAILURE)
2096     return FAILURE;
2097
2098   if (type_check (y, 0, BT_INTEGER) == FAILURE)
2099     return FAILURE;
2100
2101   if (scalar_check (y, 1) == FAILURE)
2102     return FAILURE;
2103
2104   return SUCCESS;
2105 }
2106
2107
2108 try
2109 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
2110                    gfc_expr * pad, gfc_expr * order)
2111 {
2112   mpz_t size;
2113   int m;
2114
2115   if (array_check (source, 0) == FAILURE)
2116     return FAILURE;
2117
2118   if (rank_check (shape, 1, 1) == FAILURE)
2119     return FAILURE;
2120
2121   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2122     return FAILURE;
2123
2124   if (gfc_array_size (shape, &size) != SUCCESS)
2125     {
2126       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2127                  "array of constant size", &shape->where);
2128       return FAILURE;
2129     }
2130
2131   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2132   mpz_clear (size);
2133
2134   if (m > 0)
2135     {
2136       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2137                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2138       return FAILURE;
2139     }
2140
2141   if (pad != NULL)
2142     {
2143       if (same_type_check (source, 0, pad, 2) == FAILURE)
2144         return FAILURE;
2145       if (array_check (pad, 2) == FAILURE)
2146         return FAILURE;
2147     }
2148
2149   if (order != NULL && array_check (order, 3) == FAILURE)
2150     return FAILURE;
2151
2152   return SUCCESS;
2153 }
2154
2155
2156 try
2157 gfc_check_scale (gfc_expr * x, gfc_expr * i)
2158 {
2159   if (type_check (x, 0, BT_REAL) == FAILURE)
2160     return FAILURE;
2161
2162   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2163     return FAILURE;
2164
2165   return SUCCESS;
2166 }
2167
2168
2169 try
2170 gfc_check_scan (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 (type_check (y, 1, BT_CHARACTER) == FAILURE)
2176     return FAILURE;
2177
2178   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2179     return FAILURE;
2180
2181   if (same_type_check (x, 0, y, 1) == FAILURE)
2182     return FAILURE;
2183
2184   return SUCCESS;
2185 }
2186
2187
2188 try
2189 gfc_check_secnds (gfc_expr * r)
2190 {
2191
2192   if (type_check (r, 0, BT_REAL) == FAILURE)
2193     return FAILURE;
2194
2195   if (kind_value_check (r, 0, 4) == FAILURE)
2196     return FAILURE;
2197
2198   if (scalar_check (r, 0) == FAILURE)
2199     return FAILURE;
2200
2201   return SUCCESS;
2202 }
2203
2204
2205 try
2206 gfc_check_selected_int_kind (gfc_expr * r)
2207 {
2208
2209   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2210     return FAILURE;
2211
2212   if (scalar_check (r, 0) == FAILURE)
2213     return FAILURE;
2214
2215   return SUCCESS;
2216 }
2217
2218
2219 try
2220 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
2221 {
2222   if (p == NULL && r == NULL)
2223     {
2224       gfc_error ("Missing arguments to %s intrinsic at %L",
2225                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2226
2227       return FAILURE;
2228     }
2229
2230   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2231     return FAILURE;
2232
2233   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2234     return FAILURE;
2235
2236   return SUCCESS;
2237 }
2238
2239
2240 try
2241 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
2242 {
2243   if (type_check (x, 0, BT_REAL) == FAILURE)
2244     return FAILURE;
2245
2246   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2247     return FAILURE;
2248
2249   return SUCCESS;
2250 }
2251
2252
2253 try
2254 gfc_check_shape (gfc_expr * source)
2255 {
2256   gfc_array_ref *ar;
2257
2258   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2259     return SUCCESS;
2260
2261   ar = gfc_find_array_ref (source);
2262
2263   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2264     {
2265       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2266                  "an assumed size array", &source->where);
2267       return FAILURE;
2268     }
2269
2270   return SUCCESS;
2271 }
2272
2273
2274 try
2275 gfc_check_sign (gfc_expr * a, gfc_expr * b)
2276 {
2277   if (int_or_real_check (a, 0) == FAILURE)
2278     return FAILURE;
2279
2280   if (same_type_check (a, 0, b, 1) == FAILURE)
2281     return FAILURE;
2282
2283   return SUCCESS;
2284 }
2285
2286
2287 try
2288 gfc_check_size (gfc_expr * array, gfc_expr * dim)
2289 {
2290   if (array_check (array, 0) == FAILURE)
2291     return FAILURE;
2292
2293   if (dim != NULL)
2294     {
2295       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2296         return FAILURE;
2297
2298       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2299         return FAILURE;
2300
2301       if (dim_rank_check (dim, array, 0) == FAILURE)
2302         return FAILURE;
2303     }
2304
2305   return SUCCESS;
2306 }
2307
2308
2309 try
2310 gfc_check_sleep_sub (gfc_expr * seconds)
2311 {
2312   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2313     return FAILURE;
2314
2315   if (scalar_check (seconds, 0) == FAILURE)
2316     return FAILURE;
2317
2318   return SUCCESS;
2319 }
2320
2321
2322 try
2323 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
2324 {
2325   if (source->rank >= GFC_MAX_DIMENSIONS)
2326     {
2327       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2328                  "than rank %d", gfc_current_intrinsic_arg[0],
2329                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2330
2331       return FAILURE;
2332     }
2333
2334   if (dim_check (dim, 1, 0) == FAILURE)
2335     return FAILURE;
2336
2337   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2338     return FAILURE;
2339
2340   if (scalar_check (ncopies, 2) == FAILURE)
2341     return FAILURE;
2342
2343   if (gfc_init_expr)
2344     return non_init_transformational ();
2345
2346   return SUCCESS;
2347 }
2348
2349
2350 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2351    functions).  */
2352 try
2353 gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
2354 {
2355   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2356     return FAILURE;
2357
2358   if (scalar_check (unit, 0) == FAILURE)
2359     return FAILURE;
2360
2361   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2362     return FAILURE;
2363
2364   if (status == NULL)
2365     return SUCCESS;
2366
2367   if (type_check (status, 2, BT_INTEGER) == FAILURE
2368       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2369       || scalar_check (status, 2) == FAILURE)
2370     return FAILURE;
2371
2372   return SUCCESS;
2373 }
2374
2375
2376 try
2377 gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
2378 {
2379   return gfc_check_fgetputc_sub (unit, c, NULL);
2380 }
2381
2382
2383 try
2384 gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
2385 {
2386   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2387     return FAILURE;
2388
2389   if (status == NULL)
2390     return SUCCESS;
2391
2392   if (type_check (status, 1, BT_INTEGER) == FAILURE
2393       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2394       || scalar_check (status, 1) == FAILURE)
2395     return FAILURE;
2396
2397   return SUCCESS;
2398 }
2399
2400
2401 try
2402 gfc_check_fgetput (gfc_expr * c)
2403 {
2404   return gfc_check_fgetput_sub (c, NULL);
2405 }
2406
2407
2408 try
2409 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2410 {
2411   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2412     return FAILURE;
2413
2414   if (scalar_check (unit, 0) == FAILURE)
2415     return FAILURE;
2416
2417   if (type_check (array, 1, BT_INTEGER) == FAILURE
2418       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2419     return FAILURE;
2420
2421   if (array_check (array, 1) == FAILURE)
2422     return FAILURE;
2423
2424   return SUCCESS;
2425 }
2426
2427
2428 try
2429 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2430 {
2431   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2432     return FAILURE;
2433
2434   if (scalar_check (unit, 0) == FAILURE)
2435     return FAILURE;
2436
2437   if (type_check (array, 1, BT_INTEGER) == FAILURE
2438       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2439     return FAILURE;
2440
2441   if (array_check (array, 1) == FAILURE)
2442     return FAILURE;
2443
2444   if (status == NULL)
2445     return SUCCESS;
2446
2447   if (type_check (status, 2, BT_INTEGER) == FAILURE
2448       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2449     return FAILURE;
2450
2451   if (scalar_check (status, 2) == FAILURE)
2452     return FAILURE;
2453
2454   return SUCCESS;
2455 }
2456
2457
2458 try
2459 gfc_check_ftell (gfc_expr * unit)
2460 {
2461   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2462     return FAILURE;
2463
2464   if (scalar_check (unit, 0) == FAILURE)
2465     return FAILURE;
2466
2467   return SUCCESS;
2468 }
2469
2470
2471 try
2472 gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
2473 {
2474   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2475     return FAILURE;
2476
2477   if (scalar_check (unit, 0) == FAILURE)
2478     return FAILURE;
2479
2480   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2481     return FAILURE;
2482
2483   if (scalar_check (offset, 1) == FAILURE)
2484     return FAILURE;
2485
2486   return SUCCESS;
2487 }
2488
2489
2490 try
2491 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2492 {
2493   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2494     return FAILURE;
2495
2496   if (type_check (array, 1, BT_INTEGER) == FAILURE
2497       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2498     return FAILURE;
2499
2500   if (array_check (array, 1) == FAILURE)
2501     return FAILURE;
2502
2503   return SUCCESS;
2504 }
2505
2506
2507 try
2508 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2509 {
2510   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2511     return FAILURE;
2512
2513   if (type_check (array, 1, BT_INTEGER) == FAILURE
2514       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2515     return FAILURE;
2516
2517   if (array_check (array, 1) == FAILURE)
2518     return FAILURE;
2519
2520   if (status == NULL)
2521     return SUCCESS;
2522
2523   if (type_check (status, 2, BT_INTEGER) == FAILURE
2524       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2525     return FAILURE;
2526
2527   if (scalar_check (status, 2) == FAILURE)
2528     return FAILURE;
2529
2530   return SUCCESS;
2531 }
2532
2533
2534 try
2535 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2536                     gfc_expr * mold ATTRIBUTE_UNUSED,
2537                     gfc_expr * size)
2538 {
2539   if (size != NULL)
2540     {
2541       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2542         return FAILURE;
2543
2544       if (scalar_check (size, 2) == FAILURE)
2545         return FAILURE;
2546
2547       if (nonoptional_check (size, 2) == FAILURE)
2548         return FAILURE;
2549     }
2550
2551   return SUCCESS;
2552 }
2553
2554
2555 try
2556 gfc_check_transpose (gfc_expr * matrix)
2557 {
2558   if (rank_check (matrix, 0, 2) == FAILURE)
2559     return FAILURE;
2560
2561   if (gfc_init_expr)
2562     return non_init_transformational ();
2563
2564   return SUCCESS;
2565 }
2566
2567
2568 try
2569 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2570 {
2571   if (array_check (array, 0) == FAILURE)
2572     return FAILURE;
2573
2574   if (dim != NULL)
2575     {
2576       if (dim_check (dim, 1, 1) == FAILURE)
2577         return FAILURE;
2578
2579       if (dim_rank_check (dim, array, 0) == FAILURE)
2580         return FAILURE;
2581     }
2582
2583   return SUCCESS;
2584 }
2585
2586
2587 try
2588 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2589 {
2590   if (rank_check (vector, 0, 1) == FAILURE)
2591     return FAILURE;
2592
2593   if (array_check (mask, 1) == FAILURE)
2594     return FAILURE;
2595
2596   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2597     return FAILURE;
2598
2599   if (same_type_check (vector, 0, field, 2) == FAILURE)
2600     return FAILURE;
2601
2602   if (gfc_init_expr)
2603     return non_init_transformational ();
2604
2605   return SUCCESS;
2606 }
2607
2608
2609 try
2610 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2611 {
2612   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2613     return FAILURE;
2614
2615   if (same_type_check (x, 0, y, 1) == FAILURE)
2616     return FAILURE;
2617
2618   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2619     return FAILURE;
2620
2621   return SUCCESS;
2622 }
2623
2624
2625 try
2626 gfc_check_trim (gfc_expr * x)
2627 {
2628   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2629     return FAILURE;
2630
2631   if (scalar_check (x, 0) == FAILURE)
2632     return FAILURE;
2633
2634    return SUCCESS;
2635 }
2636
2637
2638 try
2639 gfc_check_ttynam (gfc_expr * unit)
2640 {
2641   if (scalar_check (unit, 0) == FAILURE)
2642     return FAILURE;
2643
2644   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2645     return FAILURE;
2646
2647   return SUCCESS;
2648 }
2649
2650
2651 /* Common check function for the half a dozen intrinsics that have a
2652    single real argument.  */
2653
2654 try
2655 gfc_check_x (gfc_expr * x)
2656 {
2657   if (type_check (x, 0, BT_REAL) == FAILURE)
2658     return FAILURE;
2659
2660   return SUCCESS;
2661 }
2662
2663
2664 /************* Check functions for intrinsic subroutines *************/
2665
2666 try
2667 gfc_check_cpu_time (gfc_expr * time)
2668 {
2669   if (scalar_check (time, 0) == FAILURE)
2670     return FAILURE;
2671
2672   if (type_check (time, 0, BT_REAL) == FAILURE)
2673     return FAILURE;
2674
2675   if (variable_check (time, 0) == FAILURE)
2676     return FAILURE;
2677
2678   return SUCCESS;
2679 }
2680
2681
2682 try
2683 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2684                          gfc_expr * zone, gfc_expr * values)
2685 {
2686   if (date != NULL)
2687     {
2688       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2689         return FAILURE;
2690       if (scalar_check (date, 0) == FAILURE)
2691         return FAILURE;
2692       if (variable_check (date, 0) == FAILURE)
2693         return FAILURE;
2694     }
2695
2696   if (time != NULL)
2697     {
2698       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2699         return FAILURE;
2700       if (scalar_check (time, 1) == FAILURE)
2701         return FAILURE;
2702       if (variable_check (time, 1) == FAILURE)
2703         return FAILURE;
2704     }
2705
2706   if (zone != NULL)
2707     {
2708       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2709         return FAILURE;
2710       if (scalar_check (zone, 2) == FAILURE)
2711         return FAILURE;
2712       if (variable_check (zone, 2) == FAILURE)
2713         return FAILURE;
2714     }
2715
2716   if (values != NULL)
2717     {
2718       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2719         return FAILURE;
2720       if (array_check (values, 3) == FAILURE)
2721         return FAILURE;
2722       if (rank_check (values, 3, 1) == FAILURE)
2723         return FAILURE;
2724       if (variable_check (values, 3) == FAILURE)
2725         return FAILURE;
2726     }
2727
2728   return SUCCESS;
2729 }
2730
2731
2732 try
2733 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2734                   gfc_expr * to, gfc_expr * topos)
2735 {
2736   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2737     return FAILURE;
2738
2739   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2740     return FAILURE;
2741
2742   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2743     return FAILURE;
2744
2745   if (same_type_check (from, 0, to, 3) == FAILURE)
2746     return FAILURE;
2747
2748   if (variable_check (to, 3) == FAILURE)
2749     return FAILURE;
2750
2751   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2752     return FAILURE;
2753
2754   return SUCCESS;
2755 }
2756
2757
2758 try
2759 gfc_check_random_number (gfc_expr * harvest)
2760 {
2761   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2762     return FAILURE;
2763
2764   if (variable_check (harvest, 0) == FAILURE)
2765     return FAILURE;
2766
2767   return SUCCESS;
2768 }
2769
2770
2771 try
2772 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2773 {
2774   if (size != NULL)
2775     {
2776       if (scalar_check (size, 0) == FAILURE)
2777         return FAILURE;
2778
2779       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2780         return FAILURE;
2781
2782       if (variable_check (size, 0) == FAILURE)
2783         return FAILURE;
2784
2785       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2786         return FAILURE;
2787     }
2788
2789   if (put != NULL)
2790     {
2791
2792       if (size != NULL)
2793         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2794                     &put->where);
2795
2796       if (array_check (put, 1) == FAILURE)
2797         return FAILURE;
2798
2799       if (rank_check (put, 1, 1) == FAILURE)
2800         return FAILURE;
2801
2802       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2803         return FAILURE;
2804
2805       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2806         return FAILURE;
2807     }
2808
2809   if (get != NULL)
2810     {
2811
2812       if (size != NULL || put != NULL)
2813         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2814                     &get->where);
2815
2816       if (array_check (get, 2) == FAILURE)
2817         return FAILURE;
2818
2819       if (rank_check (get, 2, 1) == FAILURE)
2820         return FAILURE;
2821
2822       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2823         return FAILURE;
2824
2825       if (variable_check (get, 2) == FAILURE)
2826         return FAILURE;
2827
2828       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2829         return FAILURE;
2830     }
2831
2832   return SUCCESS;
2833 }
2834
2835 try
2836 gfc_check_second_sub (gfc_expr * time)
2837 {
2838   if (scalar_check (time, 0) == FAILURE)
2839     return FAILURE;
2840
2841   if (type_check (time, 0, BT_REAL) == FAILURE)
2842     return FAILURE;
2843
2844   if (kind_value_check(time, 0, 4) == FAILURE)
2845     return FAILURE;
2846
2847   return SUCCESS;
2848 }
2849
2850
2851 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2852    count, count_rate, and count_max are all optional arguments */
2853
2854 try
2855 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2856                         gfc_expr * count_max)
2857 {
2858   if (count != NULL)
2859     {
2860       if (scalar_check (count, 0) == FAILURE)
2861         return FAILURE;
2862
2863       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2864         return FAILURE;
2865
2866       if (variable_check (count, 0) == FAILURE)
2867         return FAILURE;
2868     }
2869
2870   if (count_rate != NULL)
2871     {
2872       if (scalar_check (count_rate, 1) == FAILURE)
2873         return FAILURE;
2874
2875       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2876         return FAILURE;
2877
2878       if (variable_check (count_rate, 1) == FAILURE)
2879         return FAILURE;
2880
2881       if (count != NULL
2882           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2883         return FAILURE;
2884
2885     }
2886
2887   if (count_max != NULL)
2888     {
2889       if (scalar_check (count_max, 2) == FAILURE)
2890         return FAILURE;
2891
2892       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2893         return FAILURE;
2894
2895       if (variable_check (count_max, 2) == FAILURE)
2896         return FAILURE;
2897
2898       if (count != NULL
2899           && same_type_check (count, 0, count_max, 2) == FAILURE)
2900         return FAILURE;
2901
2902       if (count_rate != NULL
2903           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2904         return FAILURE;
2905     }
2906
2907   return SUCCESS;
2908 }
2909
2910 try
2911 gfc_check_irand (gfc_expr * x)
2912 {
2913   if (x == NULL)
2914     return SUCCESS;
2915
2916   if (scalar_check (x, 0) == FAILURE)
2917     return FAILURE;
2918
2919   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2920     return FAILURE;
2921
2922   if (kind_value_check(x, 0, 4) == FAILURE)
2923     return FAILURE;
2924
2925   return SUCCESS;
2926 }
2927
2928
2929 try
2930 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2931 {
2932   if (scalar_check (seconds, 0) == FAILURE)
2933     return FAILURE;
2934
2935   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2936     return FAILURE;
2937
2938   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2939     {
2940       gfc_error (
2941         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2942         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2943       return FAILURE;
2944     }
2945
2946   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2947     return FAILURE;
2948
2949   if (status == NULL)
2950     return SUCCESS;
2951
2952   if (scalar_check (status, 2) == FAILURE)
2953     return FAILURE;
2954
2955   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2956     return FAILURE;
2957
2958   return SUCCESS;
2959 }
2960
2961
2962 try
2963 gfc_check_rand (gfc_expr * x)
2964 {
2965   if (x == NULL)
2966     return SUCCESS;
2967
2968   if (scalar_check (x, 0) == FAILURE)
2969     return FAILURE;
2970
2971   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2972     return FAILURE;
2973
2974   if (kind_value_check(x, 0, 4) == FAILURE)
2975     return FAILURE;
2976
2977   return SUCCESS;
2978 }
2979
2980 try
2981 gfc_check_srand (gfc_expr * x)
2982 {
2983   if (scalar_check (x, 0) == FAILURE)
2984     return FAILURE;
2985
2986   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2987     return FAILURE;
2988
2989   if (kind_value_check(x, 0, 4) == FAILURE)
2990     return FAILURE;
2991
2992   return SUCCESS;
2993 }
2994
2995 try
2996 gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
2997 {
2998   if (scalar_check (time, 0) == FAILURE)
2999     return FAILURE;
3000
3001   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3002     return FAILURE;
3003
3004   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3005     return FAILURE;
3006
3007   return SUCCESS;
3008 }
3009
3010 try
3011 gfc_check_etime (gfc_expr * x)
3012 {
3013   if (array_check (x, 0) == FAILURE)
3014     return FAILURE;
3015
3016   if (rank_check (x, 0, 1) == FAILURE)
3017     return FAILURE;
3018
3019   if (variable_check (x, 0) == FAILURE)
3020     return FAILURE;
3021
3022   if (type_check (x, 0, BT_REAL) == FAILURE)
3023     return FAILURE;
3024
3025   if (kind_value_check(x, 0, 4) == FAILURE)
3026     return FAILURE;
3027
3028   return SUCCESS;
3029 }
3030
3031 try
3032 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
3033 {
3034   if (array_check (values, 0) == FAILURE)
3035     return FAILURE;
3036
3037   if (rank_check (values, 0, 1) == FAILURE)
3038     return FAILURE;
3039
3040   if (variable_check (values, 0) == FAILURE)
3041     return FAILURE;
3042
3043   if (type_check (values, 0, BT_REAL) == FAILURE)
3044     return FAILURE;
3045
3046   if (kind_value_check(values, 0, 4) == FAILURE)
3047     return FAILURE;
3048
3049   if (scalar_check (time, 1) == FAILURE)
3050     return FAILURE;
3051
3052   if (type_check (time, 1, BT_REAL) == FAILURE)
3053     return FAILURE;
3054
3055   if (kind_value_check(time, 1, 4) == FAILURE)
3056     return FAILURE;
3057
3058   return SUCCESS;
3059 }
3060
3061
3062 try
3063 gfc_check_fdate_sub (gfc_expr * date)
3064 {
3065   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3066     return FAILURE;
3067
3068   return SUCCESS;
3069 }
3070
3071
3072 try
3073 gfc_check_gerror (gfc_expr * msg)
3074 {
3075   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3076     return FAILURE;
3077
3078   return SUCCESS;
3079 }
3080
3081
3082 try
3083 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
3084 {
3085   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3086     return FAILURE;
3087
3088   if (status == NULL)
3089     return SUCCESS;
3090
3091   if (scalar_check (status, 1) == FAILURE)
3092     return FAILURE;
3093
3094   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3095     return FAILURE;
3096
3097   return SUCCESS;
3098 }
3099
3100
3101 try
3102 gfc_check_getlog (gfc_expr * msg)
3103 {
3104   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3105     return FAILURE;
3106
3107   return SUCCESS;
3108 }
3109
3110
3111 try
3112 gfc_check_exit (gfc_expr * status)
3113 {
3114   if (status == NULL)
3115     return SUCCESS;
3116
3117   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3118     return FAILURE;
3119
3120   if (scalar_check (status, 0) == FAILURE)
3121     return FAILURE;
3122
3123   return SUCCESS;
3124 }
3125
3126
3127 try
3128 gfc_check_flush (gfc_expr * unit)
3129 {
3130   if (unit == NULL)
3131     return SUCCESS;
3132
3133   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3134     return FAILURE;
3135
3136   if (scalar_check (unit, 0) == FAILURE)
3137     return FAILURE;
3138
3139   return SUCCESS;
3140 }
3141
3142
3143 try
3144 gfc_check_free (gfc_expr * i)
3145 {
3146   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3147     return FAILURE;
3148
3149   if (scalar_check (i, 0) == FAILURE)
3150     return FAILURE;
3151
3152   return SUCCESS;
3153 }
3154
3155
3156 try
3157 gfc_check_hostnm (gfc_expr * name)
3158 {
3159   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3160     return FAILURE;
3161
3162   return SUCCESS;
3163 }
3164
3165
3166 try
3167 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
3168 {
3169   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3170     return FAILURE;
3171
3172   if (status == NULL)
3173     return SUCCESS;
3174
3175   if (scalar_check (status, 1) == FAILURE)
3176     return FAILURE;
3177
3178   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3179     return FAILURE;
3180
3181   return SUCCESS;
3182 }
3183
3184
3185 try
3186 gfc_check_itime_idate (gfc_expr * values)
3187 {
3188   if (array_check (values, 0) == FAILURE)
3189     return FAILURE;
3190
3191   if (rank_check (values, 0, 1) == FAILURE)
3192     return FAILURE;
3193
3194   if (variable_check (values, 0) == FAILURE)
3195     return FAILURE;
3196
3197   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3198     return FAILURE;
3199
3200   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3201     return FAILURE;
3202
3203   return SUCCESS;
3204 }
3205
3206
3207 try
3208 gfc_check_ltime_gmtime (gfc_expr * time, gfc_expr * values)
3209 {
3210   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3211     return FAILURE;
3212
3213   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3214     return FAILURE;
3215
3216   if (scalar_check (time, 0) == FAILURE)
3217     return FAILURE;
3218
3219   if (array_check (values, 1) == FAILURE)
3220     return FAILURE;
3221
3222   if (rank_check (values, 1, 1) == FAILURE)
3223     return FAILURE;
3224
3225   if (variable_check (values, 1) == FAILURE)
3226     return FAILURE;
3227
3228   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3229     return FAILURE;
3230
3231   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3232     return FAILURE;
3233
3234   return SUCCESS;
3235 }
3236
3237
3238 try
3239 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
3240 {
3241   if (scalar_check (unit, 0) == FAILURE)
3242     return FAILURE;
3243
3244   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3245     return FAILURE;
3246
3247   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3248     return FAILURE;
3249
3250   return SUCCESS;
3251 }
3252
3253
3254 try
3255 gfc_check_isatty (gfc_expr * unit)
3256 {
3257   if (unit == NULL)
3258     return FAILURE;
3259
3260   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3261     return FAILURE;
3262
3263   if (scalar_check (unit, 0) == FAILURE)
3264     return FAILURE;
3265
3266   return SUCCESS;
3267 }
3268
3269
3270 try
3271 gfc_check_perror (gfc_expr * string)
3272 {
3273   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3274     return FAILURE;
3275
3276   return SUCCESS;
3277 }
3278
3279
3280 try
3281 gfc_check_umask (gfc_expr * mask)
3282 {
3283   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3284     return FAILURE;
3285
3286   if (scalar_check (mask, 0) == FAILURE)
3287     return FAILURE;
3288
3289   return SUCCESS;
3290 }
3291
3292
3293 try
3294 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
3295 {
3296   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3297     return FAILURE;
3298
3299   if (scalar_check (mask, 0) == FAILURE)
3300     return FAILURE;
3301
3302   if (old == NULL)
3303     return SUCCESS;
3304
3305   if (scalar_check (old, 1) == FAILURE)
3306     return FAILURE;
3307
3308   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3309     return FAILURE;
3310
3311   return SUCCESS;
3312 }
3313
3314
3315 try
3316 gfc_check_unlink (gfc_expr * name)
3317 {
3318   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3319     return FAILURE;
3320
3321   return SUCCESS;
3322 }
3323
3324
3325 try
3326 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
3327 {
3328   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3329     return FAILURE;
3330
3331   if (status == NULL)
3332     return SUCCESS;
3333
3334   if (scalar_check (status, 1) == FAILURE)
3335     return FAILURE;
3336
3337   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3338     return FAILURE;
3339
3340   return SUCCESS;
3341 }
3342
3343
3344 try
3345 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
3346 {
3347   if (scalar_check (number, 0) == FAILURE)
3348     return FAILURE;
3349
3350   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3351     return FAILURE;
3352
3353   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3354     {
3355       gfc_error (
3356         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3357         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3358       return FAILURE;
3359     }
3360
3361   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3362     return FAILURE;
3363
3364   return SUCCESS;
3365 }
3366
3367
3368 try
3369 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
3370 {
3371   if (scalar_check (number, 0) == FAILURE)
3372     return FAILURE;
3373
3374   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3375     return FAILURE;
3376
3377   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3378     {
3379       gfc_error (
3380         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3381         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3382       return FAILURE;
3383     }
3384
3385   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3386     return FAILURE;
3387
3388   if (status == NULL)
3389     return SUCCESS;
3390
3391   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3392     return FAILURE;
3393
3394   if (scalar_check (status, 2) == FAILURE)
3395     return FAILURE;
3396
3397   return SUCCESS;
3398 }
3399
3400
3401 try
3402 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
3403 {
3404   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3405     return FAILURE;
3406
3407   if (scalar_check (status, 1) == FAILURE)
3408     return FAILURE;
3409
3410   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3411     return FAILURE;
3412
3413   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3414     return FAILURE;
3415
3416   return SUCCESS;
3417 }
3418
3419
3420 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3421 try
3422 gfc_check_and (gfc_expr * i, gfc_expr * j)
3423 {
3424   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3425     {
3426       gfc_error (
3427         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3428         gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
3429       return FAILURE;
3430     }
3431
3432   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3433     {
3434       gfc_error (
3435         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3436         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
3437       return FAILURE;
3438     }
3439
3440   if (i->ts.type != j->ts.type)
3441     {
3442       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3443                  "have the same type", gfc_current_intrinsic_arg[0],
3444                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3445                  &j->where);
3446       return FAILURE;
3447     }
3448
3449   if (scalar_check (i, 0) == FAILURE)
3450     return FAILURE;
3451
3452   if (scalar_check (j, 1) == FAILURE)
3453     return FAILURE;
3454
3455   return SUCCESS;
3456 }