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