gcc/fortran/check.c

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