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   return SUCCESS;
1530 }
1531
1532
1533 /* Similar to minloc/maxloc, the argument list might need to be
1534    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1535    difference is that MINLOC/MAXLOC take an additional KIND argument.
1536    The possibilities are:
1537
1538          Arg #2     Arg #3
1539          NULL       NULL
1540          DIM        NULL
1541          MASK       NULL
1542          NULL       MASK             minval(array, mask=m)
1543          DIM        MASK
1544
1545    I.e. in the case of minval(array,mask), mask will be in the second
1546    position of the argument list and we'll have to fix that up.  */
1547
1548 static try
1549 check_reduction (gfc_actual_arglist * ap)
1550 {
1551   gfc_expr *m, *d;
1552
1553   d = ap->next->expr;
1554   m = ap->next->next->expr;
1555
1556   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1557       && ap->next->name == NULL)
1558     {
1559       m = d;
1560       d = NULL;
1561
1562       ap->next->expr = NULL;
1563       ap->next->next->expr = m;
1564     }
1565
1566   if (d != NULL
1567       && (scalar_check (d, 1) == FAILURE
1568       || type_check (d, 1, BT_INTEGER) == FAILURE))
1569     return FAILURE;
1570
1571   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1572     return FAILURE;
1573
1574   return SUCCESS;
1575 }
1576
1577
1578 try
1579 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1580 {
1581   if (int_or_real_check (ap->expr, 0) == FAILURE
1582       || array_check (ap->expr, 0) == FAILURE)
1583     return FAILURE;
1584
1585   return check_reduction (ap);
1586 }
1587
1588
1589 try
1590 gfc_check_product_sum (gfc_actual_arglist * ap)
1591 {
1592   if (numeric_check (ap->expr, 0) == FAILURE
1593       || array_check (ap->expr, 0) == FAILURE)
1594     return FAILURE;
1595
1596   return check_reduction (ap);
1597 }
1598
1599
1600 try
1601 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1602 {
1603   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1604     return FAILURE;
1605
1606   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1607     return FAILURE;
1608
1609   return SUCCESS;
1610 }
1611
1612
1613 try
1614 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1615 {
1616   if (type_check (x, 0, BT_REAL) == FAILURE)
1617     return FAILURE;
1618
1619   if (type_check (s, 1, BT_REAL) == FAILURE)
1620     return FAILURE;
1621
1622   return SUCCESS;
1623 }
1624
1625
1626 try
1627 gfc_check_null (gfc_expr * mold)
1628 {
1629   symbol_attribute attr;
1630
1631   if (mold == NULL)
1632     return SUCCESS;
1633
1634   if (variable_check (mold, 0) == FAILURE)
1635     return FAILURE;
1636
1637   attr = gfc_variable_attr (mold, NULL);
1638
1639   if (!attr.pointer)
1640     {
1641       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1642                  gfc_current_intrinsic_arg[0],
1643                  gfc_current_intrinsic, &mold->where);
1644       return FAILURE;
1645     }
1646
1647   return SUCCESS;
1648 }
1649
1650
1651 try
1652 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1653 {
1654   if (array_check (array, 0) == FAILURE)
1655     return FAILURE;
1656
1657   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1658     return FAILURE;
1659
1660   if (mask->rank != 0 && mask->rank != array->rank)
1661     {
1662       gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
1663                  "with '%s' argument", gfc_current_intrinsic_arg[0],
1664                  gfc_current_intrinsic, &array->where,
1665                  gfc_current_intrinsic_arg[1]);
1666       return FAILURE;
1667     }
1668
1669   if (vector != NULL)
1670     {
1671       if (same_type_check (array, 0, vector, 2) == FAILURE)
1672         return FAILURE;
1673
1674       if (rank_check (vector, 2, 1) == FAILURE)
1675         return FAILURE;
1676
1677       /* TODO: More constraints here.  */
1678     }
1679
1680   return SUCCESS;
1681 }
1682
1683
1684 try
1685 gfc_check_precision (gfc_expr * x)
1686 {
1687   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1688     {
1689       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1690                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1691                  gfc_current_intrinsic, &x->where);
1692       return FAILURE;
1693     }
1694
1695   return SUCCESS;
1696 }
1697
1698
1699 try
1700 gfc_check_present (gfc_expr * a)
1701 {
1702   gfc_symbol *sym;
1703
1704   if (variable_check (a, 0) == FAILURE)
1705     return FAILURE;
1706
1707   sym = a->symtree->n.sym;
1708   if (!sym->attr.dummy)
1709     {
1710       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1711                  "dummy variable", gfc_current_intrinsic_arg[0],
1712                  gfc_current_intrinsic, &a->where);
1713       return FAILURE;
1714     }
1715
1716   if (!sym->attr.optional)
1717     {
1718       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1719                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1720                  gfc_current_intrinsic, &a->where);
1721       return FAILURE;
1722     }
1723
1724   return SUCCESS;
1725 }
1726
1727
1728 try
1729 gfc_check_radix (gfc_expr * x)
1730 {
1731   if (int_or_real_check (x, 0) == FAILURE)
1732     return FAILURE;
1733
1734   return SUCCESS;
1735 }
1736
1737
1738 try
1739 gfc_check_range (gfc_expr * x)
1740 {
1741   if (numeric_check (x, 0) == FAILURE)
1742     return FAILURE;
1743
1744   return SUCCESS;
1745 }
1746
1747
1748 /* real, float, sngl.  */
1749 try
1750 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1751 {
1752   if (numeric_check (a, 0) == FAILURE)
1753     return FAILURE;
1754
1755   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1756     return FAILURE;
1757
1758   return SUCCESS;
1759 }
1760
1761
1762 try
1763 gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
1764 {
1765   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1766     return FAILURE;
1767
1768   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1769     return FAILURE;
1770
1771   return SUCCESS;
1772 }
1773
1774
1775 try
1776 gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
1777 {
1778   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1779     return FAILURE;
1780
1781   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1782     return FAILURE;
1783
1784   if (status == NULL)
1785     return SUCCESS;
1786
1787   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1788     return FAILURE;
1789
1790   if (scalar_check (status, 2) == FAILURE)
1791     return FAILURE;
1792
1793   return SUCCESS;
1794 }
1795
1796
1797 try
1798 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1799 {
1800   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1801     return FAILURE;
1802
1803   if (scalar_check (x, 0) == FAILURE)
1804     return FAILURE;
1805
1806   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1807     return FAILURE;
1808
1809   if (scalar_check (y, 1) == FAILURE)
1810     return FAILURE;
1811
1812   return SUCCESS;
1813 }
1814
1815
1816 try
1817 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1818                    gfc_expr * pad, gfc_expr * order)
1819 {
1820   mpz_t size;
1821   int m;
1822
1823   if (array_check (source, 0) == FAILURE)
1824     return FAILURE;
1825
1826   if (rank_check (shape, 1, 1) == FAILURE)
1827     return FAILURE;
1828
1829   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1830     return FAILURE;
1831
1832   if (gfc_array_size (shape, &size) != SUCCESS)
1833     {
1834       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1835                  "array of constant size", &shape->where);
1836       return FAILURE;
1837     }
1838
1839   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1840   mpz_clear (size);
1841
1842   if (m > 0)
1843     {
1844       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
1845                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
1846       return FAILURE;
1847     }
1848
1849   if (pad != NULL)
1850     {
1851       if (same_type_check (source, 0, pad, 2) == FAILURE)
1852         return FAILURE;
1853       if (array_check (pad, 2) == FAILURE)
1854         return FAILURE;
1855     }
1856
1857   if (order != NULL && array_check (order, 3) == FAILURE)
1858     return FAILURE;
1859
1860   return SUCCESS;
1861 }
1862
1863
1864 try
1865 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1866 {
1867   if (type_check (x, 0, BT_REAL) == FAILURE)
1868     return FAILURE;
1869
1870   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1871     return FAILURE;
1872
1873   return SUCCESS;
1874 }
1875
1876
1877 try
1878 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1879 {
1880   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1881     return FAILURE;
1882
1883   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1884     return FAILURE;
1885
1886   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1887     return FAILURE;
1888
1889   if (same_type_check (x, 0, y, 1) == FAILURE)
1890     return FAILURE;
1891
1892   return SUCCESS;
1893 }
1894
1895
1896 try
1897 gfc_check_secnds (gfc_expr * r)
1898 {
1899
1900   if (type_check (r, 0, BT_REAL) == FAILURE)
1901     return FAILURE;
1902
1903   if (kind_value_check (r, 0, 4) == FAILURE)
1904     return FAILURE;
1905
1906   if (scalar_check (r, 0) == FAILURE)
1907     return FAILURE;
1908
1909   return SUCCESS;
1910 }
1911
1912
1913 try
1914 gfc_check_selected_int_kind (gfc_expr * r)
1915 {
1916
1917   if (type_check (r, 0, BT_INTEGER) == FAILURE)
1918     return FAILURE;
1919
1920   if (scalar_check (r, 0) == FAILURE)
1921     return FAILURE;
1922
1923   return SUCCESS;
1924 }
1925
1926
1927 try
1928 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1929 {
1930   if (p == NULL && r == NULL)
1931     {
1932       gfc_error ("Missing arguments to %s intrinsic at %L",
1933                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1934
1935       return FAILURE;
1936     }
1937
1938   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1939     return FAILURE;
1940
1941   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1942     return FAILURE;
1943
1944   return SUCCESS;
1945 }
1946
1947
1948 try
1949 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1950 {
1951   if (type_check (x, 0, BT_REAL) == FAILURE)
1952     return FAILURE;
1953
1954   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1955     return FAILURE;
1956
1957   return SUCCESS;
1958 }
1959
1960
1961 try
1962 gfc_check_shape (gfc_expr * source)
1963 {
1964   gfc_array_ref *ar;
1965
1966   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1967     return SUCCESS;
1968
1969   ar = gfc_find_array_ref (source);
1970
1971   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1972     {
1973       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1974                  "an assumed size array", &source->where);
1975       return FAILURE;
1976     }
1977
1978   return SUCCESS;
1979 }
1980
1981
1982 try
1983 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1984 {
1985   if (int_or_real_check (a, 0) == FAILURE)
1986     return FAILURE;
1987
1988   if (same_type_check (a, 0, b, 1) == FAILURE)
1989     return FAILURE;
1990
1991   return SUCCESS;
1992 }
1993
1994
1995 try
1996 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1997 {
1998   if (array_check (array, 0) == FAILURE)
1999     return FAILURE;
2000
2001   if (dim != NULL)
2002     {
2003       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2004         return FAILURE;
2005
2006       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2007         return FAILURE;
2008
2009       if (dim_rank_check (dim, array, 0) == FAILURE)
2010         return FAILURE;
2011     }
2012
2013   return SUCCESS;
2014 }
2015
2016
2017 try
2018 gfc_check_sleep_sub (gfc_expr * seconds)
2019 {
2020   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2021     return FAILURE;
2022
2023   if (scalar_check (seconds, 0) == FAILURE)
2024     return FAILURE;
2025
2026   return SUCCESS;
2027 }
2028
2029
2030 try
2031 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
2032 {
2033   if (source->rank >= GFC_MAX_DIMENSIONS)
2034     {
2035       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2036                  "than rank %d", gfc_current_intrinsic_arg[0],
2037                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2038
2039       return FAILURE;
2040     }
2041
2042   if (dim_check (dim, 1, 0) == FAILURE)
2043     return FAILURE;
2044
2045   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2046     return FAILURE;
2047
2048   if (scalar_check (ncopies, 2) == FAILURE)
2049     return FAILURE;
2050
2051   return SUCCESS;
2052 }
2053
2054
2055 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2056    functions).  */
2057 try
2058 gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
2059 {
2060   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2061     return FAILURE;
2062
2063   if (scalar_check (unit, 0) == FAILURE)
2064     return FAILURE;
2065
2066   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2067     return FAILURE;
2068
2069   if (status == NULL)
2070     return SUCCESS;
2071
2072   if (type_check (status, 2, BT_INTEGER) == FAILURE
2073       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2074       || scalar_check (status, 2) == FAILURE)
2075     return FAILURE;
2076
2077   return SUCCESS;
2078 }
2079
2080
2081 try
2082 gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
2083 {
2084   return gfc_check_fgetputc_sub (unit, c, NULL);
2085 }
2086
2087
2088 try
2089 gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
2090 {
2091   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2092     return FAILURE;
2093
2094   if (status == NULL)
2095     return SUCCESS;
2096
2097   if (type_check (status, 1, BT_INTEGER) == FAILURE
2098       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2099       || scalar_check (status, 1) == FAILURE)
2100     return FAILURE;
2101
2102   return SUCCESS;
2103 }
2104
2105
2106 try
2107 gfc_check_fgetput (gfc_expr * c)
2108 {
2109   return gfc_check_fgetput_sub (c, NULL);
2110 }
2111
2112
2113 try
2114 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
2115 {
2116   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2117     return FAILURE;
2118
2119   if (scalar_check (unit, 0) == FAILURE)
2120     return FAILURE;
2121
2122   if (type_check (array, 1, BT_INTEGER) == FAILURE
2123       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2124     return FAILURE;
2125
2126   if (array_check (array, 1) == FAILURE)
2127     return FAILURE;
2128
2129   return SUCCESS;
2130 }
2131
2132
2133 try
2134 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
2135 {
2136   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2137     return FAILURE;
2138
2139   if (scalar_check (unit, 0) == FAILURE)
2140     return FAILURE;
2141
2142   if (type_check (array, 1, BT_INTEGER) == FAILURE
2143       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2144     return FAILURE;
2145
2146   if (array_check (array, 1) == FAILURE)
2147     return FAILURE;
2148
2149   if (status == NULL)
2150     return SUCCESS;
2151
2152   if (type_check (status, 2, BT_INTEGER) == FAILURE
2153       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2154     return FAILURE;
2155
2156   if (scalar_check (status, 2) == FAILURE)
2157     return FAILURE;
2158
2159   return SUCCESS;
2160 }
2161
2162
2163 try
2164 gfc_check_ftell (gfc_expr * unit)
2165 {
2166   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2167     return FAILURE;
2168
2169   if (scalar_check (unit, 0) == FAILURE)
2170     return FAILURE;
2171
2172   return SUCCESS;
2173 }
2174
2175
2176 try
2177 gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
2178 {
2179   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2180     return FAILURE;
2181
2182   if (scalar_check (unit, 0) == FAILURE)
2183     return FAILURE;
2184
2185   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2186     return FAILURE;
2187
2188   if (scalar_check (offset, 1) == FAILURE)
2189     return FAILURE;
2190
2191   return SUCCESS;
2192 }
2193
2194
2195 try
2196 gfc_check_stat (gfc_expr * name, gfc_expr * array)
2197 {
2198   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2199     return FAILURE;
2200
2201   if (type_check (array, 1, BT_INTEGER) == FAILURE
2202       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2203     return FAILURE;
2204
2205   if (array_check (array, 1) == FAILURE)
2206     return FAILURE;
2207
2208   return SUCCESS;
2209 }
2210
2211
2212 try
2213 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
2214 {
2215   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2216     return FAILURE;
2217
2218   if (type_check (array, 1, BT_INTEGER) == FAILURE
2219       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2220     return FAILURE;
2221
2222   if (array_check (array, 1) == FAILURE)
2223     return FAILURE;
2224
2225   if (status == NULL)
2226     return SUCCESS;
2227
2228   if (type_check (status, 2, BT_INTEGER) == FAILURE
2229       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2230     return FAILURE;
2231
2232   if (scalar_check (status, 2) == FAILURE)
2233     return FAILURE;
2234
2235   return SUCCESS;
2236 }
2237
2238
2239 try
2240 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
2241                     gfc_expr * mold ATTRIBUTE_UNUSED,
2242                     gfc_expr * size)
2243 {
2244   if (size != NULL)
2245     {
2246       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2247         return FAILURE;
2248
2249       if (scalar_check (size, 2) == FAILURE)
2250         return FAILURE;
2251
2252       if (nonoptional_check (size, 2) == FAILURE)
2253         return FAILURE;
2254     }
2255
2256   return SUCCESS;
2257 }
2258
2259
2260 try
2261 gfc_check_transpose (gfc_expr * matrix)
2262 {
2263   if (rank_check (matrix, 0, 2) == FAILURE)
2264     return FAILURE;
2265
2266   return SUCCESS;
2267 }
2268
2269
2270 try
2271 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
2272 {
2273   if (array_check (array, 0) == FAILURE)
2274     return FAILURE;
2275
2276   if (dim != NULL)
2277     {
2278       if (dim_check (dim, 1, 1) == FAILURE)
2279         return FAILURE;
2280
2281       if (dim_rank_check (dim, array, 0) == FAILURE)
2282         return FAILURE;
2283     }
2284
2285   return SUCCESS;
2286 }
2287
2288
2289 try
2290 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
2291 {
2292   if (rank_check (vector, 0, 1) == FAILURE)
2293     return FAILURE;
2294
2295   if (array_check (mask, 1) == FAILURE)
2296     return FAILURE;
2297
2298   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2299     return FAILURE;
2300
2301   if (same_type_check (vector, 0, field, 2) == FAILURE)
2302     return FAILURE;
2303
2304   return SUCCESS;
2305 }
2306
2307
2308 try
2309 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
2310 {
2311   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2312     return FAILURE;
2313
2314   if (same_type_check (x, 0, y, 1) == FAILURE)
2315     return FAILURE;
2316
2317   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2318     return FAILURE;
2319
2320   return SUCCESS;
2321 }
2322
2323
2324 try
2325 gfc_check_trim (gfc_expr * x)
2326 {
2327   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2328     return FAILURE;
2329
2330   if (scalar_check (x, 0) == FAILURE)
2331     return FAILURE;
2332
2333    return SUCCESS;
2334 }
2335
2336
2337 try
2338 gfc_check_ttynam (gfc_expr * unit)
2339 {
2340   if (scalar_check (unit, 0) == FAILURE)
2341     return FAILURE;
2342
2343   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2344     return FAILURE;
2345
2346   return SUCCESS;
2347 }
2348
2349
2350 /* Common check function for the half a dozen intrinsics that have a
2351    single real argument.  */
2352
2353 try
2354 gfc_check_x (gfc_expr * x)
2355 {
2356   if (type_check (x, 0, BT_REAL) == FAILURE)
2357     return FAILURE;
2358
2359   return SUCCESS;
2360 }
2361
2362
2363 /************* Check functions for intrinsic subroutines *************/
2364
2365 try
2366 gfc_check_cpu_time (gfc_expr * time)
2367 {
2368   if (scalar_check (time, 0) == FAILURE)
2369     return FAILURE;
2370
2371   if (type_check (time, 0, BT_REAL) == FAILURE)
2372     return FAILURE;
2373
2374   if (variable_check (time, 0) == FAILURE)
2375     return FAILURE;
2376
2377   return SUCCESS;
2378 }
2379
2380
2381 try
2382 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
2383                          gfc_expr * zone, gfc_expr * values)
2384 {
2385   if (date != NULL)
2386     {
2387       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2388         return FAILURE;
2389       if (scalar_check (date, 0) == FAILURE)
2390         return FAILURE;
2391       if (variable_check (date, 0) == FAILURE)
2392         return FAILURE;
2393     }
2394
2395   if (time != NULL)
2396     {
2397       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2398         return FAILURE;
2399       if (scalar_check (time, 1) == FAILURE)
2400         return FAILURE;
2401       if (variable_check (time, 1) == FAILURE)
2402         return FAILURE;
2403     }
2404
2405   if (zone != NULL)
2406     {
2407       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2408         return FAILURE;
2409       if (scalar_check (zone, 2) == FAILURE)
2410         return FAILURE;
2411       if (variable_check (zone, 2) == FAILURE)
2412         return FAILURE;
2413     }
2414
2415   if (values != NULL)
2416     {
2417       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2418         return FAILURE;
2419       if (array_check (values, 3) == FAILURE)
2420         return FAILURE;
2421       if (rank_check (values, 3, 1) == FAILURE)
2422         return FAILURE;
2423       if (variable_check (values, 3) == FAILURE)
2424         return FAILURE;
2425     }
2426
2427   return SUCCESS;
2428 }
2429
2430
2431 try
2432 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
2433                   gfc_expr * to, gfc_expr * topos)
2434 {
2435   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2436     return FAILURE;
2437
2438   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2439     return FAILURE;
2440
2441   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2442     return FAILURE;
2443
2444   if (same_type_check (from, 0, to, 3) == FAILURE)
2445     return FAILURE;
2446
2447   if (variable_check (to, 3) == FAILURE)
2448     return FAILURE;
2449
2450   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2451     return FAILURE;
2452
2453   return SUCCESS;
2454 }
2455
2456
2457 try
2458 gfc_check_random_number (gfc_expr * harvest)
2459 {
2460   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2461     return FAILURE;
2462
2463   if (variable_check (harvest, 0) == FAILURE)
2464     return FAILURE;
2465
2466   return SUCCESS;
2467 }
2468
2469
2470 try
2471 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
2472 {
2473   if (size != NULL)
2474     {
2475       if (scalar_check (size, 0) == FAILURE)
2476         return FAILURE;
2477
2478       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2479         return FAILURE;
2480
2481       if (variable_check (size, 0) == FAILURE)
2482         return FAILURE;
2483
2484       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2485         return FAILURE;
2486     }
2487
2488   if (put != NULL)
2489     {
2490
2491       if (size != NULL)
2492         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2493                     &put->where);
2494
2495       if (array_check (put, 1) == FAILURE)
2496         return FAILURE;
2497
2498       if (rank_check (put, 1, 1) == FAILURE)
2499         return FAILURE;
2500
2501       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2502         return FAILURE;
2503
2504       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2505         return FAILURE;
2506     }
2507
2508   if (get != NULL)
2509     {
2510
2511       if (size != NULL || put != NULL)
2512         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2513                     &get->where);
2514
2515       if (array_check (get, 2) == FAILURE)
2516         return FAILURE;
2517
2518       if (rank_check (get, 2, 1) == FAILURE)
2519         return FAILURE;
2520
2521       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2522         return FAILURE;
2523
2524       if (variable_check (get, 2) == FAILURE)
2525         return FAILURE;
2526
2527       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2528         return FAILURE;
2529     }
2530
2531   return SUCCESS;
2532 }
2533
2534 try
2535 gfc_check_second_sub (gfc_expr * time)
2536 {
2537   if (scalar_check (time, 0) == FAILURE)
2538     return FAILURE;
2539
2540   if (type_check (time, 0, BT_REAL) == FAILURE)
2541     return FAILURE;
2542
2543   if (kind_value_check(time, 0, 4) == FAILURE)
2544     return FAILURE;
2545
2546   return SUCCESS;
2547 }
2548
2549
2550 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2551    count, count_rate, and count_max are all optional arguments */
2552
2553 try
2554 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2555                         gfc_expr * count_max)
2556 {
2557   if (count != NULL)
2558     {
2559       if (scalar_check (count, 0) == FAILURE)
2560         return FAILURE;
2561
2562       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2563         return FAILURE;
2564
2565       if (variable_check (count, 0) == FAILURE)
2566         return FAILURE;
2567     }
2568
2569   if (count_rate != NULL)
2570     {
2571       if (scalar_check (count_rate, 1) == FAILURE)
2572         return FAILURE;
2573
2574       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2575         return FAILURE;
2576
2577       if (variable_check (count_rate, 1) == FAILURE)
2578         return FAILURE;
2579
2580       if (count != NULL
2581           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2582         return FAILURE;
2583
2584     }
2585
2586   if (count_max != NULL)
2587     {
2588       if (scalar_check (count_max, 2) == FAILURE)
2589         return FAILURE;
2590
2591       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2592         return FAILURE;
2593
2594       if (variable_check (count_max, 2) == FAILURE)
2595         return FAILURE;
2596
2597       if (count != NULL
2598           && same_type_check (count, 0, count_max, 2) == FAILURE)
2599         return FAILURE;
2600
2601       if (count_rate != NULL
2602           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2603         return FAILURE;
2604     }
2605
2606   return SUCCESS;
2607 }
2608
2609 try
2610 gfc_check_irand (gfc_expr * x)
2611 {
2612   if (x == NULL)
2613     return SUCCESS;
2614
2615   if (scalar_check (x, 0) == FAILURE)
2616     return FAILURE;
2617
2618   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2619     return FAILURE;
2620
2621   if (kind_value_check(x, 0, 4) == FAILURE)
2622     return FAILURE;
2623
2624   return SUCCESS;
2625 }
2626
2627
2628 try
2629 gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
2630 {
2631   if (scalar_check (seconds, 0) == FAILURE)
2632     return FAILURE;
2633
2634   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2635     return FAILURE;
2636
2637   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2638     {
2639       gfc_error (
2640         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
2641         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
2642       return FAILURE;
2643     }
2644
2645   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2646     return FAILURE;
2647
2648   if (status == NULL)
2649     return SUCCESS;
2650
2651   if (scalar_check (status, 2) == FAILURE)
2652     return FAILURE;
2653
2654   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2655     return FAILURE;
2656
2657   return SUCCESS;
2658 }
2659
2660
2661 try
2662 gfc_check_rand (gfc_expr * x)
2663 {
2664   if (x == NULL)
2665     return SUCCESS;
2666
2667   if (scalar_check (x, 0) == FAILURE)
2668     return FAILURE;
2669
2670   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2671     return FAILURE;
2672
2673   if (kind_value_check(x, 0, 4) == FAILURE)
2674     return FAILURE;
2675
2676   return SUCCESS;
2677 }
2678
2679 try
2680 gfc_check_srand (gfc_expr * x)
2681 {
2682   if (scalar_check (x, 0) == FAILURE)
2683     return FAILURE;
2684
2685   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2686     return FAILURE;
2687
2688   if (kind_value_check(x, 0, 4) == FAILURE)
2689     return FAILURE;
2690
2691   return SUCCESS;
2692 }
2693
2694 try
2695 gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
2696 {
2697   if (scalar_check (time, 0) == FAILURE)
2698     return FAILURE;
2699
2700   if (type_check (time, 0, BT_INTEGER) == FAILURE)
2701     return FAILURE;
2702
2703   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
2704     return FAILURE;
2705
2706   return SUCCESS;
2707 }
2708
2709 try
2710 gfc_check_etime (gfc_expr * x)
2711 {
2712   if (array_check (x, 0) == FAILURE)
2713     return FAILURE;
2714
2715   if (rank_check (x, 0, 1) == FAILURE)
2716     return FAILURE;
2717
2718   if (variable_check (x, 0) == FAILURE)
2719     return FAILURE;
2720
2721   if (type_check (x, 0, BT_REAL) == FAILURE)
2722     return FAILURE;
2723
2724   if (kind_value_check(x, 0, 4) == FAILURE)
2725     return FAILURE;
2726
2727   return SUCCESS;
2728 }
2729
2730 try
2731 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2732 {
2733   if (array_check (values, 0) == FAILURE)
2734     return FAILURE;
2735
2736   if (rank_check (values, 0, 1) == FAILURE)
2737     return FAILURE;
2738
2739   if (variable_check (values, 0) == FAILURE)
2740     return FAILURE;
2741
2742   if (type_check (values, 0, BT_REAL) == FAILURE)
2743     return FAILURE;
2744
2745   if (kind_value_check(values, 0, 4) == FAILURE)
2746     return FAILURE;
2747
2748   if (scalar_check (time, 1) == FAILURE)
2749     return FAILURE;
2750
2751   if (type_check (time, 1, BT_REAL) == FAILURE)
2752     return FAILURE;
2753
2754   if (kind_value_check(time, 1, 4) == FAILURE)
2755     return FAILURE;
2756
2757   return SUCCESS;
2758 }
2759
2760
2761 try
2762 gfc_check_fdate_sub (gfc_expr * date)
2763 {
2764   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2765     return FAILURE;
2766
2767   return SUCCESS;
2768 }
2769
2770
2771 try
2772 gfc_check_gerror (gfc_expr * msg)
2773 {
2774   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2775     return FAILURE;
2776
2777   return SUCCESS;
2778 }
2779
2780
2781 try
2782 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2783 {
2784   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2785     return FAILURE;
2786
2787   if (status == NULL)
2788     return SUCCESS;
2789
2790   if (scalar_check (status, 1) == FAILURE)
2791     return FAILURE;
2792
2793   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2794     return FAILURE;
2795
2796   return SUCCESS;
2797 }
2798
2799
2800 try
2801 gfc_check_getlog (gfc_expr * msg)
2802 {
2803   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
2804     return FAILURE;
2805
2806   return SUCCESS;
2807 }
2808
2809
2810 try
2811 gfc_check_exit (gfc_expr * status)
2812 {
2813   if (status == NULL)
2814     return SUCCESS;
2815
2816   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2817     return FAILURE;
2818
2819   if (scalar_check (status, 0) == FAILURE)
2820     return FAILURE;
2821
2822   return SUCCESS;
2823 }
2824
2825
2826 try
2827 gfc_check_flush (gfc_expr * unit)
2828 {
2829   if (unit == NULL)
2830     return SUCCESS;
2831
2832   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2833     return FAILURE;
2834
2835   if (scalar_check (unit, 0) == FAILURE)
2836     return FAILURE;
2837
2838   return SUCCESS;
2839 }
2840
2841
2842 try
2843 gfc_check_free (gfc_expr * i)
2844 {
2845   if (type_check (i, 0, BT_INTEGER) == FAILURE)
2846     return FAILURE;
2847
2848   if (scalar_check (i, 0) == FAILURE)
2849     return FAILURE;
2850
2851   return SUCCESS;
2852 }
2853
2854
2855 try
2856 gfc_check_hostnm (gfc_expr * name)
2857 {
2858   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2859     return FAILURE;
2860
2861   return SUCCESS;
2862 }
2863
2864
2865 try
2866 gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
2867 {
2868   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2869     return FAILURE;
2870
2871   if (status == NULL)
2872     return SUCCESS;
2873
2874   if (scalar_check (status, 1) == FAILURE)
2875     return FAILURE;
2876
2877   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2878     return FAILURE;
2879
2880   return SUCCESS;
2881 }
2882
2883
2884 try
2885 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
2886 {
2887   if (scalar_check (unit, 0) == FAILURE)
2888     return FAILURE;
2889
2890   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2891     return FAILURE;
2892
2893   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
2894     return FAILURE;
2895
2896   return SUCCESS;
2897 }
2898
2899
2900 try
2901 gfc_check_isatty (gfc_expr * unit)
2902 {
2903   if (unit == NULL)
2904     return FAILURE;
2905
2906   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2907     return FAILURE;
2908
2909   if (scalar_check (unit, 0) == FAILURE)
2910     return FAILURE;
2911
2912   return SUCCESS;
2913 }
2914
2915
2916 try
2917 gfc_check_perror (gfc_expr * string)
2918 {
2919   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
2920     return FAILURE;
2921
2922   return SUCCESS;
2923 }
2924
2925
2926 try
2927 gfc_check_umask (gfc_expr * mask)
2928 {
2929   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2930     return FAILURE;
2931
2932   if (scalar_check (mask, 0) == FAILURE)
2933     return FAILURE;
2934
2935   return SUCCESS;
2936 }
2937
2938
2939 try
2940 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2941 {
2942   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2943     return FAILURE;
2944
2945   if (scalar_check (mask, 0) == FAILURE)
2946     return FAILURE;
2947
2948   if (old == NULL)
2949     return SUCCESS;
2950
2951   if (scalar_check (old, 1) == FAILURE)
2952     return FAILURE;
2953
2954   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2955     return FAILURE;
2956
2957   return SUCCESS;
2958 }
2959
2960
2961 try
2962 gfc_check_unlink (gfc_expr * name)
2963 {
2964   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2965     return FAILURE;
2966
2967   return SUCCESS;
2968 }
2969
2970
2971 try
2972 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2973 {
2974   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2975     return FAILURE;
2976
2977   if (status == NULL)
2978     return SUCCESS;
2979
2980   if (scalar_check (status, 1) == FAILURE)
2981     return FAILURE;
2982
2983   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2984     return FAILURE;
2985
2986   return SUCCESS;
2987 }
2988
2989
2990 try
2991 gfc_check_signal (gfc_expr * number, gfc_expr * handler)
2992 {
2993   if (scalar_check (number, 0) == FAILURE)
2994     return FAILURE;
2995
2996   if (type_check (number, 0, BT_INTEGER) == FAILURE)
2997     return FAILURE;
2998
2999   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3000     {
3001       gfc_error (
3002         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3003         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3004       return FAILURE;
3005     }
3006
3007   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3008     return FAILURE;
3009
3010   return SUCCESS;
3011 }
3012
3013
3014 try
3015 gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
3016 {
3017   if (scalar_check (number, 0) == FAILURE)
3018     return FAILURE;
3019
3020   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3021     return FAILURE;
3022
3023   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3024     {
3025       gfc_error (
3026         "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
3027         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
3028       return FAILURE;
3029     }
3030
3031   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3032     return FAILURE;
3033
3034   if (status == NULL)
3035     return SUCCESS;
3036
3037   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3038     return FAILURE;
3039
3040   if (scalar_check (status, 2) == FAILURE)
3041     return FAILURE;
3042
3043   return SUCCESS;
3044 }
3045
3046
3047 try
3048 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
3049 {
3050   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3051     return FAILURE;
3052
3053   if (scalar_check (status, 1) == FAILURE)
3054     return FAILURE;
3055
3056   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3057     return FAILURE;
3058
3059   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3060     return FAILURE;
3061
3062   return SUCCESS;
3063 }
3064
3065
3066 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3067 try
3068 gfc_check_and (gfc_expr * i, gfc_expr * j)
3069 {
3070   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3071     {
3072       gfc_error (
3073         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3074         gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
3075       return FAILURE;
3076     }
3077
3078   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3079     {
3080       gfc_error (
3081         "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
3082         gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
3083       return FAILURE;
3084     }
3085
3086   if (i->ts.type != j->ts.type)
3087     {
3088       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3089                  "have the same type", gfc_current_intrinsic_arg[0],
3090                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3091                  &j->where);
3092       return FAILURE;
3093     }
3094
3095   if (scalar_check (i, 0) == FAILURE)
3096     return FAILURE;
3097
3098   if (scalar_check (j, 1) == FAILURE)
3099     return FAILURE;
3100
3101   return SUCCESS;
3102 }