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