gcc/fortran/check.c

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