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   if (size != NULL)
2884     {
2885       if (scalar_check (size, 0) == FAILURE)
2886         return FAILURE;
2887
2888       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2889         return FAILURE;
2890
2891       if (variable_check (size, 0) == FAILURE)
2892         return FAILURE;
2893
2894       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2895         return FAILURE;
2896     }
2897
2898   if (put != NULL)
2899     {
2900
2901       if (size != NULL)
2902         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2903                     &put->where);
2904
2905       if (array_check (put, 1) == FAILURE)
2906         return FAILURE;
2907
2908       if (rank_check (put, 1, 1) == FAILURE)
2909         return FAILURE;
2910
2911       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2912         return FAILURE;
2913
2914       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2915         return FAILURE;
2916     }
2917
2918   if (get != NULL)
2919     {
2920
2921       if (size != NULL || put != NULL)
2922         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2923                    &get->where);
2924
2925       if (array_check (get, 2) == FAILURE)
2926         return FAILURE;
2927
2928       if (rank_check (get, 2, 1) == FAILURE)
2929         return FAILURE;
2930
2931       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2932         return FAILURE;
2933
2934       if (variable_check (get, 2) == FAILURE)
2935         return FAILURE;
2936
2937       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2938         return FAILURE;
2939     }
2940
2941   return SUCCESS;
2942 }
2943
2944
2945 try
2946 gfc_check_second_sub (gfc_expr *time)
2947 {
2948   if (scalar_check (time, 0) == FAILURE)
2949     return FAILURE;
2950
2951   if (type_check (time, 0, BT_REAL) == FAILURE)
2952     return FAILURE;
2953
2954   if (kind_value_check(time, 0, 4) == FAILURE)
2955     return FAILURE;
2956
2957   return SUCCESS;
2958 }
2959
2960
2961 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2962    count, count_rate, and count_max are all optional arguments */
2963
2964 try
2965 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
2966                         gfc_expr *count_max)
2967 {
2968   if (count != NULL)
2969     {
2970       if (scalar_check (count, 0) == FAILURE)
2971         return FAILURE;
2972
2973       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2974         return FAILURE;
2975
2976       if (variable_check (count, 0) == FAILURE)
2977         return FAILURE;
2978     }
2979
2980   if (count_rate != NULL)
2981     {
2982       if (scalar_check (count_rate, 1) == FAILURE)
2983         return FAILURE;
2984
2985       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2986         return FAILURE;
2987
2988       if (variable_check (count_rate, 1) == FAILURE)
2989         return FAILURE;
2990
2991       if (count != NULL
2992           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2993         return FAILURE;
2994
2995     }
2996
2997   if (count_max != NULL)
2998     {
2999       if (scalar_check (count_max, 2) == FAILURE)
3000         return FAILURE;
3001
3002       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3003         return FAILURE;
3004
3005       if (variable_check (count_max, 2) == FAILURE)
3006         return FAILURE;
3007
3008       if (count != NULL
3009           && same_type_check (count, 0, count_max, 2) == FAILURE)
3010         return FAILURE;
3011
3012       if (count_rate != NULL
3013           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3014         return FAILURE;
3015     }
3016
3017   return SUCCESS;
3018 }
3019
3020
3021 try
3022 gfc_check_irand (gfc_expr *x)
3023 {
3024   if (x == NULL)
3025     return SUCCESS;
3026
3027   if (scalar_check (x, 0) == FAILURE)
3028     return FAILURE;
3029
3030   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3031     return FAILURE;
3032
3033   if (kind_value_check(x, 0, 4) == FAILURE)
3034     return FAILURE;
3035
3036   return SUCCESS;
3037 }
3038
3039
3040 try
3041 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3042 {
3043   if (scalar_check (seconds, 0) == FAILURE)
3044     return FAILURE;
3045
3046   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3047     return FAILURE;
3048
3049   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3050     {
3051       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3052                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3053                  gfc_current_intrinsic, &handler->where);
3054       return FAILURE;
3055     }
3056
3057   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3058     return FAILURE;
3059
3060   if (status == NULL)
3061     return SUCCESS;
3062
3063   if (scalar_check (status, 2) == FAILURE)
3064     return FAILURE;
3065
3066   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3067     return FAILURE;
3068
3069   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3070     return FAILURE;
3071
3072   return SUCCESS;
3073 }
3074
3075
3076 try
3077 gfc_check_rand (gfc_expr *x)
3078 {
3079   if (x == NULL)
3080     return SUCCESS;
3081
3082   if (scalar_check (x, 0) == FAILURE)
3083     return FAILURE;
3084
3085   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3086     return FAILURE;
3087
3088   if (kind_value_check(x, 0, 4) == FAILURE)
3089     return FAILURE;
3090
3091   return SUCCESS;
3092 }
3093
3094
3095 try
3096 gfc_check_srand (gfc_expr *x)
3097 {
3098   if (scalar_check (x, 0) == FAILURE)
3099     return FAILURE;
3100
3101   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3102     return FAILURE;
3103
3104   if (kind_value_check(x, 0, 4) == FAILURE)
3105     return FAILURE;
3106
3107   return SUCCESS;
3108 }
3109
3110
3111 try
3112 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3113 {
3114   if (scalar_check (time, 0) == FAILURE)
3115     return FAILURE;
3116
3117   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3118     return FAILURE;
3119
3120   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3121     return FAILURE;
3122
3123   return SUCCESS;
3124 }
3125
3126
3127 try
3128 gfc_check_etime (gfc_expr *x)
3129 {
3130   if (array_check (x, 0) == FAILURE)
3131     return FAILURE;
3132
3133   if (rank_check (x, 0, 1) == FAILURE)
3134     return FAILURE;
3135
3136   if (variable_check (x, 0) == FAILURE)
3137     return FAILURE;
3138
3139   if (type_check (x, 0, BT_REAL) == FAILURE)
3140     return FAILURE;
3141
3142   if (kind_value_check(x, 0, 4) == FAILURE)
3143     return FAILURE;
3144
3145   return SUCCESS;
3146 }
3147
3148
3149 try
3150 gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
3151 {
3152   if (array_check (values, 0) == FAILURE)
3153     return FAILURE;
3154
3155   if (rank_check (values, 0, 1) == FAILURE)
3156     return FAILURE;
3157
3158   if (variable_check (values, 0) == FAILURE)
3159     return FAILURE;
3160
3161   if (type_check (values, 0, BT_REAL) == FAILURE)
3162     return FAILURE;
3163
3164   if (kind_value_check(values, 0, 4) == FAILURE)
3165     return FAILURE;
3166
3167   if (scalar_check (time, 1) == FAILURE)
3168     return FAILURE;
3169
3170   if (type_check (time, 1, BT_REAL) == FAILURE)
3171     return FAILURE;
3172
3173   if (kind_value_check(time, 1, 4) == FAILURE)
3174     return FAILURE;
3175
3176   return SUCCESS;
3177 }
3178
3179
3180 try
3181 gfc_check_fdate_sub (gfc_expr *date)
3182 {
3183   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3184     return FAILURE;
3185
3186   return SUCCESS;
3187 }
3188
3189
3190 try
3191 gfc_check_gerror (gfc_expr *msg)
3192 {
3193   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3194     return FAILURE;
3195
3196   return SUCCESS;
3197 }
3198
3199
3200 try
3201 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3202 {
3203   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3204     return FAILURE;
3205
3206   if (status == NULL)
3207     return SUCCESS;
3208
3209   if (scalar_check (status, 1) == FAILURE)
3210     return FAILURE;
3211
3212   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3213     return FAILURE;
3214
3215   return SUCCESS;
3216 }
3217
3218
3219 try
3220 gfc_check_getlog (gfc_expr *msg)
3221 {
3222   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3223     return FAILURE;
3224
3225   return SUCCESS;
3226 }
3227
3228
3229 try
3230 gfc_check_exit (gfc_expr *status)
3231 {
3232   if (status == NULL)
3233     return SUCCESS;
3234
3235   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3236     return FAILURE;
3237
3238   if (scalar_check (status, 0) == FAILURE)
3239     return FAILURE;
3240
3241   return SUCCESS;
3242 }
3243
3244
3245 try
3246 gfc_check_flush (gfc_expr *unit)
3247 {
3248   if (unit == NULL)
3249     return SUCCESS;
3250
3251   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3252     return FAILURE;
3253
3254   if (scalar_check (unit, 0) == FAILURE)
3255     return FAILURE;
3256
3257   return SUCCESS;
3258 }
3259
3260
3261 try
3262 gfc_check_free (gfc_expr *i)
3263 {
3264   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3265     return FAILURE;
3266
3267   if (scalar_check (i, 0) == FAILURE)
3268     return FAILURE;
3269
3270   return SUCCESS;
3271 }
3272
3273
3274 try
3275 gfc_check_hostnm (gfc_expr *name)
3276 {
3277   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3278     return FAILURE;
3279
3280   return SUCCESS;
3281 }
3282
3283
3284 try
3285 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3286 {
3287   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3288     return FAILURE;
3289
3290   if (status == NULL)
3291     return SUCCESS;
3292
3293   if (scalar_check (status, 1) == FAILURE)
3294     return FAILURE;
3295
3296   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3297     return FAILURE;
3298
3299   return SUCCESS;
3300 }
3301
3302
3303 try
3304 gfc_check_itime_idate (gfc_expr *values)
3305 {
3306   if (array_check (values, 0) == FAILURE)
3307     return FAILURE;
3308
3309   if (rank_check (values, 0, 1) == FAILURE)
3310     return FAILURE;
3311
3312   if (variable_check (values, 0) == FAILURE)
3313     return FAILURE;
3314
3315   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3316     return FAILURE;
3317
3318   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3319     return FAILURE;
3320
3321   return SUCCESS;
3322 }
3323
3324
3325 try
3326 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3327 {
3328   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3329     return FAILURE;
3330
3331   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3332     return FAILURE;
3333
3334   if (scalar_check (time, 0) == FAILURE)
3335     return FAILURE;
3336
3337   if (array_check (values, 1) == FAILURE)
3338     return FAILURE;
3339
3340   if (rank_check (values, 1, 1) == FAILURE)
3341     return FAILURE;
3342
3343   if (variable_check (values, 1) == FAILURE)
3344     return FAILURE;
3345
3346   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3347     return FAILURE;
3348
3349   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3350     return FAILURE;
3351
3352   return SUCCESS;
3353 }
3354
3355
3356 try
3357 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3358 {
3359   if (scalar_check (unit, 0) == FAILURE)
3360     return FAILURE;
3361
3362   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3363     return FAILURE;
3364
3365   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3366     return FAILURE;
3367
3368   return SUCCESS;
3369 }
3370
3371
3372 try
3373 gfc_check_isatty (gfc_expr *unit)
3374 {
3375   if (unit == NULL)
3376     return FAILURE;
3377
3378   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3379     return FAILURE;
3380
3381   if (scalar_check (unit, 0) == FAILURE)
3382     return FAILURE;
3383
3384   return SUCCESS;
3385 }
3386
3387
3388 try
3389 gfc_check_isnan (gfc_expr *x)
3390 {
3391   if (type_check (x, 0, BT_REAL) == FAILURE)
3392     return FAILURE;
3393
3394   return SUCCESS;
3395 }
3396
3397
3398 try
3399 gfc_check_perror (gfc_expr *string)
3400 {
3401   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3402     return FAILURE;
3403
3404   return SUCCESS;
3405 }
3406
3407
3408 try
3409 gfc_check_umask (gfc_expr *mask)
3410 {
3411   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3412     return FAILURE;
3413
3414   if (scalar_check (mask, 0) == FAILURE)
3415     return FAILURE;
3416
3417   return SUCCESS;
3418 }
3419
3420
3421 try
3422 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3423 {
3424   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3425     return FAILURE;
3426
3427   if (scalar_check (mask, 0) == FAILURE)
3428     return FAILURE;
3429
3430   if (old == NULL)
3431     return SUCCESS;
3432
3433   if (scalar_check (old, 1) == FAILURE)
3434     return FAILURE;
3435
3436   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3437     return FAILURE;
3438
3439   return SUCCESS;
3440 }
3441
3442
3443 try
3444 gfc_check_unlink (gfc_expr *name)
3445 {
3446   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3447     return FAILURE;
3448
3449   return SUCCESS;
3450 }
3451
3452
3453 try
3454 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3455 {
3456   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3457     return FAILURE;
3458
3459   if (status == NULL)
3460     return SUCCESS;
3461
3462   if (scalar_check (status, 1) == FAILURE)
3463     return FAILURE;
3464
3465   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3466     return FAILURE;
3467
3468   return SUCCESS;
3469 }
3470
3471
3472 try
3473 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3474 {
3475   if (scalar_check (number, 0) == FAILURE)
3476     return FAILURE;
3477
3478   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3479     return FAILURE;
3480
3481   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3482     {
3483       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3484                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3485                  gfc_current_intrinsic, &handler->where);
3486       return FAILURE;
3487     }
3488
3489   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3490     return FAILURE;
3491
3492   return SUCCESS;
3493 }
3494
3495
3496 try
3497 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3498 {
3499   if (scalar_check (number, 0) == FAILURE)
3500     return FAILURE;
3501
3502   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3503     return FAILURE;
3504
3505   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3506     {
3507       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3508                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3509                  gfc_current_intrinsic, &handler->where);
3510       return FAILURE;
3511     }
3512
3513   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3514     return FAILURE;
3515
3516   if (status == NULL)
3517     return SUCCESS;
3518
3519   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3520     return FAILURE;
3521
3522   if (scalar_check (status, 2) == FAILURE)
3523     return FAILURE;
3524
3525   return SUCCESS;
3526 }
3527
3528
3529 try
3530 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3531 {
3532   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3533     return FAILURE;
3534
3535   if (scalar_check (status, 1) == FAILURE)
3536     return FAILURE;
3537
3538   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3539     return FAILURE;
3540
3541   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3542     return FAILURE;
3543
3544   return SUCCESS;
3545 }
3546
3547
3548 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3549 try
3550 gfc_check_and (gfc_expr *i, gfc_expr *j)
3551 {
3552   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3553     {
3554       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3555                  "or LOGICAL", gfc_current_intrinsic_arg[0],
3556                  gfc_current_intrinsic, &i->where);
3557       return FAILURE;
3558     }
3559
3560   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3561     {
3562       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3563                  "or LOGICAL", gfc_current_intrinsic_arg[1],
3564                  gfc_current_intrinsic, &j->where);
3565       return FAILURE;
3566     }
3567
3568   if (i->ts.type != j->ts.type)
3569     {
3570       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3571                  "have the same type", gfc_current_intrinsic_arg[0],
3572                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3573                  &j->where);
3574       return FAILURE;
3575     }
3576
3577   if (scalar_check (i, 0) == FAILURE)
3578     return FAILURE;
3579
3580   if (scalar_check (j, 1) == FAILURE)
3581     return FAILURE;
3582
3583   return SUCCESS;
3584 }