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