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