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)
 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   mpz_t tmp;
3992   gfc_expr *mold_element;
3993
3994   if (source->expr_type == EXPR_FUNCTION)
3995     return FAILURE;
3996
3997   if (size && size->expr_type != EXPR_CONSTANT)
3998     return FAILURE;
3999
4000   /* Calculate the size of the source.  */
4001   if (source->expr_type == EXPR_ARRAY
4002       && gfc_array_size (source, &tmp) == FAILURE)
4003     return FAILURE;
4004
4005   *source_size = gfc_target_expr_size (source);
4006   if (*source_size == 0)
4007     return FAILURE;
4008
4009   mold_element = mold->expr_type == EXPR_ARRAY
4010                  ? gfc_constructor_first (mold->value.constructor)->expr
4011                  : mold;
4012
4013   /* Determine the size of the element.  */
4014   result_elt_size = gfc_target_expr_size (mold_element);
4015   if (result_elt_size == 0)
4016     return FAILURE;
4017
4018   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4019     {
4020       int result_length;
4021
4022       if (size)
4023         result_length = (size_t)mpz_get_ui (size->value.integer);
4024       else
4025         {
4026           result_length = *source_size / result_elt_size;
4027           if (result_length * result_elt_size < *source_size)
4028             result_length += 1;
4029         }
4030
4031       *result_size = result_length * result_elt_size;
4032       if (result_length_p)
4033         *result_length_p = result_length;
4034     }
4035   else
4036     *result_size = result_elt_size;
4037
4038   return SUCCESS;
4039 }
4040
4041
4042 gfc_try
4043 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4044 {
4045   size_t source_size;
4046   size_t result_size;
4047
4048   if (mold->ts.type == BT_HOLLERITH)
4049     {
4050       gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4051                  &mold->where, gfc_basic_typename (BT_HOLLERITH));
4052       return FAILURE;
4053     }
4054
4055   if (size != NULL)
4056     {
4057       if (type_check (size, 2, BT_INTEGER) == FAILURE)
4058         return FAILURE;
4059
4060       if (scalar_check (size, 2) == FAILURE)
4061         return FAILURE;
4062
4063       if (nonoptional_check (size, 2) == FAILURE)
4064         return FAILURE;
4065     }
4066
4067   if (!gfc_option.warn_surprising)
4068     return SUCCESS;
4069
4070   /* If we can't calculate the sizes, we cannot check any more.
4071      Return SUCCESS for that case.  */
4072
4073   if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
4074                                     &result_size, NULL) == FAILURE)
4075     return SUCCESS;
4076
4077   if (source_size < result_size)
4078     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4079                 "source size %ld < result size %ld", &source->where,
4080                 (long) source_size, (long) result_size);
4081
4082   return SUCCESS;
4083 }
4084
4085
4086 gfc_try
4087 gfc_check_transpose (gfc_expr *matrix)
4088 {
4089   if (rank_check (matrix, 0, 2) == FAILURE)
4090     return FAILURE;
4091
4092   return SUCCESS;
4093 }
4094
4095
4096 gfc_try
4097 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4098 {
4099   if (array_check (array, 0) == FAILURE)
4100     return FAILURE;
4101
4102   if (dim_check (dim, 1, false) == FAILURE)
4103     return FAILURE;
4104
4105   if (dim_rank_check (dim, array, 0) == FAILURE)
4106     return FAILURE;
4107
4108   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4109     return FAILURE;
4110   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4111                               "with KIND argument at %L",
4112                               gfc_current_intrinsic, &kind->where) == FAILURE)
4113     return FAILURE;
4114
4115   return SUCCESS;
4116 }
4117
4118
4119 gfc_try
4120 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
4121 {
4122   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4123     {
4124       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4125       return FAILURE;
4126     }
4127
4128   if (coarray_check (coarray, 0) == FAILURE)
4129     return FAILURE;
4130
4131   if (dim != NULL)
4132     {
4133       if (dim_check (dim, 1, false) == FAILURE)
4134         return FAILURE;
4135
4136       if (dim_corank_check (dim, coarray) == FAILURE)
4137         return FAILURE;
4138     }
4139
4140   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4141     return FAILURE;
4142
4143   return SUCCESS;
4144 }
4145
4146
4147 gfc_try
4148 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
4149 {
4150   mpz_t vector_size;
4151
4152   if (rank_check (vector, 0, 1) == FAILURE)
4153     return FAILURE;
4154
4155   if (array_check (mask, 1) == FAILURE)
4156     return FAILURE;
4157
4158   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
4159     return FAILURE;
4160
4161   if (same_type_check (vector, 0, field, 2) == FAILURE)
4162     return FAILURE;
4163
4164   if (mask->expr_type == EXPR_ARRAY
4165       && gfc_array_size (vector, &vector_size) == SUCCESS)
4166     {
4167       int mask_true_count = 0;
4168       gfc_constructor *mask_ctor;
4169       mask_ctor = gfc_constructor_first (mask->value.constructor);
4170       while (mask_ctor)
4171         {
4172           if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4173             {
4174               mask_true_count = 0;
4175               break;
4176             }
4177
4178           if (mask_ctor->expr->value.logical)
4179             mask_true_count++;
4180
4181           mask_ctor = gfc_constructor_next (mask_ctor);
4182         }
4183
4184       if (mpz_get_si (vector_size) < mask_true_count)
4185         {
4186           gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4187                      "provide at least as many elements as there "
4188                      "are .TRUE. values in '%s' (%ld/%d)",
4189                      gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4190                      &vector->where, gfc_current_intrinsic_arg[1]->name,
4191                      mpz_get_si (vector_size), mask_true_count);
4192           return FAILURE;
4193         }
4194
4195       mpz_clear (vector_size);
4196     }
4197
4198   if (mask->rank != field->rank && field->rank != 0)
4199     {
4200       gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4201                  "the same rank as '%s' or be a scalar",
4202                  gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4203                  &field->where, gfc_current_intrinsic_arg[1]->name);
4204       return FAILURE;
4205     }
4206
4207   if (mask->rank == field->rank)
4208     {
4209       int i;
4210       for (i = 0; i < field->rank; i++)
4211         if (! identical_dimen_shape (mask, i, field, i))
4212         {
4213           gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4214                      "must have identical shape.",
4215                      gfc_current_intrinsic_arg[2]->name,
4216                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4217                      &field->where);
4218         }
4219     }
4220
4221   return SUCCESS;
4222 }
4223
4224
4225 gfc_try
4226 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4227 {
4228   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4229     return FAILURE;
4230
4231   if (same_type_check (x, 0, y, 1) == FAILURE)
4232     return FAILURE;
4233
4234   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
4235     return FAILURE;
4236
4237   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
4238     return FAILURE;
4239   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4240                               "with KIND argument at %L",
4241                               gfc_current_intrinsic, &kind->where) == FAILURE)
4242     return FAILURE;
4243
4244   return SUCCESS;
4245 }
4246
4247
4248 gfc_try
4249 gfc_check_trim (gfc_expr *x)
4250 {
4251   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4252     return FAILURE;
4253
4254   if (scalar_check (x, 0) == FAILURE)
4255     return FAILURE;
4256
4257    return SUCCESS;
4258 }
4259
4260
4261 gfc_try
4262 gfc_check_ttynam (gfc_expr *unit)
4263 {
4264   if (scalar_check (unit, 0) == FAILURE)
4265     return FAILURE;
4266
4267   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4268     return FAILURE;
4269
4270   return SUCCESS;
4271 }
4272
4273
4274 /* Common check function for the half a dozen intrinsics that have a
4275    single real argument.  */
4276
4277 gfc_try
4278 gfc_check_x (gfc_expr *x)
4279 {
4280   if (type_check (x, 0, BT_REAL) == FAILURE)
4281     return FAILURE;
4282
4283   return SUCCESS;
4284 }
4285
4286
4287 /************* Check functions for intrinsic subroutines *************/
4288
4289 gfc_try
4290 gfc_check_cpu_time (gfc_expr *time)
4291 {
4292   if (scalar_check (time, 0) == FAILURE)
4293     return FAILURE;
4294
4295   if (type_check (time, 0, BT_REAL) == FAILURE)
4296     return FAILURE;
4297
4298   if (variable_check (time, 0, false) == FAILURE)
4299     return FAILURE;
4300
4301   return SUCCESS;
4302 }
4303
4304
4305 gfc_try
4306 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
4307                          gfc_expr *zone, gfc_expr *values)
4308 {
4309   if (date != NULL)
4310     {
4311       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4312         return FAILURE;
4313       if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4314         return FAILURE;
4315       if (scalar_check (date, 0) == FAILURE)
4316         return FAILURE;
4317       if (variable_check (date, 0, false) == FAILURE)
4318         return FAILURE;
4319     }
4320
4321   if (time != NULL)
4322     {
4323       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
4324         return FAILURE;
4325       if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
4326         return FAILURE;
4327       if (scalar_check (time, 1) == FAILURE)
4328         return FAILURE;
4329       if (variable_check (time, 1, false) == FAILURE)
4330         return FAILURE;
4331     }
4332
4333   if (zone != NULL)
4334     {
4335       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
4336         return FAILURE;
4337       if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
4338         return FAILURE;
4339       if (scalar_check (zone, 2) == FAILURE)
4340         return FAILURE;
4341       if (variable_check (zone, 2, false) == FAILURE)
4342         return FAILURE;
4343     }
4344
4345   if (values != NULL)
4346     {
4347       if (type_check (values, 3, BT_INTEGER) == FAILURE)
4348         return FAILURE;
4349       if (array_check (values, 3) == FAILURE)
4350         return FAILURE;
4351       if (rank_check (values, 3, 1) == FAILURE)
4352         return FAILURE;
4353       if (variable_check (values, 3, false) == FAILURE)
4354         return FAILURE;
4355     }
4356
4357   return SUCCESS;
4358 }
4359
4360
4361 gfc_try
4362 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
4363                   gfc_expr *to, gfc_expr *topos)
4364 {
4365   if (type_check (from, 0, BT_INTEGER) == FAILURE)
4366     return FAILURE;
4367
4368   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
4369     return FAILURE;
4370
4371   if (type_check (len, 2, BT_INTEGER) == FAILURE)
4372     return FAILURE;
4373
4374   if (same_type_check (from, 0, to, 3) == FAILURE)
4375     return FAILURE;
4376
4377   if (variable_check (to, 3, false) == FAILURE)
4378     return FAILURE;
4379
4380   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
4381     return FAILURE;
4382
4383   if (nonnegative_check ("frompos", frompos) == FAILURE)
4384     return FAILURE;
4385
4386   if (nonnegative_check ("topos", topos) == FAILURE)
4387     return FAILURE;
4388
4389   if (nonnegative_check ("len", len) == FAILURE)
4390     return FAILURE;
4391
4392   if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
4393       == FAILURE)
4394     return FAILURE;
4395
4396   if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
4397     return FAILURE;
4398
4399   return SUCCESS;
4400 }
4401
4402
4403 gfc_try
4404 gfc_check_random_number (gfc_expr *harvest)
4405 {
4406   if (type_check (harvest, 0, BT_REAL) == FAILURE)
4407     return FAILURE;
4408
4409   if (variable_check (harvest, 0, false) == FAILURE)
4410     return FAILURE;
4411
4412   return SUCCESS;
4413 }
4414
4415
4416 gfc_try
4417 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
4418 {
4419   unsigned int nargs = 0, kiss_size;
4420   locus *where = NULL;
4421   mpz_t put_size, get_size;
4422   bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran.  */
4423
4424   have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
4425
4426   /* Keep the number of bytes in sync with kiss_size in
4427      libgfortran/intrinsics/random.c.  */
4428   kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
4429
4430   if (size != NULL)
4431     {
4432       if (size->expr_type != EXPR_VARIABLE
4433           || !size->symtree->n.sym->attr.optional)
4434         nargs++;
4435
4436       if (scalar_check (size, 0) == FAILURE)
4437         return FAILURE;
4438
4439       if (type_check (size, 0, BT_INTEGER) == FAILURE)
4440         return FAILURE;
4441
4442       if (variable_check (size, 0, false) == FAILURE)
4443         return FAILURE;
4444
4445       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
4446         return FAILURE;
4447     }
4448
4449   if (put != NULL)
4450     {
4451       if (put->expr_type != EXPR_VARIABLE
4452           || !put->symtree->n.sym->attr.optional)
4453         {
4454           nargs++;
4455           where = &put->where;
4456         }
4457
4458       if (array_check (put, 1) == FAILURE)
4459         return FAILURE;
4460
4461       if (rank_check (put, 1, 1) == FAILURE)
4462         return FAILURE;
4463
4464       if (type_check (put, 1, BT_INTEGER) == FAILURE)
4465         return FAILURE;
4466
4467       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
4468         return FAILURE;
4469
4470       if (gfc_array_size (put, &put_size) == SUCCESS
4471           && mpz_get_ui (put_size) < kiss_size)
4472         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4473                    "too small (%i/%i)",
4474                    gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4475                    where, (int) mpz_get_ui (put_size), kiss_size);
4476     }
4477
4478   if (get != NULL)
4479     {
4480       if (get->expr_type != EXPR_VARIABLE
4481           || !get->symtree->n.sym->attr.optional)
4482         {
4483           nargs++;
4484           where = &get->where;
4485         }
4486
4487       if (array_check (get, 2) == FAILURE)
4488         return FAILURE;
4489
4490       if (rank_check (get, 2, 1) == FAILURE)
4491         return FAILURE;
4492
4493       if (type_check (get, 2, BT_INTEGER) == FAILURE)
4494         return FAILURE;
4495
4496       if (variable_check (get, 2, false) == FAILURE)
4497         return FAILURE;
4498
4499       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
4500         return FAILURE;
4501
4502        if (gfc_array_size (get, &get_size) == SUCCESS
4503           && mpz_get_ui (get_size) < kiss_size)
4504         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4505                    "too small (%i/%i)",
4506                    gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4507                    where, (int) mpz_get_ui (get_size), kiss_size);
4508     }
4509
4510   /* RANDOM_SEED may not have more than one non-optional argument.  */
4511   if (nargs > 1)
4512     gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
4513
4514   return SUCCESS;
4515 }
4516
4517
4518 gfc_try
4519 gfc_check_second_sub (gfc_expr *time)
4520 {
4521   if (scalar_check (time, 0) == FAILURE)
4522     return FAILURE;
4523
4524   if (type_check (time, 0, BT_REAL) == FAILURE)
4525     return FAILURE;
4526
4527   if (kind_value_check(time, 0, 4) == FAILURE)
4528     return FAILURE;
4529
4530   return SUCCESS;
4531 }
4532
4533
4534 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
4535    count, count_rate, and count_max are all optional arguments */
4536
4537 gfc_try
4538 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
4539                         gfc_expr *count_max)
4540 {
4541   if (count != NULL)
4542     {
4543       if (scalar_check (count, 0) == FAILURE)
4544         return FAILURE;
4545
4546       if (type_check (count, 0, BT_INTEGER) == FAILURE)
4547         return FAILURE;
4548
4549       if (variable_check (count, 0, false) == FAILURE)
4550         return FAILURE;
4551     }
4552
4553   if (count_rate != NULL)
4554     {
4555       if (scalar_check (count_rate, 1) == FAILURE)
4556         return FAILURE;
4557
4558       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
4559         return FAILURE;
4560
4561       if (variable_check (count_rate, 1, false) == FAILURE)
4562         return FAILURE;
4563
4564       if (count != NULL
4565           && same_type_check (count, 0, count_rate, 1) == FAILURE)
4566         return FAILURE;
4567
4568     }
4569
4570   if (count_max != NULL)
4571     {
4572       if (scalar_check (count_max, 2) == FAILURE)
4573         return FAILURE;
4574
4575       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
4576         return FAILURE;
4577
4578       if (variable_check (count_max, 2, false) == FAILURE)
4579         return FAILURE;
4580
4581       if (count != NULL
4582           && same_type_check (count, 0, count_max, 2) == FAILURE)
4583         return FAILURE;
4584
4585       if (count_rate != NULL
4586           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
4587         return FAILURE;
4588     }
4589
4590   return SUCCESS;
4591 }
4592
4593
4594 gfc_try
4595 gfc_check_irand (gfc_expr *x)
4596 {
4597   if (x == NULL)
4598     return SUCCESS;
4599
4600   if (scalar_check (x, 0) == FAILURE)
4601     return FAILURE;
4602
4603   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4604     return FAILURE;
4605
4606   if (kind_value_check(x, 0, 4) == FAILURE)
4607     return FAILURE;
4608
4609   return SUCCESS;
4610 }
4611
4612
4613 gfc_try
4614 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
4615 {
4616   if (scalar_check (seconds, 0) == FAILURE)
4617     return FAILURE;
4618   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
4619     return FAILURE;
4620
4621   if (int_or_proc_check (handler, 1) == FAILURE)
4622     return FAILURE;
4623   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4624     return FAILURE;
4625
4626   if (status == NULL)
4627     return SUCCESS;
4628
4629   if (scalar_check (status, 2) == FAILURE)
4630     return FAILURE;
4631   if (type_check (status, 2, BT_INTEGER) == FAILURE)
4632     return FAILURE;
4633   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
4634     return FAILURE;
4635
4636   return SUCCESS;
4637 }
4638
4639
4640 gfc_try
4641 gfc_check_rand (gfc_expr *x)
4642 {
4643   if (x == NULL)
4644     return SUCCESS;
4645
4646   if (scalar_check (x, 0) == FAILURE)
4647     return FAILURE;
4648
4649   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4650     return FAILURE;
4651
4652   if (kind_value_check(x, 0, 4) == FAILURE)
4653     return FAILURE;
4654
4655   return SUCCESS;
4656 }
4657
4658
4659 gfc_try
4660 gfc_check_srand (gfc_expr *x)
4661 {
4662   if (scalar_check (x, 0) == FAILURE)
4663     return FAILURE;
4664
4665   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4666     return FAILURE;
4667
4668   if (kind_value_check(x, 0, 4) == FAILURE)
4669     return FAILURE;
4670
4671   return SUCCESS;
4672 }
4673
4674
4675 gfc_try
4676 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
4677 {
4678   if (scalar_check (time, 0) == FAILURE)
4679     return FAILURE;
4680   if (type_check (time, 0, BT_INTEGER) == FAILURE)
4681     return FAILURE;
4682
4683   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
4684     return FAILURE;
4685   if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
4686     return FAILURE;
4687
4688   return SUCCESS;
4689 }
4690
4691
4692 gfc_try
4693 gfc_check_dtime_etime (gfc_expr *x)
4694 {
4695   if (array_check (x, 0) == FAILURE)
4696     return FAILURE;
4697
4698   if (rank_check (x, 0, 1) == FAILURE)
4699     return FAILURE;
4700
4701   if (variable_check (x, 0, false) == FAILURE)
4702     return FAILURE;
4703
4704   if (type_check (x, 0, BT_REAL) == FAILURE)
4705     return FAILURE;
4706
4707   if (kind_value_check(x, 0, 4) == FAILURE)
4708     return FAILURE;
4709
4710   return SUCCESS;
4711 }
4712
4713
4714 gfc_try
4715 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
4716 {
4717   if (array_check (values, 0) == FAILURE)
4718     return FAILURE;
4719
4720   if (rank_check (values, 0, 1) == FAILURE)
4721     return FAILURE;
4722
4723   if (variable_check (values, 0, false) == FAILURE)
4724     return FAILURE;
4725
4726   if (type_check (values, 0, BT_REAL) == FAILURE)
4727     return FAILURE;
4728
4729   if (kind_value_check(values, 0, 4) == FAILURE)
4730     return FAILURE;
4731
4732   if (scalar_check (time, 1) == FAILURE)
4733     return FAILURE;
4734
4735   if (type_check (time, 1, BT_REAL) == FAILURE)
4736     return FAILURE;
4737
4738   if (kind_value_check(time, 1, 4) == FAILURE)
4739     return FAILURE;
4740
4741   return SUCCESS;
4742 }
4743
4744
4745 gfc_try
4746 gfc_check_fdate_sub (gfc_expr *date)
4747 {
4748   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4749     return FAILURE;
4750   if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4751     return FAILURE;
4752
4753   return SUCCESS;
4754 }
4755
4756
4757 gfc_try
4758 gfc_check_gerror (gfc_expr *msg)
4759 {
4760   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4761     return FAILURE;
4762   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4763     return FAILURE;
4764
4765   return SUCCESS;
4766 }
4767
4768
4769 gfc_try
4770 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4771 {
4772   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4773     return FAILURE;
4774   if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4775     return FAILURE;
4776
4777   if (status == NULL)
4778     return SUCCESS;
4779
4780   if (scalar_check (status, 1) == FAILURE)
4781     return FAILURE;
4782
4783   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4784     return FAILURE;
4785
4786   return SUCCESS;
4787 }
4788
4789
4790 gfc_try
4791 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4792 {
4793   if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4794     return FAILURE;
4795
4796   if (pos->ts.kind > gfc_default_integer_kind)
4797     {
4798       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4799                  "not wider than the default kind (%d)",
4800                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4801                  &pos->where, gfc_default_integer_kind);
4802       return FAILURE;
4803     }
4804
4805   if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4806     return FAILURE;
4807   if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4808     return FAILURE;
4809
4810   return SUCCESS;
4811 }
4812
4813
4814 gfc_try
4815 gfc_check_getlog (gfc_expr *msg)
4816 {
4817   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4818     return FAILURE;
4819   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4820     return FAILURE;
4821
4822   return SUCCESS;
4823 }
4824
4825
4826 gfc_try
4827 gfc_check_exit (gfc_expr *status)
4828 {
4829   if (status == NULL)
4830     return SUCCESS;
4831
4832   if (type_check (status, 0, BT_INTEGER) == FAILURE)
4833     return FAILURE;
4834
4835   if (scalar_check (status, 0) == FAILURE)
4836     return FAILURE;
4837
4838   return SUCCESS;
4839 }
4840
4841
4842 gfc_try
4843 gfc_check_flush (gfc_expr *unit)
4844 {
4845   if (unit == NULL)
4846     return SUCCESS;
4847
4848   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4849     return FAILURE;
4850
4851   if (scalar_check (unit, 0) == FAILURE)
4852     return FAILURE;
4853
4854   return SUCCESS;
4855 }
4856
4857
4858 gfc_try
4859 gfc_check_free (gfc_expr *i)
4860 {
4861   if (type_check (i, 0, BT_INTEGER) == FAILURE)
4862     return FAILURE;
4863
4864   if (scalar_check (i, 0) == FAILURE)
4865     return FAILURE;
4866
4867   return SUCCESS;
4868 }
4869
4870
4871 gfc_try
4872 gfc_check_hostnm (gfc_expr *name)
4873 {
4874   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4875     return FAILURE;
4876   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4877     return FAILURE;
4878
4879   return SUCCESS;
4880 }
4881
4882
4883 gfc_try
4884 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4885 {
4886   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4887     return FAILURE;
4888   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4889     return FAILURE;
4890
4891   if (status == NULL)
4892     return SUCCESS;
4893
4894   if (scalar_check (status, 1) == FAILURE)
4895     return FAILURE;
4896
4897   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4898     return FAILURE;
4899
4900   return SUCCESS;
4901 }
4902
4903
4904 gfc_try
4905 gfc_check_itime_idate (gfc_expr *values)
4906 {
4907   if (array_check (values, 0) == FAILURE)
4908     return FAILURE;
4909
4910   if (rank_check (values, 0, 1) == FAILURE)
4911     return FAILURE;
4912
4913   if (variable_check (values, 0, false) == FAILURE)
4914     return FAILURE;
4915
4916   if (type_check (values, 0, BT_INTEGER) == FAILURE)
4917     return FAILURE;
4918
4919   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4920     return FAILURE;
4921
4922   return SUCCESS;
4923 }
4924
4925
4926 gfc_try
4927 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4928 {
4929   if (type_check (time, 0, BT_INTEGER) == FAILURE)
4930     return FAILURE;
4931
4932   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4933     return FAILURE;
4934
4935   if (scalar_check (time, 0) == FAILURE)
4936     return FAILURE;
4937
4938   if (array_check (values, 1) == FAILURE)
4939     return FAILURE;
4940
4941   if (rank_check (values, 1, 1) == FAILURE)
4942     return FAILURE;
4943
4944   if (variable_check (values, 1, false) == FAILURE)
4945     return FAILURE;
4946
4947   if (type_check (values, 1, BT_INTEGER) == FAILURE)
4948     return FAILURE;
4949
4950   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4951     return FAILURE;
4952
4953   return SUCCESS;
4954 }
4955
4956
4957 gfc_try
4958 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4959 {
4960   if (scalar_check (unit, 0) == FAILURE)
4961     return FAILURE;
4962
4963   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4964     return FAILURE;
4965
4966   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4967     return FAILURE;
4968   if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4969     return FAILURE;
4970
4971   return SUCCESS;
4972 }
4973
4974
4975 gfc_try
4976 gfc_check_isatty (gfc_expr *unit)
4977 {
4978   if (unit == NULL)
4979     return FAILURE;
4980
4981   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4982     return FAILURE;
4983
4984   if (scalar_check (unit, 0) == FAILURE)
4985     return FAILURE;
4986
4987   return SUCCESS;
4988 }
4989
4990
4991 gfc_try
4992 gfc_check_isnan (gfc_expr *x)
4993 {
4994   if (type_check (x, 0, BT_REAL) == FAILURE)
4995     return FAILURE;
4996
4997   return SUCCESS;
4998 }
4999
5000
5001 gfc_try
5002 gfc_check_perror (gfc_expr *string)
5003 {
5004   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
5005     return FAILURE;
5006   if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
5007     return FAILURE;
5008
5009   return SUCCESS;
5010 }
5011
5012
5013 gfc_try
5014 gfc_check_umask (gfc_expr *mask)
5015 {
5016   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5017     return FAILURE;
5018
5019   if (scalar_check (mask, 0) == FAILURE)
5020     return FAILURE;
5021
5022   return SUCCESS;
5023 }
5024
5025
5026 gfc_try
5027 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
5028 {
5029   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5030     return FAILURE;
5031
5032   if (scalar_check (mask, 0) == FAILURE)
5033     return FAILURE;
5034
5035   if (old == NULL)
5036     return SUCCESS;
5037
5038   if (scalar_check (old, 1) == FAILURE)
5039     return FAILURE;
5040
5041   if (type_check (old, 1, BT_INTEGER) == FAILURE)
5042     return FAILURE;
5043
5044   return SUCCESS;
5045 }
5046
5047
5048 gfc_try
5049 gfc_check_unlink (gfc_expr *name)
5050 {
5051   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5052     return FAILURE;
5053   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5054     return FAILURE;
5055
5056   return SUCCESS;
5057 }
5058
5059
5060 gfc_try
5061 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
5062 {
5063   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5064     return FAILURE;
5065   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5066     return FAILURE;
5067
5068   if (status == NULL)
5069     return SUCCESS;
5070
5071   if (scalar_check (status, 1) == FAILURE)
5072     return FAILURE;
5073
5074   if (type_check (status, 1, BT_INTEGER) == FAILURE)
5075     return FAILURE;
5076
5077   return SUCCESS;
5078 }
5079
5080
5081 gfc_try
5082 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
5083 {
5084   if (scalar_check (number, 0) == FAILURE)
5085     return FAILURE;
5086   if (type_check (number, 0, BT_INTEGER) == FAILURE)
5087     return FAILURE;
5088
5089   if (int_or_proc_check (handler, 1) == FAILURE)
5090     return FAILURE;
5091   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5092     return FAILURE;
5093
5094   return SUCCESS;
5095 }
5096
5097
5098 gfc_try
5099 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
5100 {
5101   if (scalar_check (number, 0) == FAILURE)
5102     return FAILURE;
5103   if (type_check (number, 0, BT_INTEGER) == FAILURE)
5104     return FAILURE;
5105
5106   if (int_or_proc_check (handler, 1) == FAILURE)
5107     return FAILURE;
5108   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5109     return FAILURE;
5110
5111   if (status == NULL)
5112     return SUCCESS;
5113
5114   if (type_check (status, 2, BT_INTEGER) == FAILURE)
5115     return FAILURE;
5116   if (scalar_check (status, 2) == FAILURE)
5117     return FAILURE;
5118
5119   return SUCCESS;
5120 }
5121
5122
5123 gfc_try
5124 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
5125 {
5126   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
5127     return FAILURE;
5128   if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
5129     return FAILURE;
5130
5131   if (scalar_check (status, 1) == FAILURE)
5132     return FAILURE;
5133
5134   if (type_check (status, 1, BT_INTEGER) == FAILURE)
5135     return FAILURE;
5136
5137   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
5138     return FAILURE;
5139
5140   return SUCCESS;
5141 }
5142
5143
5144 /* This is used for the GNU intrinsics AND, OR and XOR.  */
5145 gfc_try
5146 gfc_check_and (gfc_expr *i, gfc_expr *j)
5147 {
5148   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
5149     {
5150       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5151                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
5152                  gfc_current_intrinsic, &i->where);
5153       return FAILURE;
5154     }
5155
5156   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
5157     {
5158       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5159                  "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
5160                  gfc_current_intrinsic, &j->where);
5161       return FAILURE;
5162     }
5163
5164   if (i->ts.type != j->ts.type)
5165     {
5166       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5167                  "have the same type", gfc_current_intrinsic_arg[0]->name,
5168                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5169                  &j->where);
5170       return FAILURE;
5171     }
5172
5173   if (scalar_check (i, 0) == FAILURE)
5174     return FAILURE;
5175
5176   if (scalar_check (j, 1) == FAILURE)
5177     return FAILURE;
5178
5179   return SUCCESS;
5180 }
5181
5182
5183 gfc_try
5184 gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
5185 {
5186   if (kind == NULL)
5187     return SUCCESS;
5188
5189   if (type_check (kind, 1, BT_INTEGER) == FAILURE)
5190     return FAILURE;
5191
5192   if (scalar_check (kind, 1) == FAILURE)
5193     return FAILURE;
5194
5195   if (kind->expr_type != EXPR_CONSTANT)
5196     {
5197       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5198                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5199                  &kind->where);
5200       return FAILURE;
5201     }
5202
5203   return SUCCESS;
5204 }