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