gcc/fortran/check.c

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