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