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