gcc/fortran/check.c

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