gcc/fortran/check.c

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