gcc/fortran/check.c

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