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