gcc/fortran/check.c

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