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 /* For IANY, IALL and IPARITY.  */
2357
2358 gfc_try
2359 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
2360 {
2361   if (ap->expr->ts.type != BT_INTEGER)
2362     {
2363       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2364                  gfc_current_intrinsic_arg[0]->name,
2365                  gfc_current_intrinsic, &ap->expr->where);
2366       return FAILURE;
2367     }
2368
2369   if (array_check (ap->expr, 0) == FAILURE)
2370     return FAILURE;
2371
2372   return check_reduction (ap);
2373 }
2374
2375
2376 gfc_try
2377 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2378 {
2379   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2380     return FAILURE;
2381
2382   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2383     return FAILURE;
2384
2385   if (tsource->ts.type == BT_CHARACTER)
2386     return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2387
2388   return SUCCESS;
2389 }
2390
2391
2392 gfc_try
2393 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2394 {
2395   if (variable_check (from, 0) == FAILURE)
2396     return FAILURE;
2397   if (allocatable_check (from, 0) == FAILURE)
2398     return FAILURE;
2399
2400   if (variable_check (to, 1) == FAILURE)
2401     return FAILURE;
2402   if (allocatable_check (to, 1) == FAILURE)
2403     return FAILURE;
2404
2405   if (same_type_check (to, 1, from, 0) == FAILURE)
2406     return FAILURE;
2407
2408   if (to->rank != from->rank)
2409     {
2410       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2411                  "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
2412                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2413                  &to->where,  from->rank, to->rank);
2414       return FAILURE;
2415     }
2416
2417   if (to->ts.kind != from->ts.kind)
2418     {
2419       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
2420                  "be of the same kind %d/%d",
2421                  gfc_current_intrinsic_arg[0]->name,
2422                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2423                  &to->where, from->ts.kind, to->ts.kind);
2424       return FAILURE;
2425     }
2426
2427   return SUCCESS;
2428 }
2429
2430
2431 gfc_try
2432 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2433 {
2434   if (type_check (x, 0, BT_REAL) == FAILURE)
2435     return FAILURE;
2436
2437   if (type_check (s, 1, BT_REAL) == FAILURE)
2438     return FAILURE;
2439
2440   return SUCCESS;
2441 }
2442
2443
2444 gfc_try
2445 gfc_check_new_line (gfc_expr *a)
2446 {
2447   if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2448     return FAILURE;
2449
2450   return SUCCESS;
2451 }
2452
2453
2454 gfc_try
2455 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
2456 {
2457   if (type_check (array, 0, BT_REAL) == FAILURE)
2458     return FAILURE;
2459
2460   if (array_check (array, 0) == FAILURE)
2461     return FAILURE;
2462
2463   if (dim_rank_check (dim, array, false) == FAILURE)
2464     return FAILURE;
2465
2466   return SUCCESS;
2467 }
2468
2469 gfc_try
2470 gfc_check_null (gfc_expr *mold)
2471 {
2472   symbol_attribute attr;
2473
2474   if (mold == NULL)
2475     return SUCCESS;
2476
2477   if (variable_check (mold, 0) == FAILURE)
2478     return FAILURE;
2479
2480   attr = gfc_variable_attr (mold, NULL);
2481
2482   if (!attr.pointer && !attr.proc_pointer)
2483     {
2484       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2485                  gfc_current_intrinsic_arg[0]->name,
2486                  gfc_current_intrinsic, &mold->where);
2487       return FAILURE;
2488     }
2489
2490   return SUCCESS;
2491 }
2492
2493
2494 gfc_try
2495 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2496 {
2497   if (array_check (array, 0) == FAILURE)
2498     return FAILURE;
2499
2500   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2501     return FAILURE;
2502
2503   if (gfc_check_conformance (array, mask,
2504                              "arguments '%s' and '%s' for intrinsic '%s'",
2505                              gfc_current_intrinsic_arg[0]->name,
2506                              gfc_current_intrinsic_arg[1]->name,
2507                              gfc_current_intrinsic) == FAILURE)
2508     return FAILURE;
2509
2510   if (vector != NULL)
2511     {
2512       mpz_t array_size, vector_size;
2513       bool have_array_size, have_vector_size;
2514
2515       if (same_type_check (array, 0, vector, 2) == FAILURE)
2516         return FAILURE;
2517
2518       if (rank_check (vector, 2, 1) == FAILURE)
2519         return FAILURE;
2520
2521       /* VECTOR requires at least as many elements as MASK
2522          has .TRUE. values.  */
2523       have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2524       have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2525
2526       if (have_vector_size
2527           && (mask->expr_type == EXPR_ARRAY
2528               || (mask->expr_type == EXPR_CONSTANT
2529                   && have_array_size)))
2530         {
2531           int mask_true_values = 0;
2532
2533           if (mask->expr_type == EXPR_ARRAY)
2534             {
2535               gfc_constructor *mask_ctor;
2536               mask_ctor = gfc_constructor_first (mask->value.constructor);
2537               while (mask_ctor)
2538                 {
2539                   if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2540                     {
2541                       mask_true_values = 0;
2542                       break;
2543                     }
2544
2545                   if (mask_ctor->expr->value.logical)
2546                     mask_true_values++;
2547
2548                   mask_ctor = gfc_constructor_next (mask_ctor);
2549                 }
2550             }
2551           else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2552             mask_true_values = mpz_get_si (array_size);
2553
2554           if (mpz_get_si (vector_size) < mask_true_values)
2555             {
2556               gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2557                          "provide at least as many elements as there "
2558                          "are .TRUE. values in '%s' (%ld/%d)",
2559                          gfc_current_intrinsic_arg[2]->name,
2560                          gfc_current_intrinsic, &vector->where,
2561                          gfc_current_intrinsic_arg[1]->name,
2562                          mpz_get_si (vector_size), mask_true_values);
2563               return FAILURE;
2564             }
2565         }
2566
2567       if (have_array_size)
2568         mpz_clear (array_size);
2569       if (have_vector_size)
2570         mpz_clear (vector_size);
2571     }
2572
2573   return SUCCESS;
2574 }
2575
2576
2577 gfc_try
2578 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
2579 {
2580   if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
2581     return FAILURE;
2582
2583   if (array_check (mask, 0) == FAILURE)
2584     return FAILURE;
2585
2586   if (dim_rank_check (dim, mask, false) == FAILURE)
2587     return FAILURE;
2588
2589   return SUCCESS;
2590 }
2591
2592
2593 gfc_try
2594 gfc_check_precision (gfc_expr *x)
2595 {
2596   if (real_or_complex_check (x, 0) == FAILURE)
2597     return FAILURE;
2598
2599   return SUCCESS;
2600 }
2601
2602
2603 gfc_try
2604 gfc_check_present (gfc_expr *a)
2605 {
2606   gfc_symbol *sym;
2607
2608   if (variable_check (a, 0) == FAILURE)
2609     return FAILURE;
2610
2611   sym = a->symtree->n.sym;
2612   if (!sym->attr.dummy)
2613     {
2614       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2615                  "dummy variable", gfc_current_intrinsic_arg[0]->name,
2616                  gfc_current_intrinsic, &a->where);
2617       return FAILURE;
2618     }
2619
2620   if (!sym->attr.optional)
2621     {
2622       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2623                  "an OPTIONAL dummy variable",
2624                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2625                  &a->where);
2626       return FAILURE;
2627     }
2628
2629   /* 13.14.82  PRESENT(A)
2630      ......
2631      Argument.  A shall be the name of an optional dummy argument that is
2632      accessible in the subprogram in which the PRESENT function reference
2633      appears...  */
2634
2635   if (a->ref != NULL
2636       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2637            && a->ref->u.ar.type == AR_FULL))
2638     {
2639       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2640                  "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
2641                  gfc_current_intrinsic, &a->where, sym->name);
2642       return FAILURE;
2643     }
2644
2645   return SUCCESS;
2646 }
2647
2648
2649 gfc_try
2650 gfc_check_radix (gfc_expr *x)
2651 {
2652   if (int_or_real_check (x, 0) == FAILURE)
2653     return FAILURE;
2654
2655   return SUCCESS;
2656 }
2657
2658
2659 gfc_try
2660 gfc_check_range (gfc_expr *x)
2661 {
2662   if (numeric_check (x, 0) == FAILURE)
2663     return FAILURE;
2664
2665   return SUCCESS;
2666 }
2667
2668
2669 /* real, float, sngl.  */
2670 gfc_try
2671 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2672 {
2673   if (numeric_check (a, 0) == FAILURE)
2674     return FAILURE;
2675
2676   if (kind_check (kind, 1, BT_REAL) == FAILURE)
2677     return FAILURE;
2678
2679   return SUCCESS;
2680 }
2681
2682
2683 gfc_try
2684 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2685 {
2686   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2687     return FAILURE;
2688   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2689     return FAILURE;
2690
2691   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2692     return FAILURE;
2693   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2694     return FAILURE;
2695
2696   return SUCCESS;
2697 }
2698
2699
2700 gfc_try
2701 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2702 {
2703   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2704     return FAILURE;
2705   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2706     return FAILURE;
2707
2708   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2709     return FAILURE;
2710   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2711     return FAILURE;
2712
2713   if (status == NULL)
2714     return SUCCESS;
2715
2716   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2717     return FAILURE;
2718
2719   if (scalar_check (status, 2) == FAILURE)
2720     return FAILURE;
2721
2722   return SUCCESS;
2723 }
2724
2725
2726 gfc_try
2727 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2728 {
2729   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2730     return FAILURE;
2731
2732   if (scalar_check (x, 0) == FAILURE)
2733     return FAILURE;
2734
2735   if (type_check (y, 0, BT_INTEGER) == FAILURE)
2736     return FAILURE;
2737
2738   if (scalar_check (y, 1) == FAILURE)
2739     return FAILURE;
2740
2741   return SUCCESS;
2742 }
2743
2744
2745 gfc_try
2746 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2747                    gfc_expr *pad, gfc_expr *order)
2748 {
2749   mpz_t size;
2750   mpz_t nelems;
2751   int shape_size;
2752
2753   if (array_check (source, 0) == FAILURE)
2754     return FAILURE;
2755
2756   if (rank_check (shape, 1, 1) == FAILURE)
2757     return FAILURE;
2758
2759   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2760     return FAILURE;
2761
2762   if (gfc_array_size (shape, &size) != SUCCESS)
2763     {
2764       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2765                  "array of constant size", &shape->where);
2766       return FAILURE;
2767     }
2768
2769   shape_size = mpz_get_ui (size);
2770   mpz_clear (size);
2771
2772   if (shape_size <= 0)
2773     {
2774       gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
2775                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2776                  &shape->where);
2777       return FAILURE;
2778     }
2779   else if (shape_size > GFC_MAX_DIMENSIONS)
2780     {
2781       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2782                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2783       return FAILURE;
2784     }
2785   else if (shape->expr_type == EXPR_ARRAY)
2786     {
2787       gfc_expr *e;
2788       int i, extent;
2789       for (i = 0; i < shape_size; ++i)
2790         {
2791           e = gfc_constructor_lookup_expr (shape->value.constructor, i);
2792           if (e->expr_type != EXPR_CONSTANT)
2793             continue;
2794
2795           gfc_extract_int (e, &extent);
2796           if (extent < 0)
2797             {
2798               gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2799                          "negative element (%d)",
2800                          gfc_current_intrinsic_arg[1]->name,
2801                          gfc_current_intrinsic, &e->where, extent);
2802               return FAILURE;
2803             }
2804         }
2805     }
2806
2807   if (pad != NULL)
2808     {
2809       if (same_type_check (source, 0, pad, 2) == FAILURE)
2810         return FAILURE;
2811
2812       if (array_check (pad, 2) == FAILURE)
2813         return FAILURE;
2814     }
2815
2816   if (order != NULL)
2817     {
2818       if (array_check (order, 3) == FAILURE)
2819         return FAILURE;
2820
2821       if (type_check (order, 3, BT_INTEGER) == FAILURE)
2822         return FAILURE;
2823
2824       if (order->expr_type == EXPR_ARRAY)
2825         {
2826           int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
2827           gfc_expr *e;
2828
2829           for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
2830             perm[i] = 0;
2831
2832           gfc_array_size (order, &size);
2833           order_size = mpz_get_ui (size);
2834           mpz_clear (size);
2835
2836           if (order_size != shape_size)
2837             {
2838               gfc_error ("'%s' argument of '%s' intrinsic at %L "
2839                          "has wrong number of elements (%d/%d)",
2840                          gfc_current_intrinsic_arg[3]->name,
2841                          gfc_current_intrinsic, &order->where,
2842                          order_size, shape_size);
2843               return FAILURE;
2844             }
2845
2846           for (i = 1; i <= order_size; ++i)
2847             {
2848               e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
2849               if (e->expr_type != EXPR_CONSTANT)
2850                 continue;
2851
2852               gfc_extract_int (e, &dim);
2853
2854               if (dim < 1 || dim > order_size)
2855                 {
2856                   gfc_error ("'%s' argument of '%s' intrinsic at %L "
2857                              "has out-of-range dimension (%d)",
2858                              gfc_current_intrinsic_arg[3]->name,
2859                              gfc_current_intrinsic, &e->where, dim);
2860                   return FAILURE;
2861                 }
2862
2863               if (perm[dim-1] != 0)
2864                 {
2865                   gfc_error ("'%s' argument of '%s' intrinsic at %L has "
2866                              "invalid permutation of dimensions (dimension "
2867                              "'%d' duplicated)",
2868                              gfc_current_intrinsic_arg[3]->name,
2869                              gfc_current_intrinsic, &e->where, dim);
2870                   return FAILURE;
2871                 }
2872
2873               perm[dim-1] = 1;
2874             }
2875         }
2876     }
2877
2878   if (pad == NULL && shape->expr_type == EXPR_ARRAY
2879       && gfc_is_constant_expr (shape)
2880       && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2881            && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2882     {
2883       /* Check the match in size between source and destination.  */
2884       if (gfc_array_size (source, &nelems) == SUCCESS)
2885         {
2886           gfc_constructor *c;
2887           bool test;
2888
2889
2890           mpz_init_set_ui (size, 1);
2891           for (c = gfc_constructor_first (shape->value.constructor);
2892                c; c = gfc_constructor_next (c))
2893             mpz_mul (size, size, c->expr->value.integer);
2894
2895           test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2896           mpz_clear (nelems);
2897           mpz_clear (size);
2898
2899           if (test)
2900             {
2901               gfc_error ("Without padding, there are not enough elements "
2902                          "in the intrinsic RESHAPE source at %L to match "
2903                          "the shape", &source->where);
2904               return FAILURE;
2905             }
2906         }
2907     }
2908
2909   return SUCCESS;
2910 }
2911
2912
2913 gfc_try
2914 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
2915 {
2916
2917   if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
2918     {
2919       gfc_error ("'%s' argument of '%s' intrinsic at %L "
2920                  "must be of a derived type",
2921                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2922                  &a->where);
2923       return FAILURE;
2924     }
2925
2926   if (!gfc_type_is_extensible (a->ts.u.derived))
2927     {
2928       gfc_error ("'%s' argument of '%s' intrinsic at %L "
2929                  "must be of an extensible type",
2930                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2931                  &a->where);
2932       return FAILURE;
2933     }
2934
2935   if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
2936     {
2937       gfc_error ("'%s' argument of '%s' intrinsic at %L "
2938                  "must be of a derived type",
2939                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2940                  &b->where);
2941       return FAILURE;
2942     }
2943
2944   if (!gfc_type_is_extensible (b->ts.u.derived))
2945     {
2946       gfc_error ("'%s' argument of '%s' intrinsic at %L "
2947                  "must be of an extensible type",
2948                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2949                  &b->where);
2950       return FAILURE;
2951     }
2952
2953   return SUCCESS;
2954 }
2955
2956
2957 gfc_try
2958 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2959 {
2960   if (type_check (x, 0, BT_REAL) == FAILURE)
2961     return FAILURE;
2962
2963   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2964     return FAILURE;
2965
2966   return SUCCESS;
2967 }
2968
2969
2970 gfc_try
2971 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2972 {
2973   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2974     return FAILURE;
2975
2976   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2977     return FAILURE;
2978
2979   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2980     return FAILURE;
2981
2982   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2983     return FAILURE;
2984   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2985                               "with KIND argument at %L",
2986                               gfc_current_intrinsic, &kind->where) == FAILURE)
2987     return FAILURE;
2988
2989   if (same_type_check (x, 0, y, 1) == FAILURE)
2990     return FAILURE;
2991
2992   return SUCCESS;
2993 }
2994
2995
2996 gfc_try
2997 gfc_check_secnds (gfc_expr *r)
2998 {
2999   if (type_check (r, 0, BT_REAL) == FAILURE)
3000     return FAILURE;
3001
3002   if (kind_value_check (r, 0, 4) == FAILURE)
3003     return FAILURE;
3004
3005   if (scalar_check (r, 0) == FAILURE)
3006     return FAILURE;
3007
3008   return SUCCESS;
3009 }
3010
3011
3012 gfc_try
3013 gfc_check_selected_char_kind (gfc_expr *name)
3014 {
3015   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3016     return FAILURE;
3017
3018   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3019     return FAILURE;
3020
3021   if (scalar_check (name, 0) == FAILURE)
3022     return FAILURE;
3023
3024   return SUCCESS;
3025 }
3026
3027
3028 gfc_try
3029 gfc_check_selected_int_kind (gfc_expr *r)
3030 {
3031   if (type_check (r, 0, BT_INTEGER) == FAILURE)
3032     return FAILURE;
3033
3034   if (scalar_check (r, 0) == FAILURE)
3035     return FAILURE;
3036
3037   return SUCCESS;
3038 }
3039
3040
3041 gfc_try
3042 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
3043 {
3044   if (p == NULL && r == NULL
3045       && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
3046                          " neither 'P' nor 'R' argument at %L",
3047                          gfc_current_intrinsic_where) == FAILURE)
3048     return FAILURE;
3049
3050   if (p)
3051     {
3052       if (type_check (p, 0, BT_INTEGER) == FAILURE)
3053         return FAILURE;
3054
3055       if (scalar_check (p, 0) == FAILURE)
3056         return FAILURE;
3057     }
3058
3059   if (r)
3060     {
3061       if (type_check (r, 1, BT_INTEGER) == FAILURE)
3062         return FAILURE;
3063
3064       if (scalar_check (r, 1) == FAILURE)
3065         return FAILURE;
3066     }
3067
3068   if (radix)
3069     {
3070       if (type_check (radix, 1, BT_INTEGER) == FAILURE)
3071         return FAILURE;
3072
3073       if (scalar_check (radix, 1) == FAILURE)
3074         return FAILURE;
3075
3076       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
3077                           "RADIX argument at %L", gfc_current_intrinsic,
3078                           &radix->where) == FAILURE)
3079         return FAILURE;
3080     }
3081
3082   return SUCCESS;
3083 }
3084
3085
3086 gfc_try
3087 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
3088 {
3089   if (type_check (x, 0, BT_REAL) == FAILURE)
3090     return FAILURE;
3091
3092   if (type_check (i, 1, BT_INTEGER) == FAILURE)
3093     return FAILURE;
3094
3095   return SUCCESS;
3096 }
3097
3098
3099 gfc_try
3100 gfc_check_shape (gfc_expr *source)
3101 {
3102   gfc_array_ref *ar;
3103
3104   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3105     return SUCCESS;
3106
3107   ar = gfc_find_array_ref (source);
3108
3109   if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
3110     {
3111       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3112                  "an assumed size array", &source->where);
3113       return FAILURE;
3114     }
3115
3116   return SUCCESS;
3117 }
3118
3119
3120 gfc_try
3121 gfc_check_sign (gfc_expr *a, gfc_expr *b)
3122 {
3123   if (int_or_real_check (a, 0) == FAILURE)
3124     return FAILURE;
3125
3126   if (same_type_check (a, 0, b, 1) == FAILURE)
3127     return FAILURE;
3128
3129   return SUCCESS;
3130 }
3131
3132
3133 gfc_try
3134 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3135 {
3136   if (array_check (array, 0) == FAILURE)
3137     return FAILURE;
3138
3139   if (dim_check (dim, 1, true) == FAILURE)
3140     return FAILURE;
3141
3142   if (dim_rank_check (dim, array, 0) == FAILURE)
3143     return FAILURE;
3144
3145   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3146     return FAILURE;
3147   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3148                               "with KIND argument at %L",
3149                               gfc_current_intrinsic, &kind->where) == FAILURE)
3150     return FAILURE;
3151
3152
3153   return SUCCESS;
3154 }
3155
3156
3157 gfc_try
3158 gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
3159 {
3160   return SUCCESS;
3161 }
3162
3163
3164 gfc_try
3165 gfc_check_c_sizeof (gfc_expr *arg)
3166 {
3167   if (verify_c_interop (&arg->ts) != SUCCESS)
3168     {
3169       gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an "
3170                  "interoperable data entity",
3171                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3172                  &arg->where);
3173       return FAILURE;
3174     }
3175   return SUCCESS;
3176 }
3177
3178
3179 gfc_try
3180 gfc_check_sleep_sub (gfc_expr *seconds)
3181 {
3182   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3183     return FAILURE;
3184
3185   if (scalar_check (seconds, 0) == FAILURE)
3186     return FAILURE;
3187
3188   return SUCCESS;
3189 }
3190
3191 gfc_try
3192 gfc_check_sngl (gfc_expr *a)
3193 {
3194   if (type_check (a, 0, BT_REAL) == FAILURE)
3195     return FAILURE;
3196
3197   if ((a->ts.kind != gfc_default_double_kind)
3198       && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision"
3199                          "REAL argument to %s intrinsic at %L",
3200                          gfc_current_intrinsic, &a->where) == FAILURE)
3201     return FAILURE;
3202
3203   return SUCCESS;
3204 }
3205
3206 gfc_try
3207 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
3208 {
3209   if (source->rank >= GFC_MAX_DIMENSIONS)
3210     {
3211       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3212                  "than rank %d", gfc_current_intrinsic_arg[0]->name,
3213                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
3214
3215       return FAILURE;
3216     }
3217
3218   if (dim == NULL)
3219     return FAILURE;
3220
3221   if (dim_check (dim, 1, false) == FAILURE)
3222     return FAILURE;
3223
3224   /* dim_rank_check() does not apply here.  */
3225   if (dim
3226       && dim->expr_type == EXPR_CONSTANT
3227       && (mpz_cmp_ui (dim->value.integer, 1) < 0
3228           || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
3229     {
3230       gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3231                  "dimension index", gfc_current_intrinsic_arg[1]->name,
3232                  gfc_current_intrinsic, &dim->where);
3233       return FAILURE;
3234     }
3235
3236   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
3237     return FAILURE;
3238
3239   if (scalar_check (ncopies, 2) == FAILURE)
3240     return FAILURE;
3241
3242   return SUCCESS;
3243 }
3244
3245
3246 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3247    functions).  */
3248
3249 gfc_try
3250 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3251 {
3252   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3253     return FAILURE;
3254
3255   if (scalar_check (unit, 0) == FAILURE)
3256     return FAILURE;
3257
3258   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3259     return FAILURE;
3260   if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3261     return FAILURE;
3262
3263   if (status == NULL)
3264     return SUCCESS;
3265
3266   if (type_check (status, 2, BT_INTEGER) == FAILURE
3267       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3268       || scalar_check (status, 2) == FAILURE)
3269     return FAILURE;
3270
3271   return SUCCESS;
3272 }
3273
3274
3275 gfc_try
3276 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3277 {
3278   return gfc_check_fgetputc_sub (unit, c, NULL);
3279 }
3280
3281
3282 gfc_try
3283 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3284 {
3285   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3286     return FAILURE;
3287   if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3288     return FAILURE;
3289
3290   if (status == NULL)
3291     return SUCCESS;
3292
3293   if (type_check (status, 1, BT_INTEGER) == FAILURE
3294       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3295       || scalar_check (status, 1) == FAILURE)
3296     return FAILURE;
3297
3298   return SUCCESS;
3299 }
3300
3301
3302 gfc_try
3303 gfc_check_fgetput (gfc_expr *c)
3304 {
3305   return gfc_check_fgetput_sub (c, NULL);
3306 }
3307
3308
3309 gfc_try
3310 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3311 {
3312   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3313     return FAILURE;
3314
3315   if (scalar_check (unit, 0) == FAILURE)
3316     return FAILURE;
3317
3318   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3319     return FAILURE;
3320
3321   if (scalar_check (offset, 1) == FAILURE)
3322     return FAILURE;
3323
3324   if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3325     return FAILURE;
3326
3327   if (scalar_check (whence, 2) == FAILURE)
3328     return FAILURE;
3329
3330   if (status == NULL)
3331     return SUCCESS;
3332
3333   if (type_check (status, 3, BT_INTEGER) == FAILURE)
3334     return FAILURE;
3335
3336   if (kind_value_check (status, 3, 4) == FAILURE)
3337     return FAILURE;
3338
3339   if (scalar_check (status, 3) == FAILURE)
3340     return FAILURE;
3341
3342   return SUCCESS;
3343 }
3344
3345
3346
3347 gfc_try
3348 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
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 (unit, 0, gfc_default_integer_kind) == FAILURE)
3358     return FAILURE;
3359
3360   if (array_check (array, 1) == FAILURE)
3361     return FAILURE;
3362
3363   return SUCCESS;
3364 }
3365
3366
3367 gfc_try
3368 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3369 {
3370   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3371     return FAILURE;
3372
3373   if (scalar_check (unit, 0) == FAILURE)
3374     return FAILURE;
3375
3376   if (type_check (array, 1, BT_INTEGER) == FAILURE
3377       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3378     return FAILURE;
3379
3380   if (array_check (array, 1) == FAILURE)
3381     return FAILURE;
3382
3383   if (status == NULL)
3384     return SUCCESS;
3385
3386   if (type_check (status, 2, BT_INTEGER) == FAILURE
3387       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3388     return FAILURE;
3389
3390   if (scalar_check (status, 2) == FAILURE)
3391     return FAILURE;
3392
3393   return SUCCESS;
3394 }
3395
3396
3397 gfc_try
3398 gfc_check_ftell (gfc_expr *unit)
3399 {
3400   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3401     return FAILURE;
3402
3403   if (scalar_check (unit, 0) == FAILURE)
3404     return FAILURE;
3405
3406   return SUCCESS;
3407 }
3408
3409
3410 gfc_try
3411 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3412 {
3413   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3414     return FAILURE;
3415
3416   if (scalar_check (unit, 0) == FAILURE)
3417     return FAILURE;
3418
3419   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3420     return FAILURE;
3421
3422   if (scalar_check (offset, 1) == FAILURE)
3423     return FAILURE;
3424
3425   return SUCCESS;
3426 }
3427
3428
3429 gfc_try
3430 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3431 {
3432   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3433     return FAILURE;
3434   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3435     return FAILURE;
3436
3437   if (type_check (array, 1, BT_INTEGER) == FAILURE
3438       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3439     return FAILURE;
3440
3441   if (array_check (array, 1) == FAILURE)
3442     return FAILURE;
3443
3444   return SUCCESS;
3445 }
3446
3447
3448 gfc_try
3449 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3450 {
3451   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3452     return FAILURE;
3453   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3454     return FAILURE;
3455
3456   if (type_check (array, 1, BT_INTEGER) == FAILURE
3457       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3458     return FAILURE;
3459
3460   if (array_check (array, 1) == FAILURE)
3461     return FAILURE;
3462
3463   if (status == NULL)
3464     return SUCCESS;
3465
3466   if (type_check (status, 2, BT_INTEGER) == FAILURE
3467       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3468     return FAILURE;
3469
3470   if (scalar_check (status, 2) == FAILURE)
3471     return FAILURE;
3472
3473   return SUCCESS;
3474 }
3475
3476
3477 gfc_try
3478 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3479 {
3480   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3481     {
3482       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3483       return FAILURE;
3484     }
3485
3486   if (coarray_check (coarray, 0) == FAILURE)
3487     return FAILURE;
3488
3489   if (sub->rank != 1)
3490     {
3491       gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3492                 gfc_current_intrinsic_arg[1]->name, &sub->where);
3493       return FAILURE;
3494     }
3495
3496   return SUCCESS;
3497 }
3498
3499
3500 gfc_try
3501 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3502 {
3503   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3504     {
3505       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3506       return FAILURE;
3507     }
3508
3509   if (dim != NULL &&  coarray == NULL)
3510     {
3511       gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3512                 "intrinsic at %L", &dim->where);
3513       return FAILURE;
3514     }
3515
3516   if (coarray == NULL)
3517     return SUCCESS;
3518
3519   if (coarray_check (coarray, 0) == FAILURE)
3520     return FAILURE;
3521
3522   if (dim != NULL)
3523     {
3524       if (dim_check (dim, 1, false) == FAILURE)
3525        return FAILURE;
3526
3527       if (dim_corank_check (dim, coarray) == FAILURE)
3528        return FAILURE;
3529     }
3530
3531   return SUCCESS;
3532 }
3533
3534
3535 gfc_try
3536 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
3537                     gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
3538 {
3539   if (mold->ts.type == BT_HOLLERITH)
3540     {
3541       gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
3542                  &mold->where, gfc_basic_typename (BT_HOLLERITH));
3543       return FAILURE;
3544     }
3545
3546   if (size != NULL)
3547     {
3548       if (type_check (size, 2, BT_INTEGER) == FAILURE)
3549         return FAILURE;
3550
3551       if (scalar_check (size, 2) == FAILURE)
3552         return FAILURE;
3553
3554       if (nonoptional_check (size, 2) == FAILURE)
3555         return FAILURE;
3556     }
3557
3558   return SUCCESS;
3559 }
3560
3561
3562 gfc_try
3563 gfc_check_transpose (gfc_expr *matrix)
3564 {
3565   if (rank_check (matrix, 0, 2) == FAILURE)
3566     return FAILURE;
3567
3568   return SUCCESS;
3569 }
3570
3571
3572 gfc_try
3573 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3574 {
3575   if (array_check (array, 0) == FAILURE)
3576     return FAILURE;
3577
3578   if (dim_check (dim, 1, false) == FAILURE)
3579     return FAILURE;
3580
3581   if (dim_rank_check (dim, array, 0) == FAILURE)
3582     return FAILURE;
3583
3584   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3585     return FAILURE;
3586   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3587                               "with KIND argument at %L",
3588                               gfc_current_intrinsic, &kind->where) == FAILURE)
3589     return FAILURE;
3590
3591   return SUCCESS;
3592 }
3593
3594
3595 gfc_try
3596 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
3597 {
3598   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3599     {
3600       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3601       return FAILURE;
3602     }
3603
3604   if (coarray_check (coarray, 0) == FAILURE)
3605     return FAILURE;
3606
3607   if (dim != NULL)
3608     {
3609       if (dim_check (dim, 1, false) == FAILURE)
3610         return FAILURE;
3611
3612       if (dim_corank_check (dim, coarray) == FAILURE)
3613         return FAILURE;
3614     }
3615
3616   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3617     return FAILURE;
3618
3619   return SUCCESS;
3620 }
3621
3622
3623 gfc_try
3624 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
3625 {
3626   mpz_t vector_size;
3627
3628   if (rank_check (vector, 0, 1) == FAILURE)
3629     return FAILURE;
3630
3631   if (array_check (mask, 1) == FAILURE)
3632     return FAILURE;
3633
3634   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
3635     return FAILURE;
3636
3637   if (same_type_check (vector, 0, field, 2) == FAILURE)
3638     return FAILURE;
3639
3640   if (mask->expr_type == EXPR_ARRAY
3641       && gfc_array_size (vector, &vector_size) == SUCCESS)
3642     {
3643       int mask_true_count = 0;
3644       gfc_constructor *mask_ctor;
3645       mask_ctor = gfc_constructor_first (mask->value.constructor);
3646       while (mask_ctor)
3647         {
3648           if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
3649             {
3650               mask_true_count = 0;
3651               break;
3652             }
3653
3654           if (mask_ctor->expr->value.logical)
3655             mask_true_count++;
3656
3657           mask_ctor = gfc_constructor_next (mask_ctor);
3658         }
3659
3660       if (mpz_get_si (vector_size) < mask_true_count)
3661         {
3662           gfc_error ("'%s' argument of '%s' intrinsic at %L must "
3663                      "provide at least as many elements as there "
3664                      "are .TRUE. values in '%s' (%ld/%d)",
3665                      gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3666                      &vector->where, gfc_current_intrinsic_arg[1]->name,
3667                      mpz_get_si (vector_size), mask_true_count);
3668           return FAILURE;
3669         }
3670
3671       mpz_clear (vector_size);
3672     }
3673
3674   if (mask->rank != field->rank && field->rank != 0)
3675     {
3676       gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
3677                  "the same rank as '%s' or be a scalar",
3678                  gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
3679                  &field->where, gfc_current_intrinsic_arg[1]->name);
3680       return FAILURE;
3681     }
3682
3683   if (mask->rank == field->rank)
3684     {
3685       int i;
3686       for (i = 0; i < field->rank; i++)
3687         if (! identical_dimen_shape (mask, i, field, i))
3688         {
3689           gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
3690                      "must have identical shape.",
3691                      gfc_current_intrinsic_arg[2]->name,
3692                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3693                      &field->where);
3694         }
3695     }
3696
3697   return SUCCESS;
3698 }
3699
3700
3701 gfc_try
3702 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3703 {
3704   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3705     return FAILURE;
3706
3707   if (same_type_check (x, 0, y, 1) == FAILURE)
3708     return FAILURE;
3709
3710   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3711     return FAILURE;
3712
3713   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3714     return FAILURE;
3715   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3716                               "with KIND argument at %L",
3717                               gfc_current_intrinsic, &kind->where) == FAILURE)
3718     return FAILURE;
3719
3720   return SUCCESS;
3721 }
3722
3723
3724 gfc_try
3725 gfc_check_trim (gfc_expr *x)
3726 {
3727   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3728     return FAILURE;
3729
3730   if (scalar_check (x, 0) == FAILURE)
3731     return FAILURE;
3732
3733    return SUCCESS;
3734 }
3735
3736
3737 gfc_try
3738 gfc_check_ttynam (gfc_expr *unit)
3739 {
3740   if (scalar_check (unit, 0) == FAILURE)
3741     return FAILURE;
3742
3743   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3744     return FAILURE;
3745
3746   return SUCCESS;
3747 }
3748
3749
3750 /* Common check function for the half a dozen intrinsics that have a
3751    single real argument.  */
3752
3753 gfc_try
3754 gfc_check_x (gfc_expr *x)
3755 {
3756   if (type_check (x, 0, BT_REAL) == FAILURE)
3757     return FAILURE;
3758
3759   return SUCCESS;
3760 }
3761
3762
3763 /************* Check functions for intrinsic subroutines *************/
3764
3765 gfc_try
3766 gfc_check_cpu_time (gfc_expr *time)
3767 {
3768   if (scalar_check (time, 0) == FAILURE)
3769     return FAILURE;
3770
3771   if (type_check (time, 0, BT_REAL) == FAILURE)
3772     return FAILURE;
3773
3774   if (variable_check (time, 0) == FAILURE)
3775     return FAILURE;
3776
3777   return SUCCESS;
3778 }
3779
3780
3781 gfc_try
3782 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
3783                          gfc_expr *zone, gfc_expr *values)
3784 {
3785   if (date != NULL)
3786     {
3787       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3788         return FAILURE;
3789       if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3790         return FAILURE;
3791       if (scalar_check (date, 0) == FAILURE)
3792         return FAILURE;
3793       if (variable_check (date, 0) == FAILURE)
3794         return FAILURE;
3795     }
3796
3797   if (time != NULL)
3798     {
3799       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
3800         return FAILURE;
3801       if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
3802         return FAILURE;
3803       if (scalar_check (time, 1) == FAILURE)
3804         return FAILURE;
3805       if (variable_check (time, 1) == FAILURE)
3806         return FAILURE;
3807     }
3808
3809   if (zone != NULL)
3810     {
3811       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
3812         return FAILURE;
3813       if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
3814         return FAILURE;
3815       if (scalar_check (zone, 2) == FAILURE)
3816         return FAILURE;
3817       if (variable_check (zone, 2) == FAILURE)
3818         return FAILURE;
3819     }
3820
3821   if (values != NULL)
3822     {
3823       if (type_check (values, 3, BT_INTEGER) == FAILURE)
3824         return FAILURE;
3825       if (array_check (values, 3) == FAILURE)
3826         return FAILURE;
3827       if (rank_check (values, 3, 1) == FAILURE)
3828         return FAILURE;
3829       if (variable_check (values, 3) == FAILURE)
3830         return FAILURE;
3831     }
3832
3833   return SUCCESS;
3834 }
3835
3836
3837 gfc_try
3838 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
3839                   gfc_expr *to, gfc_expr *topos)
3840 {
3841   if (type_check (from, 0, BT_INTEGER) == FAILURE)
3842     return FAILURE;
3843
3844   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
3845     return FAILURE;
3846
3847   if (type_check (len, 2, BT_INTEGER) == FAILURE)
3848     return FAILURE;
3849
3850   if (same_type_check (from, 0, to, 3) == FAILURE)
3851     return FAILURE;
3852
3853   if (variable_check (to, 3) == FAILURE)
3854     return FAILURE;
3855
3856   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
3857     return FAILURE;
3858
3859   if (nonnegative_check ("frompos", frompos) == FAILURE)
3860     return FAILURE;
3861
3862   if (nonnegative_check ("topos", topos) == FAILURE)
3863     return FAILURE;
3864
3865   if (nonnegative_check ("len", len) == FAILURE)
3866     return FAILURE;
3867
3868   if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
3869       == FAILURE)
3870     return FAILURE;
3871
3872   if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
3873     return FAILURE;
3874
3875   return SUCCESS;
3876 }
3877
3878
3879 gfc_try
3880 gfc_check_random_number (gfc_expr *harvest)
3881 {
3882   if (type_check (harvest, 0, BT_REAL) == FAILURE)
3883     return FAILURE;
3884
3885   if (variable_check (harvest, 0) == FAILURE)
3886     return FAILURE;
3887
3888   return SUCCESS;
3889 }
3890
3891
3892 gfc_try
3893 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
3894 {
3895   unsigned int nargs = 0, kiss_size;
3896   locus *where = NULL;
3897   mpz_t put_size, get_size;
3898   bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran.  */
3899
3900   have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
3901
3902   /* Keep the number of bytes in sync with kiss_size in
3903      libgfortran/intrinsics/random.c.  */
3904   kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
3905
3906   if (size != NULL)
3907     {
3908       if (size->expr_type != EXPR_VARIABLE
3909           || !size->symtree->n.sym->attr.optional)
3910         nargs++;
3911
3912       if (scalar_check (size, 0) == FAILURE)
3913         return FAILURE;
3914
3915       if (type_check (size, 0, BT_INTEGER) == FAILURE)
3916         return FAILURE;
3917
3918       if (variable_check (size, 0) == FAILURE)
3919         return FAILURE;
3920
3921       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3922         return FAILURE;
3923     }
3924
3925   if (put != NULL)
3926     {
3927       if (put->expr_type != EXPR_VARIABLE
3928           || !put->symtree->n.sym->attr.optional)
3929         {
3930           nargs++;
3931           where = &put->where;
3932         }
3933
3934       if (array_check (put, 1) == FAILURE)
3935         return FAILURE;
3936
3937       if (rank_check (put, 1, 1) == FAILURE)
3938         return FAILURE;
3939
3940       if (type_check (put, 1, BT_INTEGER) == FAILURE)
3941         return FAILURE;
3942
3943       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3944         return FAILURE;
3945
3946       if (gfc_array_size (put, &put_size) == SUCCESS
3947           && mpz_get_ui (put_size) < kiss_size)
3948         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3949                    "too small (%i/%i)",
3950                    gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3951                    where, (int) mpz_get_ui (put_size), kiss_size);
3952     }
3953
3954   if (get != NULL)
3955     {
3956       if (get->expr_type != EXPR_VARIABLE
3957           || !get->symtree->n.sym->attr.optional)
3958         {
3959           nargs++;
3960           where = &get->where;
3961         }
3962
3963       if (array_check (get, 2) == FAILURE)
3964         return FAILURE;
3965
3966       if (rank_check (get, 2, 1) == FAILURE)
3967         return FAILURE;
3968
3969       if (type_check (get, 2, BT_INTEGER) == FAILURE)
3970         return FAILURE;
3971
3972       if (variable_check (get, 2) == FAILURE)
3973         return FAILURE;
3974
3975       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3976         return FAILURE;
3977
3978        if (gfc_array_size (get, &get_size) == SUCCESS
3979           && mpz_get_ui (get_size) < kiss_size)
3980         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3981                    "too small (%i/%i)",
3982                    gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
3983                    where, (int) mpz_get_ui (get_size), kiss_size);
3984     }
3985
3986   /* RANDOM_SEED may not have more than one non-optional argument.  */
3987   if (nargs > 1)
3988     gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3989
3990   return SUCCESS;
3991 }
3992
3993
3994 gfc_try
3995 gfc_check_second_sub (gfc_expr *time)
3996 {
3997   if (scalar_check (time, 0) == FAILURE)
3998     return FAILURE;
3999
4000   if (type_check (time, 0, BT_REAL) == FAILURE)
4001     return FAILURE;
4002
4003   if (kind_value_check(time, 0, 4) == FAILURE)
4004     return FAILURE;
4005
4006   return SUCCESS;
4007 }
4008
4009
4010 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
4011    count, count_rate, and count_max are all optional arguments */
4012
4013 gfc_try
4014 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
4015                         gfc_expr *count_max)
4016 {
4017   if (count != NULL)
4018     {
4019       if (scalar_check (count, 0) == FAILURE)
4020         return FAILURE;
4021
4022       if (type_check (count, 0, BT_INTEGER) == FAILURE)
4023         return FAILURE;
4024
4025       if (variable_check (count, 0) == FAILURE)
4026         return FAILURE;
4027     }
4028
4029   if (count_rate != NULL)
4030     {
4031       if (scalar_check (count_rate, 1) == FAILURE)
4032         return FAILURE;
4033
4034       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
4035         return FAILURE;
4036
4037       if (variable_check (count_rate, 1) == FAILURE)
4038         return FAILURE;
4039
4040       if (count != NULL
4041           && same_type_check (count, 0, count_rate, 1) == FAILURE)
4042         return FAILURE;
4043
4044     }
4045
4046   if (count_max != NULL)
4047     {
4048       if (scalar_check (count_max, 2) == FAILURE)
4049         return FAILURE;
4050
4051       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
4052         return FAILURE;
4053
4054       if (variable_check (count_max, 2) == FAILURE)
4055         return FAILURE;
4056
4057       if (count != NULL
4058           && same_type_check (count, 0, count_max, 2) == FAILURE)
4059         return FAILURE;
4060
4061       if (count_rate != NULL
4062           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
4063         return FAILURE;
4064     }
4065
4066   return SUCCESS;
4067 }
4068
4069
4070 gfc_try
4071 gfc_check_irand (gfc_expr *x)
4072 {
4073   if (x == NULL)
4074     return SUCCESS;
4075
4076   if (scalar_check (x, 0) == FAILURE)
4077     return FAILURE;
4078
4079   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4080     return FAILURE;
4081
4082   if (kind_value_check(x, 0, 4) == FAILURE)
4083     return FAILURE;
4084
4085   return SUCCESS;
4086 }
4087
4088
4089 gfc_try
4090 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
4091 {
4092   if (scalar_check (seconds, 0) == FAILURE)
4093     return FAILURE;
4094   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
4095     return FAILURE;
4096
4097   if (int_or_proc_check (handler, 1) == FAILURE)
4098     return FAILURE;
4099   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4100     return FAILURE;
4101
4102   if (status == NULL)
4103     return SUCCESS;
4104
4105   if (scalar_check (status, 2) == FAILURE)
4106     return FAILURE;
4107   if (type_check (status, 2, BT_INTEGER) == FAILURE)
4108     return FAILURE;
4109   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
4110     return FAILURE;
4111
4112   return SUCCESS;
4113 }
4114
4115
4116 gfc_try
4117 gfc_check_rand (gfc_expr *x)
4118 {
4119   if (x == NULL)
4120     return SUCCESS;
4121
4122   if (scalar_check (x, 0) == FAILURE)
4123     return FAILURE;
4124
4125   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4126     return FAILURE;
4127
4128   if (kind_value_check(x, 0, 4) == FAILURE)
4129     return FAILURE;
4130
4131   return SUCCESS;
4132 }
4133
4134
4135 gfc_try
4136 gfc_check_srand (gfc_expr *x)
4137 {
4138   if (scalar_check (x, 0) == FAILURE)
4139     return FAILURE;
4140
4141   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4142     return FAILURE;
4143
4144   if (kind_value_check(x, 0, 4) == FAILURE)
4145     return FAILURE;
4146
4147   return SUCCESS;
4148 }
4149
4150
4151 gfc_try
4152 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
4153 {
4154   if (scalar_check (time, 0) == FAILURE)
4155     return FAILURE;
4156   if (type_check (time, 0, BT_INTEGER) == FAILURE)
4157     return FAILURE;
4158
4159   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
4160     return FAILURE;
4161   if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
4162     return FAILURE;
4163
4164   return SUCCESS;
4165 }
4166
4167
4168 gfc_try
4169 gfc_check_dtime_etime (gfc_expr *x)
4170 {
4171   if (array_check (x, 0) == FAILURE)
4172     return FAILURE;
4173
4174   if (rank_check (x, 0, 1) == FAILURE)
4175     return FAILURE;
4176
4177   if (variable_check (x, 0) == FAILURE)
4178     return FAILURE;
4179
4180   if (type_check (x, 0, BT_REAL) == FAILURE)
4181     return FAILURE;
4182
4183   if (kind_value_check(x, 0, 4) == FAILURE)
4184     return FAILURE;
4185
4186   return SUCCESS;
4187 }
4188
4189
4190 gfc_try
4191 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
4192 {
4193   if (array_check (values, 0) == FAILURE)
4194     return FAILURE;
4195
4196   if (rank_check (values, 0, 1) == FAILURE)
4197     return FAILURE;
4198
4199   if (variable_check (values, 0) == FAILURE)
4200     return FAILURE;
4201
4202   if (type_check (values, 0, BT_REAL) == FAILURE)
4203     return FAILURE;
4204
4205   if (kind_value_check(values, 0, 4) == FAILURE)
4206     return FAILURE;
4207
4208   if (scalar_check (time, 1) == FAILURE)
4209     return FAILURE;
4210
4211   if (type_check (time, 1, BT_REAL) == FAILURE)
4212     return FAILURE;
4213
4214   if (kind_value_check(time, 1, 4) == FAILURE)
4215     return FAILURE;
4216
4217   return SUCCESS;
4218 }
4219
4220
4221 gfc_try
4222 gfc_check_fdate_sub (gfc_expr *date)
4223 {
4224   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4225     return FAILURE;
4226   if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4227     return FAILURE;
4228
4229   return SUCCESS;
4230 }
4231
4232
4233 gfc_try
4234 gfc_check_gerror (gfc_expr *msg)
4235 {
4236   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4237     return FAILURE;
4238   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4239     return FAILURE;
4240
4241   return SUCCESS;
4242 }
4243
4244
4245 gfc_try
4246 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4247 {
4248   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4249     return FAILURE;
4250   if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4251     return FAILURE;
4252
4253   if (status == NULL)
4254     return SUCCESS;
4255
4256   if (scalar_check (status, 1) == FAILURE)
4257     return FAILURE;
4258
4259   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4260     return FAILURE;
4261
4262   return SUCCESS;
4263 }
4264
4265
4266 gfc_try
4267 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4268 {
4269   if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4270     return FAILURE;
4271
4272   if (pos->ts.kind > gfc_default_integer_kind)
4273     {
4274       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4275                  "not wider than the default kind (%d)",
4276                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4277                  &pos->where, gfc_default_integer_kind);
4278       return FAILURE;
4279     }
4280
4281   if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4282     return FAILURE;
4283   if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4284     return FAILURE;
4285
4286   return SUCCESS;
4287 }
4288
4289
4290 gfc_try
4291 gfc_check_getlog (gfc_expr *msg)
4292 {
4293   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4294     return FAILURE;
4295   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4296     return FAILURE;
4297
4298   return SUCCESS;
4299 }
4300
4301
4302 gfc_try
4303 gfc_check_exit (gfc_expr *status)
4304 {
4305   if (status == NULL)
4306     return SUCCESS;
4307
4308   if (type_check (status, 0, BT_INTEGER) == FAILURE)
4309     return FAILURE;
4310
4311   if (scalar_check (status, 0) == FAILURE)
4312     return FAILURE;
4313
4314   return SUCCESS;
4315 }
4316
4317
4318 gfc_try
4319 gfc_check_flush (gfc_expr *unit)
4320 {
4321   if (unit == NULL)
4322     return SUCCESS;
4323
4324   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4325     return FAILURE;
4326
4327   if (scalar_check (unit, 0) == FAILURE)
4328     return FAILURE;
4329
4330   return SUCCESS;
4331 }
4332
4333
4334 gfc_try
4335 gfc_check_free (gfc_expr *i)
4336 {
4337   if (type_check (i, 0, BT_INTEGER) == FAILURE)
4338     return FAILURE;
4339
4340   if (scalar_check (i, 0) == FAILURE)
4341     return FAILURE;
4342
4343   return SUCCESS;
4344 }
4345
4346
4347 gfc_try
4348 gfc_check_hostnm (gfc_expr *name)
4349 {
4350   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4351     return FAILURE;
4352   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4353     return FAILURE;
4354
4355   return SUCCESS;
4356 }
4357
4358
4359 gfc_try
4360 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4361 {
4362   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4363     return FAILURE;
4364   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4365     return FAILURE;
4366
4367   if (status == NULL)
4368     return SUCCESS;
4369
4370   if (scalar_check (status, 1) == FAILURE)
4371     return FAILURE;
4372
4373   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4374     return FAILURE;
4375
4376   return SUCCESS;
4377 }
4378
4379
4380 gfc_try
4381 gfc_check_itime_idate (gfc_expr *values)
4382 {
4383   if (array_check (values, 0) == FAILURE)
4384     return FAILURE;
4385
4386   if (rank_check (values, 0, 1) == FAILURE)
4387     return FAILURE;
4388
4389   if (variable_check (values, 0) == FAILURE)
4390     return FAILURE;
4391
4392   if (type_check (values, 0, BT_INTEGER) == FAILURE)
4393     return FAILURE;
4394
4395   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4396     return FAILURE;
4397
4398   return SUCCESS;
4399 }
4400
4401
4402 gfc_try
4403 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4404 {
4405   if (type_check (time, 0, BT_INTEGER) == FAILURE)
4406     return FAILURE;
4407
4408   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4409     return FAILURE;
4410
4411   if (scalar_check (time, 0) == FAILURE)
4412     return FAILURE;
4413
4414   if (array_check (values, 1) == FAILURE)
4415     return FAILURE;
4416
4417   if (rank_check (values, 1, 1) == FAILURE)
4418     return FAILURE;
4419
4420   if (variable_check (values, 1) == FAILURE)
4421     return FAILURE;
4422
4423   if (type_check (values, 1, BT_INTEGER) == FAILURE)
4424     return FAILURE;
4425
4426   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4427     return FAILURE;
4428
4429   return SUCCESS;
4430 }
4431
4432
4433 gfc_try
4434 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4435 {
4436   if (scalar_check (unit, 0) == FAILURE)
4437     return FAILURE;
4438
4439   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4440     return FAILURE;
4441
4442   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4443     return FAILURE;
4444   if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4445     return FAILURE;
4446
4447   return SUCCESS;
4448 }
4449
4450
4451 gfc_try
4452 gfc_check_isatty (gfc_expr *unit)
4453 {
4454   if (unit == NULL)
4455     return FAILURE;
4456
4457   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4458     return FAILURE;
4459
4460   if (scalar_check (unit, 0) == FAILURE)
4461     return FAILURE;
4462
4463   return SUCCESS;
4464 }
4465
4466
4467 gfc_try
4468 gfc_check_isnan (gfc_expr *x)
4469 {
4470   if (type_check (x, 0, BT_REAL) == FAILURE)
4471     return FAILURE;
4472
4473   return SUCCESS;
4474 }
4475
4476
4477 gfc_try
4478 gfc_check_perror (gfc_expr *string)
4479 {
4480   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
4481     return FAILURE;
4482   if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
4483     return FAILURE;
4484
4485   return SUCCESS;
4486 }
4487
4488
4489 gfc_try
4490 gfc_check_umask (gfc_expr *mask)
4491 {
4492   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4493     return FAILURE;
4494
4495   if (scalar_check (mask, 0) == FAILURE)
4496     return FAILURE;
4497
4498   return SUCCESS;
4499 }
4500
4501
4502 gfc_try
4503 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
4504 {
4505   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
4506     return FAILURE;
4507
4508   if (scalar_check (mask, 0) == FAILURE)
4509     return FAILURE;
4510
4511   if (old == NULL)
4512     return SUCCESS;
4513
4514   if (scalar_check (old, 1) == FAILURE)
4515     return FAILURE;
4516
4517   if (type_check (old, 1, BT_INTEGER) == FAILURE)
4518     return FAILURE;
4519
4520   return SUCCESS;
4521 }
4522
4523
4524 gfc_try
4525 gfc_check_unlink (gfc_expr *name)
4526 {
4527   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4528     return FAILURE;
4529   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4530     return FAILURE;
4531
4532   return SUCCESS;
4533 }
4534
4535
4536 gfc_try
4537 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
4538 {
4539   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4540     return FAILURE;
4541   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4542     return FAILURE;
4543
4544   if (status == NULL)
4545     return SUCCESS;
4546
4547   if (scalar_check (status, 1) == FAILURE)
4548     return FAILURE;
4549
4550   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4551     return FAILURE;
4552
4553   return SUCCESS;
4554 }
4555
4556
4557 gfc_try
4558 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
4559 {
4560   if (scalar_check (number, 0) == FAILURE)
4561     return FAILURE;
4562   if (type_check (number, 0, BT_INTEGER) == FAILURE)
4563     return FAILURE;
4564
4565   if (int_or_proc_check (handler, 1) == FAILURE)
4566     return FAILURE;
4567   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4568     return FAILURE;
4569
4570   return SUCCESS;
4571 }
4572
4573
4574 gfc_try
4575 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
4576 {
4577   if (scalar_check (number, 0) == FAILURE)
4578     return FAILURE;
4579   if (type_check (number, 0, BT_INTEGER) == FAILURE)
4580     return FAILURE;
4581
4582   if (int_or_proc_check (handler, 1) == FAILURE)
4583     return FAILURE;
4584   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4585     return FAILURE;
4586
4587   if (status == NULL)
4588     return SUCCESS;
4589
4590   if (type_check (status, 2, BT_INTEGER) == FAILURE)
4591     return FAILURE;
4592   if (scalar_check (status, 2) == FAILURE)
4593     return FAILURE;
4594
4595   return SUCCESS;
4596 }
4597
4598
4599 gfc_try
4600 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
4601 {
4602   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
4603     return FAILURE;
4604   if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
4605     return FAILURE;
4606
4607   if (scalar_check (status, 1) == FAILURE)
4608     return FAILURE;
4609
4610   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4611     return FAILURE;
4612
4613   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
4614     return FAILURE;
4615
4616   return SUCCESS;
4617 }
4618
4619
4620 /* This is used for the GNU intrinsics AND, OR and XOR.  */
4621 gfc_try
4622 gfc_check_and (gfc_expr *i, gfc_expr *j)
4623 {
4624   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
4625     {
4626       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4627                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
4628                  gfc_current_intrinsic, &i->where);
4629       return FAILURE;
4630     }
4631
4632   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
4633     {
4634       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
4635                  "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
4636                  gfc_current_intrinsic, &j->where);
4637       return FAILURE;
4638     }
4639
4640   if (i->ts.type != j->ts.type)
4641     {
4642       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
4643                  "have the same type", gfc_current_intrinsic_arg[0]->name,
4644                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4645                  &j->where);
4646       return FAILURE;
4647     }
4648
4649   if (scalar_check (i, 0) == FAILURE)
4650     return FAILURE;
4651
4652   if (scalar_check (j, 1) == FAILURE)
4653     return FAILURE;
4654
4655   return SUCCESS;
4656 }
4657
4658
4659 gfc_try
4660 gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
4661 {
4662   if (kind == NULL)
4663     return SUCCESS;
4664
4665   if (type_check (kind, 1, BT_INTEGER) == FAILURE)
4666     return FAILURE;
4667
4668   if (scalar_check (kind, 1) == FAILURE)
4669     return FAILURE;
4670
4671   if (kind->expr_type != EXPR_CONSTANT)
4672     {
4673       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
4674                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4675                  &kind->where);
4676       return FAILURE;
4677     }
4678
4679   return SUCCESS;
4680 }