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