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