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