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