gcc/fortran/check.c

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