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