gcc/fortran/check.c

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