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