gcc/fortran/check.c

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