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