gcc/fortran/check.c

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