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