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