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