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