gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught & Katherine Holcomb
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.  */
  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 /* Check the type of an expression.  */
  37
  38 static try
  39 type_check (gfc_expr * e, int n, bt type)
  40 {
  41   if (e->ts.type == type)
  42     return SUCCESS;
  43
  44   gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
  45              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
  46              gfc_basic_typename (type));
  47
  48   return FAILURE;
  49 }
  50
  51
  52 /* Check that the expression is a numeric type.  */
  53
  54 static try
  55 numeric_check (gfc_expr * e, int n)
  56 {
  57   if (gfc_numeric_ts (&e->ts))
  58     return SUCCESS;
  59
  60   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
  61              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
  62
  63   return FAILURE;
  64 }
  65
  66
  67 /* Check that an expression is integer or real.  */
  68
  69 static try
  70 int_or_real_check (gfc_expr * e, int n)
  71 {
  72   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
  73     {
  74       gfc_error (
  75         "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
  76         gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
  77       return FAILURE;
  78     }
  79
  80   return SUCCESS;
  81 }
  82
  83
  84 /* Check that an expression is real or complex.  */
  85
  86 static try
  87 real_or_complex_check (gfc_expr * e, int n)
  88 {
  89   if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
  90     {
  91       gfc_error (
  92         "'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
  93         gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
  94       return FAILURE;
  95     }
  96
  97   return SUCCESS;
  98 }
  99
 100
 101 /* Check that the expression is an optional constant integer
 102    and that it specifies a valid kind for that type.  */
 103
 104 static try
 105 kind_check (gfc_expr * k, int n, bt type)
 106 {
 107   int kind;
 108
 109   if (k == NULL)
 110     return SUCCESS;
 111
 112   if (type_check (k, n, BT_INTEGER) == FAILURE)
 113     return FAILURE;
 114
 115   if (k->expr_type != EXPR_CONSTANT)
 116     {
 117       gfc_error (
 118         "'%s' argument of '%s' intrinsic at %L must be a constant",
 119         gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
 120       return FAILURE;
 121     }
 122
 123   if (gfc_extract_int (k, &kind) != NULL
 124       || gfc_validate_kind (type, kind, true) < 0)
 125     {
 126       gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
 127                  &k->where);
 128       return FAILURE;
 129     }
 130
 131   return SUCCESS;
 132 }
 133
 134
 135 /* Make sure the expression is a double precision real.  */
 136
 137 static try
 138 double_check (gfc_expr * d, int n)
 139 {
 140   if (type_check (d, n, BT_REAL) == FAILURE)
 141     return FAILURE;
 142
 143   if (d->ts.kind != gfc_default_double_kind)
 144     {
 145       gfc_error (
 146         "'%s' argument of '%s' intrinsic at %L must be double precision",
 147         gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
 148       return FAILURE;
 149     }
 150
 151   return SUCCESS;
 152 }
 153
 154
 155 /* Make sure the expression is a logical array.  */
 156
 157 static try
 158 logical_array_check (gfc_expr * array, int n)
 159 {
 160   if (array->ts.type != BT_LOGICAL || array->rank == 0)
 161     {
 162       gfc_error (
 163         "'%s' argument of '%s' intrinsic at %L must be a logical array",
 164         gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
 165       return FAILURE;
 166     }
 167
 168   return SUCCESS;
 169 }
 170
 171
 172 /* Make sure an expression is an array.  */
 173
 174 static try
 175 array_check (gfc_expr * e, int n)
 176 {
 177   if (e->rank != 0)
 178     return SUCCESS;
 179
 180   gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
 181              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 182
 183   return FAILURE;
 184 }
 185
 186
 187 /* Make sure an expression is a scalar.  */
 188
 189 static try
 190 scalar_check (gfc_expr * e, int n)
 191 {
 192   if (e->rank == 0)
 193     return SUCCESS;
 194
 195   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
 196              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 197
 198   return FAILURE;
 199 }
 200
 201
 202 /* Make sure two expression have the same type.  */
 203
 204 static try
 205 same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
 206 {
 207   if (gfc_compare_types (&e->ts, &f->ts))
 208     return SUCCESS;
 209
 210   gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
 211              "and kind as '%s'", gfc_current_intrinsic_arg[m],
 212              gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
 213   return FAILURE;
 214 }
 215
 216
 217 /* Make sure that an expression has a certain (nonzero) rank.  */
 218
 219 static try
 220 rank_check (gfc_expr * e, int n, int rank)
 221 {
 222   if (e->rank == rank)
 223     return SUCCESS;
 224
 225   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
 226              gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 227              &e->where, rank);
 228   return FAILURE;
 229 }
 230
 231
 232 /* Make sure a variable expression is not an optional dummy argument.  */
 233
 234 static try
 235 nonoptional_check (gfc_expr * e, int n)
 236 {
 237   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
 238     {
 239       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
 240                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 241                  &e->where);
 242
 243     }
 244
 245   /* TODO: Recursive check on nonoptional variables?  */
 246
 247   return SUCCESS;
 248 }
 249
 250
 251 /* Check that an expression has a particular kind.  */
 252
 253 static try
 254 kind_value_check (gfc_expr * e, int n, int k)
 255 {
 256   if (e->ts.kind == k)
 257     return SUCCESS;
 258
 259   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
 260              gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 261              &e->where, k);
 262   return FAILURE;
 263 }
 264
 265
 266 /* Make sure an expression is a variable.  */
 267
 268 static try
 269 variable_check (gfc_expr * e, int n)
 270 {
 271   if ((e->expr_type == EXPR_VARIABLE
 272        && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
 273       || (e->expr_type == EXPR_FUNCTION
 274           && e->symtree->n.sym->result == e->symtree->n.sym))
 275     return SUCCESS;
 276
 277   if (e->expr_type == EXPR_VARIABLE
 278       && e->symtree->n.sym->attr.intent == INTENT_IN)
 279     {
 280       gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
 281                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 282                  &e->where);
 283       return FAILURE;
 284     }
 285
 286   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
 287              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 288
 289   return FAILURE;
 290 }
 291
 292
 293 /* Check the common DIM parameter for correctness.  */
 294
 295 static try
 296 dim_check (gfc_expr * dim, int n, int optional)
 297 {
 298   if (optional && dim == NULL)
 299     return SUCCESS;
 300
 301   if (dim == NULL)
 302     {
 303       gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
 304                  gfc_current_intrinsic, gfc_current_intrinsic_where);
 305       return FAILURE;
 306     }
 307
 308   if (type_check (dim, n, BT_INTEGER) == FAILURE)
 309     return FAILURE;
 310
 311   if (scalar_check (dim, n) == FAILURE)
 312     return FAILURE;
 313
 314   if (nonoptional_check (dim, n) == FAILURE)
 315     return FAILURE;
 316
 317   return SUCCESS;
 318 }
 319
 320
 321 /* If a DIM parameter is a constant, make sure that it is greater than
 322    zero and less than or equal to the rank of the given array.  If
 323    allow_assumed is zero then dim must be less than the rank of the array
 324    for assumed size arrays.  */
 325
 326 static try
 327 dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
 328 {
 329   gfc_array_ref *ar;
 330   int rank;
 331
 332   if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
 333     return SUCCESS;
 334
 335   ar = gfc_find_array_ref (array);
 336   rank = array->rank;
 337   if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
 338     rank--;
 339
 340   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 341       || mpz_cmp_ui (dim->value.integer, rank) > 0)
 342     {
 343       gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
 344                  "dimension index", gfc_current_intrinsic, &dim->where);
 345
 346       return FAILURE;
 347     }
 348
 349   return SUCCESS;
 350 }
 351
 352 /* Compare the size of a along dimension ai with the size of b along
 353    dimension bi, returning 0 if they are known not to be identical,
 354    and 1 if they are identical, or if this cannot be determined.  */
 355
 356 static int
 357 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 358 {
 359   mpz_t a_size, b_size;
 360   int ret;
 361
 362   gcc_assert (a->rank > ai);
 363   gcc_assert (b->rank > bi);
 364
 365   ret = 1;
 366
 367   if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
 368     {
 369       if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
 370         {
 371           if (mpz_cmp (a_size, b_size) != 0)
 372             ret = 0;
 373
 374           mpz_clear (b_size);
 375         }
 376       mpz_clear (a_size);
 377     }
 378   return ret;
 379 }
 380
 381 /***** Check functions *****/
 382
 383 /* Check subroutine suitable for intrinsics taking a real argument and
 384    a kind argument for the result.  */
 385
 386 static try
 387 check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
 388 {
 389   if (type_check (a, 0, BT_REAL) == FAILURE)
 390     return FAILURE;
 391   if (kind_check (kind, 1, type) == FAILURE)
 392     return FAILURE;
 393
 394   return SUCCESS;
 395 }
 396
 397 /* Check subroutine suitable for ceiling, floor and nint.  */
 398
 399 try
 400 gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
 401 {
 402   return check_a_kind (a, kind, BT_INTEGER);
 403 }
 404
 405 /* Check subroutine suitable for aint, anint.  */
 406
 407 try
 408 gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
 409 {
 410   return check_a_kind (a, kind, BT_REAL);
 411 }
 412
 413 try
 414 gfc_check_abs (gfc_expr * a)
 415 {
 416   if (numeric_check (a, 0) == FAILURE)
 417     return FAILURE;
 418
 419   return SUCCESS;
 420 }
 421
 422 try
 423 gfc_check_achar (gfc_expr * a)
 424 {
 425
 426   if (type_check (a, 0, BT_INTEGER) == FAILURE)
 427     return FAILURE;
 428
 429   return SUCCESS;
 430 }
 431
 432
 433 try
 434 gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
 435 {
 436   if (logical_array_check (mask, 0) == FAILURE)
 437     return FAILURE;
 438
 439   if (dim_check (dim, 1, 1) == FAILURE)
 440     return FAILURE;
 441
 442   return SUCCESS;
 443 }
 444
 445
 446 try
 447 gfc_check_allocated (gfc_expr * array)
 448 {
 449   if (variable_check (array, 0) == FAILURE)
 450     return FAILURE;
 451
 452   if (array_check (array, 0) == FAILURE)
 453     return FAILURE;
 454
 455   if (!array->symtree->n.sym->attr.allocatable)
 456     {
 457       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
 458                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 459                  &array->where);
 460       return FAILURE;
 461     }
 462
 463   return SUCCESS;
 464 }
 465
 466
 467 /* Common check function where the first argument must be real or
 468    integer and the second argument must be the same as the first.  */
 469
 470 try
 471 gfc_check_a_p (gfc_expr * a, gfc_expr * p)
 472 {
 473   if (int_or_real_check (a, 0) == FAILURE)
 474     return FAILURE;
 475
 476   if (a->ts.type != p->ts.type)
 477     {
 478       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
 479                 "have the same type", gfc_current_intrinsic_arg[0],
 480                 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
 481                 &p->where);
 482       return FAILURE;
 483     }
 484
 485   if (a->ts.kind != p->ts.kind)
 486     {
 487       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 488                           &p->where) == FAILURE)
 489        return FAILURE;
 490     }
 491
 492   return SUCCESS;
 493 }
 494
 495
 496 try
 497 gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
 498 {
 499   symbol_attribute attr;
 500   int i;
 501   try t;
 502
 503   if (pointer->expr_type == EXPR_VARIABLE)
 504     attr = gfc_variable_attr (pointer, NULL);
 505   else if (pointer->expr_type == EXPR_FUNCTION)
 506     attr = pointer->symtree->n.sym->attr;
 507   else
 508     gcc_assert (0); /* Pointer must be a variable or a function.  */
 509
 510   if (!attr.pointer)
 511     {
 512       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
 513                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 514                  &pointer->where);
 515       return FAILURE;
 516     }
 517
 518   /* Target argument is optional.  */
 519   if (target == NULL)
 520     return SUCCESS;
 521
 522   if (target->expr_type == EXPR_NULL)
 523     {
 524       gfc_error ("NULL pointer at %L is not permitted as actual argument "
 525                  "of '%s' intrinsic function",
 526                  &target->where, gfc_current_intrinsic);
 527       return FAILURE;
 528     }
 529
 530   if (target->expr_type == EXPR_VARIABLE)
 531     attr = gfc_variable_attr (target, NULL);
 532   else if (target->expr_type == EXPR_FUNCTION)
 533     attr = target->symtree->n.sym->attr;
 534   else
 535     {
 536       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
 537                  "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
 538                  gfc_current_intrinsic, &target->where);
 539       return FAILURE;
 540     }
 541
 542   if (!attr.pointer && !attr.target)
 543     {
 544       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
 545                  "or a TARGET", gfc_current_intrinsic_arg[1],
 546                  gfc_current_intrinsic, &target->where);
 547       return FAILURE;
 548     }
 549
 550   t = SUCCESS;
 551   if (same_type_check (pointer, 0, target, 1) == FAILURE)
 552     t = FAILURE;
 553   if (rank_check (target, 0, pointer->rank) == FAILURE)
 554     t = FAILURE;
 555   if (target->rank > 0)
 556     {
 557       for (i = 0; i < target->rank; i++)
 558         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 559           {
 560             gfc_error ("Array section with a vector subscript at %L shall not "
 561                        "be the target of a pointer",
 562                        &target->where);
 563             t = FAILURE;
 564             break;
 565           }
 566     }
 567   return t;
 568 }
 569
 570
 571 try
 572 gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
 573 {
 574   if (type_check (y, 0, BT_REAL) == FAILURE)
 575     return FAILURE;
 576   if (same_type_check (y, 0, x, 1) == FAILURE)
 577     return FAILURE;
 578
 579   return SUCCESS;
 580 }
 581
 582
 583 /* BESJN and BESYN functions.  */
 584
 585 try
 586 gfc_check_besn (gfc_expr * n, gfc_expr * x)
 587 {
 588   if (scalar_check (n, 0) == FAILURE)
 589     return FAILURE;
 590
 591   if (type_check (n, 0, BT_INTEGER) == FAILURE)
 592     return FAILURE;
 593
 594   if (scalar_check (x, 1) == FAILURE)
 595     return FAILURE;
 596
 597   if (type_check (x, 1, BT_REAL) == FAILURE)
 598     return FAILURE;
 599
 600   return SUCCESS;
 601 }
 602
 603
 604 try
 605 gfc_check_btest (gfc_expr * i, gfc_expr * pos)
 606 {
 607   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 608     return FAILURE;
 609   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 610     return FAILURE;
 611
 612   return SUCCESS;
 613 }
 614
 615
 616 try
 617 gfc_check_char (gfc_expr * i, gfc_expr * kind)
 618 {
 619   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 620     return FAILURE;
 621   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 622     return FAILURE;
 623
 624   return SUCCESS;
 625 }
 626
 627
 628 try
 629 gfc_check_chdir (gfc_expr * dir)
 630 {
 631   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 632     return FAILURE;
 633
 634   return SUCCESS;
 635 }
 636
 637
 638 try
 639 gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
 640 {
 641   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 642     return FAILURE;
 643
 644   if (status == NULL)
 645     return SUCCESS;
 646
 647   if (type_check (status, 1, BT_INTEGER) == FAILURE)
 648     return FAILURE;
 649
 650   if (scalar_check (status, 1) == FAILURE)
 651     return FAILURE;
 652
 653   return SUCCESS;
 654 }
 655
 656
 657 try
 658 gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 659 {
 660   if (numeric_check (x, 0) == FAILURE)
 661     return FAILURE;
 662
 663   if (y != NULL)
 664     {
 665       if (numeric_check (y, 1) == FAILURE)
 666         return FAILURE;
 667
 668       if (x->ts.type == BT_COMPLEX)
 669         {
 670           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 671                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 672                      gfc_current_intrinsic, &y->where);
 673           return FAILURE;
 674         }
 675     }
 676
 677   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 678     return FAILURE;
 679
 680   return SUCCESS;
 681 }
 682
 683
 684 try
 685 gfc_check_complex (gfc_expr * x, gfc_expr * y)
 686 {
 687   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
 688     {
 689       gfc_error (
 690         "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
 691         gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
 692       return FAILURE;
 693     }
 694   if (scalar_check (x, 0) == FAILURE)
 695     return FAILURE;
 696
 697   if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
 698     {
 699       gfc_error (
 700         "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
 701         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
 702       return FAILURE;
 703     }
 704   if (scalar_check (y, 1) == FAILURE)
 705     return FAILURE;
 706
 707   return SUCCESS;
 708 }
 709
 710
 711 try
 712 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
 713 {
 714   if (logical_array_check (mask, 0) == FAILURE)
 715     return FAILURE;
 716   if (dim_check (dim, 1, 1) == FAILURE)
 717     return FAILURE;
 718
 719   return SUCCESS;
 720 }
 721
 722
 723 try
 724 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
 725 {
 726   if (array_check (array, 0) == FAILURE)
 727     return FAILURE;
 728
 729   if (array->rank == 1)
 730     {
 731       if (scalar_check (shift, 1) == FAILURE)
 732         return FAILURE;
 733     }
 734   else
 735     {
 736       /* TODO: more requirements on shift parameter.  */
 737     }
 738
 739   if (dim_check (dim, 2, 1) == FAILURE)
 740     return FAILURE;
 741
 742   return SUCCESS;
 743 }
 744
 745
 746 try
 747 gfc_check_ctime (gfc_expr * time)
 748 {
 749   if (scalar_check (time, 0) == FAILURE)
 750     return FAILURE;
 751
 752   if (type_check (time, 0, BT_INTEGER) == FAILURE)
 753     return FAILURE;
 754
 755   return SUCCESS;
 756 }
 757
 758
 759 try
 760 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 761 {
 762   if (numeric_check (x, 0) == FAILURE)
 763     return FAILURE;
 764
 765   if (y != NULL)
 766     {
 767       if (numeric_check (y, 1) == FAILURE)
 768         return FAILURE;
 769
 770       if (x->ts.type == BT_COMPLEX)
 771         {
 772           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 773                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 774                      gfc_current_intrinsic, &y->where);
 775           return FAILURE;
 776         }
 777     }
 778
 779   return SUCCESS;
 780 }
 781
 782
 783 try
 784 gfc_check_dble (gfc_expr * x)
 785 {
 786   if (numeric_check (x, 0) == FAILURE)
 787     return FAILURE;
 788
 789   return SUCCESS;
 790 }
 791
 792
 793 try
 794 gfc_check_digits (gfc_expr * x)
 795 {
 796   if (int_or_real_check (x, 0) == FAILURE)
 797     return FAILURE;
 798
 799   return SUCCESS;
 800 }
 801
 802
 803 try
 804 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
 805 {
 806   switch (vector_a->ts.type)
 807     {
 808     case BT_LOGICAL:
 809       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 810         return FAILURE;
 811       break;
 812
 813     case BT_INTEGER:
 814     case BT_REAL:
 815     case BT_COMPLEX:
 816       if (numeric_check (vector_b, 1) == FAILURE)
 817         return FAILURE;
 818       break;
 819
 820     default:
 821       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
 822                  "or LOGICAL", gfc_current_intrinsic_arg[0],
 823                  gfc_current_intrinsic, &vector_a->where);
 824       return FAILURE;
 825     }
 826
 827   if (rank_check (vector_a, 0, 1) == FAILURE)
 828     return FAILURE;
 829
 830   if (rank_check (vector_b, 1, 1) == FAILURE)
 831     return FAILURE;
 832
 833   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
 834     {
 835       gfc_error ("different shape for arguments '%s' and '%s' "
 836                  "at %L for intrinsic 'dot_product'",
 837                  gfc_current_intrinsic_arg[0],
 838                  gfc_current_intrinsic_arg[1],
 839                  &vector_a->where);
 840       return FAILURE;
 841     }
 842
 843   return SUCCESS;
 844 }
 845
 846
 847 try
 848 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
 849                    gfc_expr * dim)
 850 {
 851   if (array_check (array, 0) == FAILURE)
 852     return FAILURE;
 853
 854   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 855     return FAILURE;
 856
 857   if (array->rank == 1)
 858     {
 859       if (scalar_check (shift, 2) == FAILURE)
 860         return FAILURE;
 861     }
 862   else
 863     {
 864       /* TODO: more weird restrictions on shift.  */
 865     }
 866
 867   if (boundary != NULL)
 868     {
 869       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 870         return FAILURE;
 871
 872       /* TODO: more restrictions on boundary.  */
 873     }
 874
 875   if (dim_check (dim, 1, 1) == FAILURE)
 876     return FAILURE;
 877
 878   return SUCCESS;
 879 }
 880
 881
 882 /* A single complex argument.  */
 883
 884 try
 885 gfc_check_fn_c (gfc_expr * a)
 886 {
 887   if (type_check (a, 0, BT_COMPLEX) == FAILURE)
 888     return FAILURE;
 889
 890   return SUCCESS;
 891 }
 892
 893
 894 /* A single real argument.  */
 895
 896 try
 897 gfc_check_fn_r (gfc_expr * a)
 898 {
 899   if (type_check (a, 0, BT_REAL) == FAILURE)
 900     return FAILURE;
 901
 902   return SUCCESS;
 903 }
 904
 905
 906 /* A single real or complex argument.  */
 907
 908 try
 909 gfc_check_fn_rc (gfc_expr * a)
 910 {
 911   if (real_or_complex_check (a, 0) == FAILURE)
 912     return FAILURE;
 913
 914   return SUCCESS;
 915 }
 916
 917
 918 try
 919 gfc_check_fnum (gfc_expr * unit)
 920 {
 921   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
 922     return FAILURE;
 923
 924   if (scalar_check (unit, 0) == FAILURE)
 925     return FAILURE;
 926
 927   return SUCCESS;
 928 }
 929
 930
 931 /* This is used for the g77 one-argument Bessel functions, and the
 932    error function.  */
 933
 934 try
 935 gfc_check_g77_math1 (gfc_expr * x)
 936 {
 937   if (scalar_check (x, 0) == FAILURE)
 938     return FAILURE;
 939
 940   if (type_check (x, 0, BT_REAL) == FAILURE)
 941     return FAILURE;
 942
 943   return SUCCESS;
 944 }
 945
 946
 947 try
 948 gfc_check_huge (gfc_expr * x)
 949 {
 950   if (int_or_real_check (x, 0) == FAILURE)
 951     return FAILURE;
 952
 953   return SUCCESS;
 954 }
 955
 956
 957 /* Check that the single argument is an integer.  */
 958
 959 try
 960 gfc_check_i (gfc_expr * i)
 961 {
 962   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 963     return FAILURE;
 964
 965   return SUCCESS;
 966 }
 967
 968
 969 try
 970 gfc_check_iand (gfc_expr * i, gfc_expr * j)
 971 {
 972   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 973     return FAILURE;
 974
 975   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 976     return FAILURE;
 977
 978   if (i->ts.kind != j->ts.kind)
 979     {
 980       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 981                           &i->where) == FAILURE)
 982         return FAILURE;
 983     }
 984
 985   return SUCCESS;
 986 }
 987
 988
 989 try
 990 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
 991 {
 992   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 993     return FAILURE;
 994
 995   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 996     return FAILURE;
 997
 998   return SUCCESS;
 999 }
1000
1001
1002 try
1003 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
1004 {
1005   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1006     return FAILURE;
1007
1008   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1009     return FAILURE;
1010
1011   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1012     return FAILURE;
1013
1014   return SUCCESS;
1015 }
1016
1017
1018 try
1019 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
1020 {
1021   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1022     return FAILURE;
1023
1024   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1025     return FAILURE;
1026
1027   return SUCCESS;
1028 }
1029
1030
1031 try
1032 gfc_check_ichar_iachar (gfc_expr * c)
1033 {
1034   int i;
1035
1036   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1037     return FAILURE;
1038
1039   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1040     {
1041       gfc_expr *start;
1042       gfc_expr *end;
1043       gfc_ref *ref;
1044
1045       /* Substring references don't have the charlength set.  */
1046       ref = c->ref;
1047       while (ref && ref->type != REF_SUBSTRING)
1048         ref = ref->next;
1049
1050       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1051
1052       if (!ref)
1053         {
1054           /* Check that the argument is length one.  Non-constant lengths
1055              can't be checked here, so assume thay are ok.  */
1056           if (c->ts.cl && c->ts.cl->length)
1057             {
1058               /* If we already have a length for this expression then use it.  */
1059               if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1060                 return SUCCESS;
1061               i = mpz_get_si (c->ts.cl->length->value.integer);
1062             }
1063           else
1064             return SUCCESS;
1065         }
1066       else
1067         {
1068           start = ref->u.ss.start;
1069           end = ref->u.ss.end;
1070
1071           gcc_assert (start);
1072           if (end == NULL || end->expr_type != EXPR_CONSTANT
1073               || start->expr_type != EXPR_CONSTANT)
1074             return SUCCESS;
1075
1076           i = mpz_get_si (end->value.integer) + 1
1077               - mpz_get_si (start->value.integer);
1078         }
1079     }
1080   else
1081     return SUCCESS;
1082
1083   if (i != 1)
1084     {
1085       gfc_error ("Argument of %s at %L must be of length one",
1086                  gfc_current_intrinsic, &c->where);
1087       return FAILURE;
1088     }
1089
1090   return SUCCESS;
1091 }
1092
1093
1094 try
1095 gfc_check_idnint (gfc_expr * a)
1096 {
1097   if (double_check (a, 0) == FAILURE)
1098     return FAILURE;
1099
1100   return SUCCESS;
1101 }
1102
1103
1104 try
1105 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
1106 {
1107   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1108     return FAILURE;
1109
1110   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1111     return FAILURE;
1112
1113   if (i->ts.kind != j->ts.kind)
1114     {
1115       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1116                           &i->where) == FAILURE)
1117         return FAILURE;
1118     }
1119
1120   return SUCCESS;
1121 }
1122
1123
1124 try
1125 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
1126 {
1127   if (type_check (string, 0, BT_CHARACTER) == FAILURE
1128       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1129     return FAILURE;
1130
1131
1132   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1133     return FAILURE;
1134
1135   if (string->ts.kind != substring->ts.kind)
1136     {
1137       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1138                  "kind as '%s'", gfc_current_intrinsic_arg[1],
1139                  gfc_current_intrinsic, &substring->where,
1140                  gfc_current_intrinsic_arg[0]);
1141       return FAILURE;
1142     }
1143
1144   return SUCCESS;
1145 }
1146
1147
1148 try
1149 gfc_check_int (gfc_expr * x, gfc_expr * kind)
1150 {
1151   if (numeric_check (x, 0) == FAILURE)
1152     return FAILURE;
1153
1154   if (kind != NULL)
1155     {
1156       if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1157     return FAILURE;
1158
1159       if (scalar_check (kind, 1) == FAILURE)
1160         return FAILURE;
1161     }
1162
1163   return SUCCESS;
1164 }
1165
1166
1167 try
1168 gfc_check_ior (gfc_expr * i, gfc_expr * j)
1169 {
1170   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1171     return FAILURE;
1172
1173   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1174     return FAILURE;
1175
1176   if (i->ts.kind != j->ts.kind)
1177     {
1178       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1179                           &i->where) == FAILURE)
1180     return FAILURE;
1181     }
1182
1183   return SUCCESS;
1184 }
1185
1186
1187 try
1188 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
1189 {
1190   if (type_check (i, 0, BT_INTEGER) == FAILURE
1191       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1192     return FAILURE;
1193
1194   return SUCCESS;
1195 }
1196
1197
1198 try
1199 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
1200 {
1201   if (type_check (i, 0, BT_INTEGER) == FAILURE
1202       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1203     return FAILURE;
1204
1205   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1206     return FAILURE;
1207
1208   return SUCCESS;
1209 }
1210
1211
1212 try
1213 gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
1214 {
1215   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1216     return FAILURE;
1217
1218   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1219     return FAILURE;
1220
1221   return SUCCESS;
1222 }
1223
1224
1225 try
1226 gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
1227 {
1228   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1229     return FAILURE;
1230
1231   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1232     return FAILURE;
1233
1234   if (status == NULL)
1235     return SUCCESS;
1236
1237   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1238     return FAILURE;
1239
1240   if (scalar_check (status, 2) == FAILURE)
1241     return FAILURE;
1242
1243   return SUCCESS;
1244 }
1245
1246
1247 try
1248 gfc_check_kind (gfc_expr * x)
1249 {
1250   if (x->ts.type == BT_DERIVED)
1251     {
1252       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1253                  "non-derived type", gfc_current_intrinsic_arg[0],
1254                  gfc_current_intrinsic, &x->where);
1255       return FAILURE;
1256     }
1257
1258   return SUCCESS;
1259 }
1260
1261
1262 try
1263 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1264 {
1265   if (array_check (array, 0) == FAILURE)
1266     return FAILURE;
1267
1268   if (dim != NULL)
1269     {
1270       if (dim_check (dim, 1, 1) == FAILURE)
1271         return FAILURE;
1272
1273       if (dim_rank_check (dim, array, 1) == FAILURE)
1274         return FAILURE;
1275     }
1276   return SUCCESS;
1277 }
1278
1279
1280 try
1281 gfc_check_link (gfc_expr * path1, gfc_expr * path2)
1282 {
1283   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1284     return FAILURE;
1285
1286   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1287     return FAILURE;
1288
1289   return SUCCESS;
1290 }
1291
1292
1293 try
1294 gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1295 {
1296   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1297     return FAILURE;
1298
1299   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1300     return FAILURE;
1301
1302   if (status == NULL)
1303     return SUCCESS;
1304
1305   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1306     return FAILURE;
1307
1308   if (scalar_check (status, 2) == FAILURE)
1309     return FAILURE;
1310
1311   return SUCCESS;
1312 }
1313
1314 try
1315 gfc_check_loc (gfc_expr *expr)
1316 {
1317   return variable_check (expr, 0);
1318 }
1319
1320
1321 try
1322 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
1323 {
1324   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1325     return FAILURE;
1326
1327   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1328     return FAILURE;
1329
1330   return SUCCESS;
1331 }
1332
1333
1334 try
1335 gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1336 {
1337   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1338     return FAILURE;
1339
1340   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1341     return FAILURE;
1342
1343   if (status == NULL)
1344     return SUCCESS;
1345
1346   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1347     return FAILURE;
1348
1349   if (scalar_check (status, 2) == FAILURE)
1350     return FAILURE;
1351
1352   return SUCCESS;
1353 }
1354
1355
1356 try
1357 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1358 {
1359   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1360     return FAILURE;
1361   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1362     return FAILURE;
1363
1364   return SUCCESS;
1365 }
1366
1367
1368 /* Min/max family.  */
1369
1370 static try
1371 min_max_args (gfc_actual_arglist * arg)
1372 {
1373   if (arg == NULL || arg->next == NULL)
1374     {
1375       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1376                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1377       return FAILURE;
1378     }
1379
1380   return SUCCESS;
1381 }
1382
1383
1384 static try
1385 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1386 {
1387   gfc_expr *x;
1388   int n;
1389
1390   if (min_max_args (arg) == FAILURE)
1391     return FAILURE;
1392
1393   n = 1;
1394
1395   for (; arg; arg = arg->next, n++)
1396     {
1397       x = arg->expr;
1398       if (x->ts.type != type || x->ts.kind != kind)
1399         {
1400           if (x->ts.type == type)
1401             {
1402               if (gfc_notify_std (GFC_STD_GNU,
1403                     "Extension: Different type kinds at %L", &x->where)
1404                   == FAILURE)
1405                 return FAILURE;
1406             }
1407           else
1408             {
1409               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1410                          n, gfc_current_intrinsic, &x->where,
1411                          gfc_basic_typename (type), kind);
1412               return FAILURE;
1413             }
1414         }
1415     }
1416
1417   return SUCCESS;
1418 }
1419
1420
1421 try
1422 gfc_check_min_max (gfc_actual_arglist * arg)
1423 {
1424   gfc_expr *x;
1425
1426   if (min_max_args (arg) == FAILURE)
1427     return FAILURE;
1428
1429   x = arg->expr;
1430
1431   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1432     {
1433       gfc_error
1434         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1435          gfc_current_intrinsic, &x->where);
1436       return FAILURE;
1437     }
1438
1439   return check_rest (x->ts.type, x->ts.kind, arg);
1440 }
1441
1442
1443 try
1444 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1445 {
1446   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1447 }
1448
1449
1450 try
1451 gfc_check_min_max_real (gfc_actual_arglist * arg)
1452 {
1453   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1454 }
1455
1456
1457 try
1458 gfc_check_min_max_double (gfc_actual_arglist * arg)
1459 {
1460   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1461 }
1462
1463 /* End of min/max family.  */
1464
1465 try
1466 gfc_check_malloc (gfc_expr * size)
1467 {
1468   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1469     return FAILURE;
1470
1471   if (scalar_check (size, 0) == FAILURE)
1472     return FAILURE;
1473
1474   return SUCCESS;
1475 }
1476
1477
1478 try
1479 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1480 {
1481   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1482     {
1483       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1484                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1485                  gfc_current_intrinsic, &matrix_a->where);
1486       return FAILURE;
1487     }
1488
1489   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1490     {
1491       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1492                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1493                  gfc_current_intrinsic, &matrix_b->where);
1494       return FAILURE;
1495     }
1496
1497   switch (matrix_a->rank)
1498     {
1499     case 1:
1500       if (rank_check (matrix_b, 1, 2) == FAILURE)
1501         return FAILURE;
1502       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
1503       if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1504         {
1505           gfc_error ("different shape on dimension 1 for arguments '%s' "
1506                      "and '%s' at %L for intrinsic matmul",
1507                      gfc_current_intrinsic_arg[0],
1508                      gfc_current_intrinsic_arg[1],
1509                      &matrix_a->where);
1510           return FAILURE;
1511         }
1512       break;
1513
1514     case 2:
1515       if (matrix_b->rank != 2)
1516         {
1517           if (rank_check (matrix_b, 1, 1) == FAILURE)
1518             return FAILURE;
1519         }
1520       /* matrix_b has rank 1 or 2 here. Common check for the cases
1521          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1522          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
1523       if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1524         {
1525           gfc_error ("different shape on dimension 2 for argument '%s' and "
1526                      "dimension 1 for argument '%s' at %L for intrinsic "
1527                      "matmul", gfc_current_intrinsic_arg[0],
1528                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1529           return FAILURE;
1530         }
1531       break;
1532
1533     default:
1534       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1535                  "1 or 2", gfc_current_intrinsic_arg[0],
1536                  gfc_current_intrinsic, &matrix_a->where);
1537       return FAILURE;
1538     }
1539
1540   return SUCCESS;
1541 }
1542
1543
1544 /* Whoever came up with this interface was probably on something.
1545    The possibilities for the occupation of the second and third
1546    parameters are:
1547
1548          Arg #2     Arg #3
1549          NULL       NULL
1550          DIM        NULL
1551          MASK       NULL
1552          NULL       MASK             minloc(array, mask=m)
1553          DIM        MASK
1554
1555    I.e. in the case of minloc(array,mask), mask will be in the second
1556    position of the argument list and we'll have to fix that up.  */
1557
1558 try
1559 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1560 {
1561   gfc_expr *a, *m, *d;
1562
1563   a = ap->expr;
1564   if (int_or_real_check (a, 0) == FAILURE
1565       || array_check (a, 0) == FAILURE)
1566     return FAILURE;
1567
1568   d = ap->next->expr;
1569   m = ap->next->next->expr;
1570
1571   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1572       && ap->next->name == NULL)
1573     {
1574       m = d;
1575       d = NULL;
1576
1577       ap->next->expr = NULL;
1578       ap->next->next->expr = m;
1579     }
1580
1581   if (dim_check (d, 1, 1) == FAILURE)
1582     return FAILURE;
1583
1584   if (d && dim_rank_check (d, a, 0) == FAILURE)
1585     return FAILURE;
1586
1587   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1588     return FAILURE;
1589
1590   if (m != NULL)
1591     {
1592       char buffer[80];
1593       snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1594                gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1595                gfc_current_intrinsic);
1596       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1597         return FAILURE;
1598     }
1599
1600   return SUCCESS;
1601 }
1602
1603
1604 /* Similar to minloc/maxloc, the argument list might need to be
1605    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1606    difference is that MINLOC/MAXLOC take an additional KIND argument.
1607    The possibilities are:
1608
1609          Arg #2     Arg #3
1610          NULL       NULL
1611          DIM        NULL
1612          MASK       NULL
1613          NULL       MASK             minval(array, mask=m)
1614          DIM        MASK
1615
1616    I.e. in the case of minval(array,mask), mask will be in the second
1617    position of the argument list and we'll have to fix that up.  */
1618
1619 static try
1620 check_reduction (gfc_actual_arglist * ap)
1621 {
1622   gfc_expr *a, *m, *d;
1623
1624   a = ap->expr;
1625   d = ap->next->expr;
1626   m = ap->next->next->expr;
1627
1628   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1629       && ap->next->name == NULL)
1630     {
1631       m = d;
1632       d = NULL;
1633
1634       ap->next->expr = NULL;
1635       ap->next->next->expr = m;
1636     }
1637
1638   if (dim_check (d, 1, 1) == FAILURE)
1639     return FAILURE;
1640
1641   if (d && dim_rank_check (d, a, 0) == FAILURE)
1642     return FAILURE;
1643
1644   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1645     return FAILURE;
1646
1647   if (m != NULL)
1648     {
1649       char buffer[80];
1650       snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
1651                gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1652                gfc_current_intrinsic);
1653       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1654         return FAILURE;
1655     }
1656
1657   return SUCCESS;
1658 }
1659
1660
1661 try
1662 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1663 {
1664   if (int_or_real_check (ap->expr, 0) == FAILURE
1665       || array_check (ap->expr, 0) == FAILURE)
1666     return FAILURE;
1667
1668   return check_reduction (ap);
1669 }
1670
1671
1672 try
1673 gfc_check_product_sum (gfc_actual_arglist * ap)
1674 {
1675   if (numeric_check (ap->expr, 0) == FAILURE
1676       || array_check (ap->expr, 0) == FAILURE)
1677     return FAILURE;
1678
1679   return check_reduction (ap);
1680 }
1681
1682
1683 try
1684 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1685 {
1686   char buffer[80];
1687
1688   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1689     return FAILURE;
1690
1691   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1692     return FAILURE;
1693
1694   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1695            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1696            gfc_current_intrinsic);
1697   if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
1698     return FAILURE;
1699
1700   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1701            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1702            gfc_current_intrinsic);
1703   if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
1704     return FAILURE;
1705
1706   return SUCCESS;
1707 }
1708
1709
1710 try
1711 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1712 {
1713   if (type_check (x, 0, BT_REAL) == FAILURE)
1714     return FAILURE;
1715
1716   if (type_check (s, 1, BT_REAL) == FAILURE)
1717     return FAILURE;
1718
1719   return SUCCESS;
1720 }
1721
1722
1723 try
1724 gfc_check_null (gfc_expr * mold)
1725 {
1726   symbol_attribute attr;
1727
1728   if (mold == NULL)
1729     return SUCCESS;
1730
1731   if (variable_check (mold, 0) == FAILURE)
1732     return FAILURE;
1733
1734   attr = gfc_variable_attr (mold, NULL);
1735
1736   if (!attr.pointer)
1737     {
1738       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1739                  gfc_current_intrinsic_arg[0],
1740                  gfc_current_intrinsic, &mold->where);
1741       return FAILURE;
1742     }
1743
1744   return SUCCESS;
1745 }
1746
1747
1748 try
1749 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1750 {
1751   char buffer[80];
1752
1753   if (array_check (array, 0) == FAILURE)
1754     return FAILURE;
1755
1756   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1757     return FAILURE;
1758
1759   snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
1760            gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1761            gfc_current_intrinsic);
1762   if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1763     return FAILURE;
1764
1765   if (vector != NULL)
1766     {
1767       if (same_type_check (array, 0, vector, 2) == FAILURE)
1768         return FAILURE;
1769
1770       if (rank_check (vector, 2, 1) == FAILURE)
1771         return FAILURE;
1772
1773       /* TODO: More constraints here.  */
1774     }
1775
1776   return SUCCESS;
1777 }
1778
1779
1780 try
1781 gfc_check_precision (gfc_expr * x)
1782 {
1783   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1784     {
1785       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1786                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1787                  gfc_current_intrinsic, &x->where);
1788       return FAILURE;
1789     }
1790
1791   return SUCCESS;
1792 }
1793
1794
1795 try
1796 gfc_check_present (gfc_expr * a)
1797 {
1798   gfc_symbol *sym;
1799
1800   if (variable_check (a, 0) == FAILURE)
1801     return FAILURE;
1802
1803   sym = a->symtree->n.sym;
1804   if (!sym->attr.dummy)
1805     {
1806       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1807                  "dummy variable", gfc_current_intrinsic_arg[0],
1808                  gfc_current_intrinsic, &a->where);
1809       return FAILURE;
1810     }
1811
1812   if (!sym->attr.optional)
1813     {
1814       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1815                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1816                  gfc_current_intrinsic, &a->where);
1817       return FAILURE;
1818     }
1819
1820   return SUCCESS;
1821 }
1822
1823
1824 try
1825 gfc_check_radix (gfc_expr * x)
1826 {
1827   if (int_or_real_check (x, 0) == FAILURE)
1828     return FAILURE;
1829
1830   return SUCCESS;
1831 }
1832
1833
1834 try
1835 gfc_check_range (gfc_expr * x)
1836 {
1837   if (numeric_check (x, 0) == FAILURE)
1838     return FAILURE;
1839
1840   return SUCCESS;
1841 }
1842
1843
1844 /* real, float, sngl.  */
1845 try
1846 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1847 {
1848   if (numeric_check (a, 0) == FAILURE)
1849     return FAILURE;
1850
1851   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1852     return FAILURE;
1853
1854   return SUCCESS;
1855 }
1856
1857
1858 try
1859 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
1860 {
1861   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1862     return FAILURE;
1863
1864   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1865     return FAILURE;
1866
1867   return SUCCESS;
1868 }
1869
1870
1871 try
1872 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1873 {
1874   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1875     return FAILURE;
1876
1877   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1878     return FAILURE;
1879
1880   if (status == NULL)
1881     return SUCCESS;
1882
1883   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1884     return FAILURE;
1885
1886   if (scalar_check (status, 2) == FAILURE)
1887     return FAILURE;
1888
1889   return SUCCESS;
1890 }
1891
1892
1893 try
1894 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1895 {
1896   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1897     return FAILURE;
1898
1899   if (scalar_check (x, 0) == FAILURE)
1900     return FAILURE;
1901
1902   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1903     return FAILURE;
1904
1905   if (scalar_check (y, 1) == FAILURE)
1906     return FAILURE;
1907
1908   return SUCCESS;
1909 }
1910
1911
1912 try
1913 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1914                    gfc_expr * pad, gfc_expr * order)
1915 {
1916   mpz_t size;
1917   int m;
1918
1919   if (array_check (source, 0) == FAILURE)
1920     return FAILURE;
1921
1922   if (rank_check (shape, 1, 1) == FAILURE)
1923     return FAILURE;
1924
1925   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1926     return FAILURE;
1927
1928   if (gfc_array_size (shape, &size) != SUCCESS)
1929     {
1930       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1931                  "array of constant size", &shape->where);
1932       return FAILURE;
1933     }
1934
1935   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1936   mpz_clear (size);
1937
1938   if (m > 0)
1939     {
1940       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
1941                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
1942       return FAILURE;
1943     }
1944
1945   if (pad != NULL)
1946     {
1947       if (same_type_check (source, 0, pad, 2) == FAILURE)
1948         return FAILURE;
1949       if (array_check (pad, 2) == FAILURE)
1950         return FAILURE;
1951     }
1952
1953   if (order != NULL && array_check (order, 3) == FAILURE)
1954     return FAILURE;
1955
1956   return SUCCESS;
1957 }
1958
1959
1960 try
1961 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1962 {
1963   if (type_check (x, 0, BT_REAL) == FAILURE)
1964     return FAILURE;
1965
1966   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1967     return FAILURE;
1968
1969   return SUCCESS;
1970 }
1971
1972
1973 try
1974 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1975 {
1976   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1977     return FAILURE;
1978
1979   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1980     return FAILURE;
1981
1982   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1983     return FAILURE;
1984
1985   if (same_type_check (x, 0, y, 1) == FAILURE)
1986     return FAILURE;
1987
1988   return SUCCESS;
1989 }
1990
1991
1992 try
1993 gfc_check_secnds (gfc_expr * r)
1994 {
1995
1996   if (type_check (r, 0, BT_REAL) == FAILURE)
1997     return FAILURE;
1998
1999   if (kind_value_check (r, 0, 4) == FAILURE)
2000     return FAILURE;
2001
2002   if (scalar_check (r, 0) == FAILURE)
2003     return FAILURE;
2004
2005   return SUCCESS;
2006 }
2007
2008
2009 try
2010 gfc_check_selected_int_kind (gfc_expr * r)
2011 {
2012
2013   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2014     return FAILURE;
2015
2016   if (scalar_check (r, 0) == FAILURE)
2017     return FAILURE;
2018
2019   return SUCCESS;
2020 }
2021
2022
2023 try
2024 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
2025 {
2026   if (p == NULL && r == NULL)
2027     {
2028       gfc_error ("Missing arguments to %s intrinsic at %L",
2029                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2030
2031       return FAILURE;
2032     }
2033
2034   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2035     return FAILURE;
2036
2037   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2038     return FAILURE;
2039
2040   return SUCCESS;
2041 }
2042
2043
2044 try
2045 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
2046 {
2047   if (type_check (x, 0, BT_REAL) == FAILURE)
2048     return FAILURE;
2049
2050   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2051     return FAILURE;
2052
2053   return SUCCESS;
2054 }
2055
2056
2057 try
2058 gfc_check_shape (gfc_expr * source)
2059 {
2060   gfc_array_ref *ar;
2061
2062   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2063     return SUCCESS;
2064
2065   ar = gfc_find_array_ref (source);
2066
2067   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2068     {
2069       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2070                  "an assumed size array", &source->where);
2071       return FAILURE;
2072     }
2073
2074   return SUCCESS;
2075 }
2076
2077
2078 try
2079 gfc_check_sign (gfc_expr * a, gfc_expr * b)
2080 {
2081   if (int_or_real_check (a, 0) == FAILURE)
2082     return FAILURE;
2083
2084   if (same_type_check (a, 0, b, 1) == FAILURE)
2085     return FAILURE;
2086
2087   return SUCCESS;
2088 }
2089
2090
2091 try
2092 gfc_check_size (gfc_expr * array, gfc_expr * dim)
2093 {
2094   if (array_check (array, 0) == FAILURE)
2095     return FAILURE;
2096
2097   if (dim != NULL)
2098     {
2099       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2100         return FAILURE;
2101
2102       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2103         return FAILURE;
2104
2105       if (dim_rank_check (dim, array, 0) == FAILURE)
2106         return FAILURE;
2107     }
2108
2109   return SUCCESS;
2110 }
2111
2112
2113 try
2114 gfc_check_sleep_sub (gfc_expr * seconds)
2115 {
2116   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2117     return FAILURE;
2118
2119   if (scalar_check (seconds, 0) == FAILURE)
2120     return FAILURE;
2121
2122   return SUCCESS;
2123 }
2124
2125
2126 try
2127 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
2128 {
2129   if (source->rank >= GFC_MAX_DIMENSIONS)
2130     {
2131       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2132                  "than rank %d", gfc_current_intrinsic_arg[0],
2133                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2134
2135       return FAILURE;
2136     }
2137
2138   if (dim_check (dim, 1, 0) == FAILURE)
2139     return FAILURE;
2140
2141   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2142     return FAILURE;
2143
2144   if (scalar_check (ncopies, 2) == FAILURE)
2145     return FAILURE;
2146
2147   return SUCCESS;
2148 }
2149
2150
2151 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2152    functions).  */
2153 try
2154 gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
2155 {
2156   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2157     return FAILURE;
2158
2159   if (scalar_check (unit, 0) == FAILURE)
2160     return FAILURE;
2161
2162   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2163     return FAILURE;
2164
2165   if (status == NULL)
2166     return SUCCESS;
2167
2168   if (type_check (status, 2, BT_INTEGER) == FAILURE
2169       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2170       || scalar_check (status, 2) == FAILURE)
2171     return FAILURE;
2172
2173   return SUCCESS;
2174 }
2175
2176
2177 try
2178 gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
2179 {
2180   return gfc_check_fgetputc_sub (unit, c, NULL);
2181 }
2182
2183
2184 try
2185 gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
2186 {
2187   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2188     return FAILURE;
2189
2190   if (status == NULL)
2191     return SUCCESS;
2192
2193   if (type_check (status, 1, BT_INTEGER) == FAILURE
2194       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2195       || scalar_check (status, 1) == FAILURE)
2196     return FAILURE;
2197
2198   return SUCCESS;
2199 }
2200
2201
2202 try
2203 gfc_check_fgetput (gfc_expr * c)
2204 {
2205   return gfc_check_fgetput_sub (c, NULL);
2206 }
2207
2208
2209 try
2210 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2211 {
2212   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2213     return FAILURE;
2214
2215   if (scalar_check (unit, 0) == FAILURE)
2216     return FAILURE;
2217
2218   if (type_check (array, 1, BT_INTEGER) == FAILURE
2219       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2220     return FAILURE;
2221
2222   if (array_check (array, 1) == FAILURE)
2223     return FAILURE;
2224
2225   return SUCCESS;
2226 }
2227
2228
2229 try
2230 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2231 {
2232   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2233     return FAILURE;
2234
2235   if (scalar_check (unit, 0) == FAILURE)
2236     return FAILURE;
2237
2238   if (type_check (array, 1, BT_INTEGER) == FAILURE
2239       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2240     return FAILURE;
2241
2242   if (array_check (array, 1) == FAILURE)
2243     return FAILURE;
2244
2245   if (status == NULL)
2246     return SUCCESS;
2247
2248   if (type_check (status, 2, BT_INTEGER) == FAILURE
2249       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2250     return FAILURE;
2251
2252   if (scalar_check (status, 2) == FAILURE)
2253     return FAILURE;
2254
2255   return SUCCESS;
2256 }
2257
2258
2259 try
2260 gfc_check_ftell (gfc_expr * unit)
2261 {
2262   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2263     return FAILURE;
2264
2265   if (scalar_check (unit, 0) == FAILURE)
2266     return FAILURE;
2267
2268   return SUCCESS;
2269 }
2270
2271
2272 try
2273 gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
2274 {
2275   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2276     return FAILURE;
2277
2278   if (scalar_check (unit, 0) == FAILURE)
2279     return FAILURE;
2280
2281   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2282     return FAILURE;
2283
2284   if (scalar_check (offset, 1) == FAILURE)
2285     return FAILURE;
2286
2287   return SUCCESS;
2288 }
2289
2290
2291 try
2292 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2293 {
2294   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2295     return FAILURE;
2296
2297   if (type_check (array, 1, BT_INTEGER) == FAILURE
2298       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2299     return FAILURE;
2300
2301   if (array_check (array, 1) == FAILURE)
2302     return FAILURE;
2303
2304   return SUCCESS;
2305 }
2306
2307
2308 try
2309 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2310 {
2311   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2312     return FAILURE;
2313
2314   if (type_check (array, 1, BT_INTEGER) == FAILURE
2315       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2316     return FAILURE;
2317
2318   if (array_check (array, 1) == FAILURE)
2319     return FAILURE;
2320
2321   if (status == NULL)
2322     return SUCCESS;
2323
2324   if (type_check (status, 2, BT_INTEGER) == FAILURE
2325       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2326     return FAILURE;
2327
2328   if (scalar_check (status, 2) == FAILURE)
2329     return FAILURE;
2330
2331   return SUCCESS;
2332 }
2333
2334
2335 try
2336 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2337                     gfc_expr * mold ATTRIBUTE_UNUSED,
2338                     gfc_expr * size)
2339 {
2340   if (size != NULL)
2341     {
2342       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2343         return FAILURE;
2344
2345       if (scalar_check (size, 2) == FAILURE)
2346         return FAILURE;
2347
2348       if (nonoptional_check (size, 2) == FAILURE)
2349         return FAILURE;
2350     }
2351
2352   return SUCCESS;
2353 }
2354
2355
2356 try
2357 gfc_check_transpose (gfc_expr * matrix)
2358 {
2359   if (rank_check (matrix, 0, 2) == FAILURE)
2360     return FAILURE;
2361
2362   return SUCCESS;
2363 }
2364
2365
2366 try
2367 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2368 {
2369   if (array_check (array, 0) == FAILURE)
2370     return FAILURE;
2371
2372   if (dim != NULL)
2373     {
2374       if (dim_check (dim, 1, 1) == FAILURE)
2375         return FAILURE;
2376
2377       if (dim_rank_check (dim, array, 0) == FAILURE)
2378         return FAILURE;
2379     }
2380
2381   return SUCCESS;
2382 }
2383
2384
2385 try
2386 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2387 {
2388   if (rank_check (vector, 0, 1) == FAILURE)
2389     return FAILURE;
2390
2391   if (array_check (mask, 1) == FAILURE)
2392     return FAILURE;
2393
2394   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2395     return FAILURE;
2396
2397   if (same_type_check (vector, 0, field, 2) == FAILURE)
2398     return FAILURE;
2399
2400   return SUCCESS;
2401 }
2402
2403
2404 try
2405 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2406 {
2407   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2408     return FAILURE;
2409
2410   if (same_type_check (x, 0, y, 1) == FAILURE)
2411     return FAILURE;
2412
2413   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2414     return FAILURE;
2415
2416   return SUCCESS;
2417 }
2418
2419
2420 try
2421 gfc_check_trim (gfc_expr * x)
2422 {
2423   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2424     return FAILURE;
2425
2426   if (scalar_check (x, 0) == FAILURE)
2427     return FAILURE;
2428
2429    return SUCCESS;
2430 }
2431
2432
2433 try
2434 gfc_check_ttynam (gfc_expr * unit)
2435 {
2436   if (scalar_check (unit, 0) == FAILURE)
2437     return FAILURE;
2438
2439   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2440     return FAILURE;
2441
2442   return SUCCESS;
2443 }
2444
2445
2446 /* Common check function for the half a dozen intrinsics that have a
2447    single real argument.  */
2448
2449 try
2450 gfc_check_x (gfc_expr * x)
2451 {
2452   if (type_check (x, 0, BT_REAL) == FAILURE)
2453     return FAILURE;
2454
2455   return SUCCESS;
2456 }
2457
2458
2459 /************* Check functions for intrinsic subroutines *************/
2460
2461 try
2462 gfc_check_cpu_time (gfc_expr * time)
2463 {
2464   if (scalar_check (time, 0) == FAILURE)
2465     return FAILURE;
2466
2467   if (type_check (time, 0, BT_REAL) == FAILURE)
2468     return FAILURE;
2469
2470   if (variable_check (time, 0) == FAILURE)
2471     return FAILURE;
2472
2473   return SUCCESS;
2474 }
2475
2476
2477 try
2478 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2479                          gfc_expr * zone, gfc_expr * values)
2480 {
2481   if (date != NULL)
2482     {
2483       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2484         return FAILURE;
2485       if (scalar_check (date, 0) == FAILURE)
2486         return FAILURE;
2487       if (variable_check (date, 0) == FAILURE)
2488         return FAILURE;
2489     }
2490
2491   if (time != NULL)
2492     {
2493       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2494         return FAILURE;
2495       if (scalar_check (time, 1) == FAILURE)
2496         return FAILURE;
2497       if (variable_check (time, 1) == FAILURE)
2498         return FAILURE;
2499     }
2500
2501   if (zone != NULL)
2502     {
2503       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2504         return FAILURE;
2505       if (scalar_check (zone, 2) == FAILURE)
2506         return FAILURE;
2507       if (variable_check (zone, 2) == FAILURE)
2508         return FAILURE;
2509     }
2510
2511   if (values != NULL)
2512     {
2513       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2514         return FAILURE;
2515       if (array_check (values, 3) == FAILURE)
2516         return FAILURE;
2517       if (rank_check (values, 3, 1) == FAILURE)
2518         return FAILURE;
2519       if (variable_check (values, 3) == FAILURE)
2520         return FAILURE;
2521     }
2522
2523   return SUCCESS;
2524 }
2525
2526
2527 try
2528 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2529                   gfc_expr * to, gfc_expr * topos)
2530 {
2531   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2532     return FAILURE;
2533
2534   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2535     return FAILURE;
2536
2537   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2538     return FAILURE;
2539
2540   if (same_type_check (from, 0, to, 3) == FAILURE)
2541     return FAILURE;
2542
2543   if (variable_check (to, 3) == FAILURE)
2544     return FAILURE;
2545
2546   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2547     return FAILURE;
2548
2549   return SUCCESS;
2550 }
2551
2552
2553 try
2554 gfc_check_random_number (gfc_expr * harvest)
2555 {
2556   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2557     return FAILURE;
2558
2559   if (variable_check (harvest, 0) == FAILURE)
2560     return FAILURE;
2561
2562   return SUCCESS;
2563 }
2564
2565
2566 try
2567 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2568 {
2569   if (size != NULL)
2570     {
2571       if (scalar_check (size, 0) == FAILURE)
2572         return FAILURE;
2573
2574       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2575         return FAILURE;
2576
2577       if (variable_check (size, 0) == FAILURE)
2578         return FAILURE;
2579
2580       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2581         return FAILURE;
2582     }
2583
2584   if (put != NULL)
2585     {
2586
2587       if (size != NULL)
2588         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2589                     &put->where);
2590
2591       if (array_check (put, 1) == FAILURE)
2592         return FAILURE;
2593
2594       if (rank_check (put, 1, 1) == FAILURE)
2595         return FAILURE;
2596
2597       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2598         return FAILURE;
2599
2600       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2601         return FAILURE;
2602     }
2603
2604   if (get != NULL)
2605     {
2606
2607       if (size != NULL || put != NULL)
2608         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2609                     &get->where);
2610
2611       if (array_check (get, 2) == FAILURE)
2612         return FAILURE;
2613
2614       if (rank_check (get, 2, 1) == FAILURE)
2615         return FAILURE;
2616
2617       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2618         return FAILURE;
2619
2620       if (variable_check (get, 2) == FAILURE)
2621         return FAILURE;
2622
2623       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2624         return FAILURE;
2625     }
2626
2627   return SUCCESS;
2628 }
2629
2630 try
2631 gfc_check_second_sub (gfc_expr * time)
2632 {
2633   if (scalar_check (time, 0) == FAILURE)
2634     return FAILURE;
2635
2636   if (type_check (time, 0, BT_REAL) == FAILURE)
2637     return FAILURE;
2638
2639   if (kind_value_check(time, 0, 4) == FAILURE)
2640     return FAILURE;
2641
2642   return SUCCESS;
2643 }
2644
2645
2646 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2647    count, count_rate, and count_max are all optional arguments */
2648
2649 try
2650 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2651                         gfc_expr * count_max)
2652 {
2653   if (count != NULL)
2654     {
2655       if (scalar_check (count, 0) == FAILURE)
2656         return FAILURE;
2657
2658       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2659         return FAILURE;
2660
2661       if (variable_check (count, 0) == FAILURE)
2662         return FAILURE;
2663     }
2664
2665   if (count_rate != NULL)
2666     {
2667       if (scalar_check (count_rate, 1) == FAILURE)
2668         return FAILURE;
2669
2670       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2671         return FAILURE;
2672
2673       if (variable_check (count_rate, 1) == FAILURE)
2674         return FAILURE;
2675
2676       if (count != NULL
2677           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2678         return FAILURE;
2679
2680     }
2681
2682   if (count_max != NULL)
2683     {
2684       if (scalar_check (count_max, 2) == FAILURE)
2685         return FAILURE;
2686
2687       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2688         return FAILURE;
2689
2690       if (variable_check (count_max, 2) == FAILURE)
2691         return FAILURE;
2692
2693       if (count != NULL
2694           && same_type_check (count, 0, count_max, 2) == FAILURE)
2695         return FAILURE;
2696
2697       if (count_rate != NULL
2698           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2699         return FAILURE;
2700     }
2701
2702   return SUCCESS;
2703 }
2704
2705 try
2706 gfc_check_irand (gfc_expr * x)
2707 {
2708   if (x == NULL)
2709     return SUCCESS;
2710
2711   if (scalar_check (x, 0) == FAILURE)
2712     return FAILURE;
2713
2714   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2715     return FAILURE;
2716
2717   if (kind_value_check(x, 0, 4) == FAILURE)
2718     return FAILURE;
2719
2720   return SUCCESS;
2721 }
2722
2723
2724 try
2725 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2726 {
2727   if (scalar_check (seconds, 0) == FAILURE)
2728     return FAILURE;
2729
2730   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2731     return FAILURE;
2732
2733   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2734     {
2735       gfc_error (
2736         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2737         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2738       return FAILURE;
2739     }
2740
2741   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2742     return FAILURE;
2743
2744   if (status == NULL)
2745     return SUCCESS;
2746
2747   if (scalar_check (status, 2) == FAILURE)
2748     return FAILURE;
2749
2750   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2751     return FAILURE;
2752
2753   return SUCCESS;
2754 }
2755
2756
2757 try
2758 gfc_check_rand (gfc_expr * x)
2759 {
2760   if (x == NULL)
2761     return SUCCESS;
2762
2763   if (scalar_check (x, 0) == FAILURE)
2764     return FAILURE;
2765
2766   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2767     return FAILURE;
2768
2769   if (kind_value_check(x, 0, 4) == FAILURE)
2770     return FAILURE;
2771
2772   return SUCCESS;
2773 }
2774
2775 try
2776 gfc_check_srand (gfc_expr * x)
2777 {
2778   if (scalar_check (x, 0) == FAILURE)
2779     return FAILURE;
2780
2781   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2782     return FAILURE;
2783
2784   if (kind_value_check(x, 0, 4) == FAILURE)
2785     return FAILURE;
2786
2787   return SUCCESS;
2788 }
2789
2790 try
2791 gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
2792 {
2793   if (scalar_check (time, 0) == FAILURE)
2794     return FAILURE;
2795
2796   if (type_check (time, 0, BT_INTEGER) == FAILURE)
2797     return FAILURE;
2798
2799   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
2800     return FAILURE;
2801
2802   return SUCCESS;
2803 }
2804
2805 try
2806 gfc_check_etime (gfc_expr * x)
2807 {
2808   if (array_check (x, 0) == FAILURE)
2809     return FAILURE;
2810
2811   if (rank_check (x, 0, 1) == FAILURE)
2812     return FAILURE;
2813
2814   if (variable_check (x, 0) == FAILURE)
2815     return FAILURE;
2816
2817   if (type_check (x, 0, BT_REAL) == FAILURE)
2818     return FAILURE;
2819
2820   if (kind_value_check(x, 0, 4) == FAILURE)
2821     return FAILURE;
2822
2823   return SUCCESS;
2824 }
2825
2826 try
2827 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2828 {
2829   if (array_check (values, 0) == FAILURE)
2830     return FAILURE;
2831
2832   if (rank_check (values, 0, 1) == FAILURE)
2833     return FAILURE;
2834
2835   if (variable_check (values, 0) == FAILURE)
2836     return FAILURE;
2837
2838   if (type_check (values, 0, BT_REAL) == FAILURE)
2839     return FAILURE;
2840
2841   if (kind_value_check(values, 0, 4) == FAILURE)
2842     return FAILURE;
2843
2844   if (scalar_check (time, 1) == FAILURE)
2845     return FAILURE;
2846
2847   if (type_check (time, 1, BT_REAL) == FAILURE)
2848     return FAILURE;
2849
2850   if (kind_value_check(time, 1, 4) == FAILURE)
2851     return FAILURE;
2852
2853   return SUCCESS;
2854 }
2855
2856
2857 try
2858 gfc_check_fdate_sub (gfc_expr * date)
2859 {
2860   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2861     return FAILURE;
2862
2863   return SUCCESS;
2864 }
2865
2866
2867 try
2868 gfc_check_gerror (gfc_expr * msg)
2869 {
2870   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2871     return FAILURE;
2872
2873   return SUCCESS;
2874 }
2875
2876
2877 try
2878 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2879 {
2880   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2881     return FAILURE;
2882
2883   if (status == NULL)
2884     return SUCCESS;
2885
2886   if (scalar_check (status, 1) == FAILURE)
2887     return FAILURE;
2888
2889   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2890     return FAILURE;
2891
2892   return SUCCESS;
2893 }
2894
2895
2896 try
2897 gfc_check_getlog (gfc_expr * msg)
2898 {
2899   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2900     return FAILURE;
2901
2902   return SUCCESS;
2903 }
2904
2905
2906 try
2907 gfc_check_exit (gfc_expr * status)
2908 {
2909   if (status == NULL)
2910     return SUCCESS;
2911
2912   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2913     return FAILURE;
2914
2915   if (scalar_check (status, 0) == FAILURE)
2916     return FAILURE;
2917
2918   return SUCCESS;
2919 }
2920
2921
2922 try
2923 gfc_check_flush (gfc_expr * unit)
2924 {
2925   if (unit == NULL)
2926     return SUCCESS;
2927
2928   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2929     return FAILURE;
2930
2931   if (scalar_check (unit, 0) == FAILURE)
2932     return FAILURE;
2933
2934   return SUCCESS;
2935 }
2936
2937
2938 try
2939 gfc_check_free (gfc_expr * i)
2940 {
2941   if (type_check (i, 0, BT_INTEGER) == FAILURE)
2942     return FAILURE;
2943
2944   if (scalar_check (i, 0) == FAILURE)
2945     return FAILURE;
2946
2947   return SUCCESS;
2948 }
2949
2950
2951 try
2952 gfc_check_hostnm (gfc_expr * name)
2953 {
2954   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2955     return FAILURE;
2956
2957   return SUCCESS;
2958 }
2959
2960
2961 try
2962 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
2963 {
2964   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2965     return FAILURE;
2966
2967   if (status == NULL)
2968     return SUCCESS;
2969
2970   if (scalar_check (status, 1) == FAILURE)
2971     return FAILURE;
2972
2973   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2974     return FAILURE;
2975
2976   return SUCCESS;
2977 }
2978
2979
2980 try
2981 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
2982 {
2983   if (scalar_check (unit, 0) == FAILURE)
2984     return FAILURE;
2985
2986   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2987     return FAILURE;
2988
2989   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
2990     return FAILURE;
2991
2992   return SUCCESS;
2993 }
2994
2995
2996 try
2997 gfc_check_isatty (gfc_expr * unit)
2998 {
2999   if (unit == NULL)
3000     return FAILURE;
3001
3002   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3003     return FAILURE;
3004
3005   if (scalar_check (unit, 0) == FAILURE)
3006     return FAILURE;
3007
3008   return SUCCESS;
3009 }
3010
3011
3012 try
3013 gfc_check_perror (gfc_expr * string)
3014 {
3015   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3016     return FAILURE;
3017
3018   return SUCCESS;
3019 }
3020
3021
3022 try
3023 gfc_check_umask (gfc_expr * mask)
3024 {
3025   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3026     return FAILURE;
3027
3028   if (scalar_check (mask, 0) == FAILURE)
3029     return FAILURE;
3030
3031   return SUCCESS;
3032 }
3033
3034
3035 try
3036 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
3037 {
3038   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3039     return FAILURE;
3040
3041   if (scalar_check (mask, 0) == FAILURE)
3042     return FAILURE;
3043
3044   if (old == NULL)
3045     return SUCCESS;
3046
3047   if (scalar_check (old, 1) == FAILURE)
3048     return FAILURE;
3049
3050   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3051     return FAILURE;
3052
3053   return SUCCESS;
3054 }
3055
3056
3057 try
3058 gfc_check_unlink (gfc_expr * name)
3059 {
3060   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3061     return FAILURE;
3062
3063   return SUCCESS;
3064 }
3065
3066
3067 try
3068 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
3069 {
3070   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3071     return FAILURE;
3072
3073   if (status == NULL)
3074     return SUCCESS;
3075
3076   if (scalar_check (status, 1) == FAILURE)
3077     return FAILURE;
3078
3079   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3080     return FAILURE;
3081
3082   return SUCCESS;
3083 }
3084
3085
3086 try
3087 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
3088 {
3089   if (scalar_check (number, 0) == FAILURE)
3090     return FAILURE;
3091
3092   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3093     return FAILURE;
3094
3095   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3096     {
3097       gfc_error (
3098         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3099         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3100       return FAILURE;
3101     }
3102
3103   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3104     return FAILURE;
3105
3106   return SUCCESS;
3107 }
3108
3109
3110 try
3111 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
3112 {
3113   if (scalar_check (number, 0) == FAILURE)
3114     return FAILURE;
3115
3116   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3117     return FAILURE;
3118
3119   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3120     {
3121       gfc_error (
3122         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3123         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3124       return FAILURE;
3125     }
3126
3127   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3128     return FAILURE;
3129
3130   if (status == NULL)
3131     return SUCCESS;
3132
3133   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3134     return FAILURE;
3135
3136   if (scalar_check (status, 2) == FAILURE)
3137     return FAILURE;
3138
3139   return SUCCESS;
3140 }
3141
3142
3143 try
3144 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
3145 {
3146   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3147     return FAILURE;
3148
3149   if (scalar_check (status, 1) == FAILURE)
3150     return FAILURE;
3151
3152   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3153     return FAILURE;
3154
3155   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3156     return FAILURE;
3157
3158   return SUCCESS;
3159 }
3160
3161
3162 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3163 try
3164 gfc_check_and (gfc_expr * i, gfc_expr * j)
3165 {
3166   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3167     {
3168       gfc_error (
3169         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3170         gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
3171       return FAILURE;
3172     }
3173
3174   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3175     {
3176       gfc_error (
3177         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3178         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
3179       return FAILURE;
3180     }
3181
3182   if (i->ts.type != j->ts.type)
3183     {
3184       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3185                  "have the same type", gfc_current_intrinsic_arg[0],
3186                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3187                  &j->where);
3188       return FAILURE;
3189     }
3190
3191   if (scalar_check (i, 0) == FAILURE)
3192     return FAILURE;
3193
3194   if (scalar_check (j, 1) == FAILURE)
3195     return FAILURE;
3196
3197   return SUCCESS;
3198 }