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