gcc/fortran/check.c

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