gcc/fortran/check.c

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