gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004 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, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, 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 /* The fundamental complaint function of this source file.  This
  37    function can be called in all kinds of ways.  */
  38
  39 static void
  40 must_be (gfc_expr * e, int n, const char *thing)
  41 {
  42
  43   gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
  44              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
  45              thing);
  46 }
  47
  48
  49 /* Check the type of an expression.  */
  50
  51 static try
  52 type_check (gfc_expr * e, int n, bt type)
  53 {
  54
  55   if (e->ts.type == type)
  56     return SUCCESS;
  57
  58   must_be (e, n, gfc_basic_typename (type));
  59
  60   return FAILURE;
  61 }
  62
  63
  64 /* Check that the expression is a numeric type.  */
  65
  66 static try
  67 numeric_check (gfc_expr * e, int n)
  68 {
  69
  70   if (gfc_numeric_ts (&e->ts))
  71     return SUCCESS;
  72
  73   must_be (e, n, "a numeric type");
  74
  75   return FAILURE;
  76 }
  77
  78
  79 /* Check that an expression is integer or real.  */
  80
  81 static try
  82 int_or_real_check (gfc_expr * e, int n)
  83 {
  84
  85   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
  86     {
  87       must_be (e, n, "INTEGER or REAL");
  88       return FAILURE;
  89     }
  90
  91   return SUCCESS;
  92 }
  93
  94
  95 /* Check that the expression is an optional constant integer
  96    and that it specifies a valid kind for that type.  */
  97
  98 static try
  99 kind_check (gfc_expr * k, int n, bt type)
 100 {
 101   int kind;
 102
 103   if (k == NULL)
 104     return SUCCESS;
 105
 106   if (type_check (k, n, BT_INTEGER) == FAILURE)
 107     return FAILURE;
 108
 109   if (k->expr_type != EXPR_CONSTANT)
 110     {
 111       must_be (k, n, "a constant");
 112       return FAILURE;
 113     }
 114
 115   if (gfc_extract_int (k, &kind) != NULL
 116       || gfc_validate_kind (type, kind, true) < 0)
 117     {
 118       gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
 119                  &k->where);
 120       return FAILURE;
 121     }
 122
 123   return SUCCESS;
 124 }
 125
 126
 127 /* Make sure the expression is a double precision real.  */
 128
 129 static try
 130 double_check (gfc_expr * d, int n)
 131 {
 132   if (type_check (d, n, BT_REAL) == FAILURE)
 133     return FAILURE;
 134
 135   if (d->ts.kind != gfc_default_double_kind)
 136     {
 137       must_be (d, n, "double precision");
 138       return FAILURE;
 139     }
 140
 141   return SUCCESS;
 142 }
 143
 144
 145 /* Make sure the expression is a logical array.  */
 146
 147 static try
 148 logical_array_check (gfc_expr * array, int n)
 149 {
 150
 151   if (array->ts.type != BT_LOGICAL || array->rank == 0)
 152     {
 153       must_be (array, n, "a logical array");
 154       return FAILURE;
 155     }
 156
 157   return SUCCESS;
 158 }
 159
 160
 161 /* Make sure an expression is an array.  */
 162
 163 static try
 164 array_check (gfc_expr * e, int n)
 165 {
 166
 167   if (e->rank != 0)
 168     return SUCCESS;
 169
 170   must_be (e, n, "an array");
 171
 172   return FAILURE;
 173 }
 174
 175
 176 /* Make sure an expression is a scalar.  */
 177
 178 static try
 179 scalar_check (gfc_expr * e, int n)
 180 {
 181
 182   if (e->rank == 0)
 183     return SUCCESS;
 184
 185   must_be (e, n, "a scalar");
 186
 187   return FAILURE;
 188 }
 189
 190
 191 /* Make sure two expression have the same type.  */
 192
 193 static try
 194 same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
 195 {
 196   char message[100];
 197
 198   if (gfc_compare_types (&e->ts, &f->ts))
 199     return SUCCESS;
 200
 201   sprintf (message, "the same type and kind as '%s'",
 202            gfc_current_intrinsic_arg[n]);
 203
 204   must_be (f, m, message);
 205
 206   return FAILURE;
 207 }
 208
 209
 210 /* Make sure that an expression has a certain (nonzero) rank.  */
 211
 212 static try
 213 rank_check (gfc_expr * e, int n, int rank)
 214 {
 215   char message[100];
 216
 217   if (e->rank == rank)
 218     return SUCCESS;
 219
 220   sprintf (message, "of rank %d", rank);
 221
 222   must_be (e, n, message);
 223
 224   return FAILURE;
 225 }
 226
 227
 228 /* Make sure a variable expression is not an optional dummy argument.  */
 229
 230 static try
 231 nonoptional_check (gfc_expr * e, int n)
 232 {
 233
 234   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
 235     {
 236       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
 237                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 238                  &e->where);
 239
 240     }
 241
 242   /* TODO: Recursive check on nonoptional variables?  */
 243
 244   return SUCCESS;
 245 }
 246
 247
 248 /* Check that an expression has a particular kind.  */
 249
 250 static try
 251 kind_value_check (gfc_expr * e, int n, int k)
 252 {
 253   char message[100];
 254
 255   if (e->ts.kind == k)
 256     return SUCCESS;
 257
 258   sprintf (message, "of kind %d", k);
 259
 260   must_be (e, n, message);
 261   return FAILURE;
 262 }
 263
 264
 265 /* Make sure an expression is a variable.  */
 266
 267 static try
 268 variable_check (gfc_expr * e, int n)
 269 {
 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   must_be (e, n, "a variable");
 287
 288   return FAILURE;
 289 }
 290
 291
 292 /* Check the common DIM parameter for correctness.  */
 293
 294 static try
 295 dim_check (gfc_expr * dim, int n, int optional)
 296 {
 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
 367   if (type_check (a, 0, BT_REAL) == FAILURE)
 368     return FAILURE;
 369   if (kind_check (kind, 1, type) == FAILURE)
 370     return FAILURE;
 371
 372   return SUCCESS;
 373 }
 374
 375 /* Check subroutine suitable for ceiling, floor and nint.  */
 376
 377 try
 378 gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
 379 {
 380
 381   return check_a_kind (a, kind, BT_INTEGER);
 382 }
 383
 384 /* Check subroutine suitable for aint, anint.  */
 385
 386 try
 387 gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
 388 {
 389
 390   return check_a_kind (a, kind, BT_REAL);
 391 }
 392
 393 try
 394 gfc_check_abs (gfc_expr * a)
 395 {
 396
 397   if (numeric_check (a, 0) == FAILURE)
 398     return FAILURE;
 399
 400   return SUCCESS;
 401 }
 402
 403
 404 try
 405 gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
 406 {
 407
 408   if (logical_array_check (mask, 0) == FAILURE)
 409     return FAILURE;
 410
 411   if (dim_check (dim, 1, 1) == FAILURE)
 412     return FAILURE;
 413
 414   return SUCCESS;
 415 }
 416
 417
 418 try
 419 gfc_check_allocated (gfc_expr * array)
 420 {
 421
 422   if (variable_check (array, 0) == FAILURE)
 423     return FAILURE;
 424
 425   if (array_check (array, 0) == FAILURE)
 426     return FAILURE;
 427
 428   if (!array->symtree->n.sym->attr.allocatable)
 429     {
 430       must_be (array, 0, "ALLOCATABLE");
 431       return FAILURE;
 432     }
 433
 434   return SUCCESS;
 435 }
 436
 437
 438 /* Common check function where the first argument must be real or
 439    integer and the second argument must be the same as the first.  */
 440
 441 try
 442 gfc_check_a_p (gfc_expr * a, gfc_expr * p)
 443 {
 444
 445   if (int_or_real_check (a, 0) == FAILURE)
 446     return FAILURE;
 447
 448   if (same_type_check (a, 0, p, 1) == FAILURE)
 449     return FAILURE;
 450
 451   return SUCCESS;
 452 }
 453
 454
 455 try
 456 gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
 457 {
 458   symbol_attribute attr;
 459   int i;
 460   try t;
 461
 462   if (variable_check (pointer, 0) == FAILURE)
 463     return FAILURE;
 464
 465   attr = gfc_variable_attr (pointer, NULL);
 466   if (!attr.pointer)
 467     {
 468       must_be (pointer, 0, "a POINTER");
 469       return FAILURE;
 470     }
 471
 472   if (target == NULL)
 473     return SUCCESS;
 474
 475   /* Target argument is optional.  */
 476   if (target->expr_type == EXPR_NULL)
 477     {
 478       gfc_error ("NULL pointer at %L is not permitted as actual argument "
 479                  "of '%s' intrinsic function",
 480                  &target->where, gfc_current_intrinsic);
 481       return FAILURE;
 482     }
 483
 484   attr = gfc_variable_attr (target, NULL);
 485   if (!attr.pointer && !attr.target)
 486     {
 487       must_be (target, 1, "a POINTER or a TARGET");
 488       return FAILURE;
 489     }
 490
 491   t = SUCCESS;
 492   if (same_type_check (pointer, 0, target, 1) == FAILURE)
 493     t = FAILURE;
 494   if (rank_check (target, 0, pointer->rank) == FAILURE)
 495     t = FAILURE;
 496   if (target->rank > 0)
 497     {
 498       for (i = 0; i < target->rank; i++)
 499         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 500           {
 501             gfc_error ("Array section with a vector subscript at %L shall not "
 502                        "be the target of an pointer",
 503                        &target->where);
 504             t = FAILURE;
 505             break;
 506           }
 507     }
 508   return t;
 509 }
 510
 511
 512 try
 513 gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
 514 {
 515   if (type_check (y, 0, BT_REAL) == FAILURE)
 516     return FAILURE;
 517   if (same_type_check (y, 0, x, 1) == FAILURE)
 518     return FAILURE;
 519
 520   return SUCCESS;
 521 }
 522
 523
 524 /* BESJN and BESYN functions.  */
 525
 526 try
 527 gfc_check_besn (gfc_expr * n, gfc_expr * x)
 528 {
 529
 530   if (scalar_check (n, 0) == FAILURE)
 531     return FAILURE;
 532
 533   if (type_check (n, 0, BT_INTEGER) == FAILURE)
 534     return FAILURE;
 535
 536   if (scalar_check (x, 1) == FAILURE)
 537     return FAILURE;
 538
 539   if (type_check (x, 1, BT_REAL) == FAILURE)
 540     return FAILURE;
 541
 542   return SUCCESS;
 543 }
 544
 545
 546 try
 547 gfc_check_btest (gfc_expr * i, gfc_expr * pos)
 548 {
 549
 550   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 551     return FAILURE;
 552   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 553     return FAILURE;
 554
 555   return SUCCESS;
 556 }
 557
 558
 559 try
 560 gfc_check_char (gfc_expr * i, gfc_expr * kind)
 561 {
 562
 563   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 564     return FAILURE;
 565   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 566     return FAILURE;
 567
 568   return SUCCESS;
 569 }
 570
 571
 572 try
 573 gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 574 {
 575
 576   if (numeric_check (x, 0) == FAILURE)
 577     return FAILURE;
 578
 579   if (y != NULL)
 580     {
 581       if (numeric_check (y, 1) == FAILURE)
 582         return FAILURE;
 583
 584       if (x->ts.type == BT_COMPLEX)
 585         {
 586           must_be (y, 1, "not be present if 'x' is COMPLEX");
 587           return FAILURE;
 588         }
 589     }
 590
 591   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 592     return FAILURE;
 593
 594   return SUCCESS;
 595 }
 596
 597
 598 try
 599 gfc_check_count (gfc_expr * mask, gfc_expr * dim)
 600 {
 601
 602   if (logical_array_check (mask, 0) == FAILURE)
 603     return FAILURE;
 604   if (dim_check (dim, 1, 1) == FAILURE)
 605     return FAILURE;
 606
 607   return SUCCESS;
 608 }
 609
 610
 611 try
 612 gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
 613 {
 614
 615   if (array_check (array, 0) == FAILURE)
 616     return FAILURE;
 617
 618   if (array->rank == 1)
 619     {
 620       if (scalar_check (shift, 1) == FAILURE)
 621         return FAILURE;
 622     }
 623   else
 624     {
 625       /* TODO: more requirements on shift parameter.  */
 626     }
 627
 628   if (dim_check (dim, 2, 1) == FAILURE)
 629     return FAILURE;
 630
 631   return SUCCESS;
 632 }
 633
 634
 635 try
 636 gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 637 {
 638
 639   if (numeric_check (x, 0) == FAILURE)
 640     return FAILURE;
 641
 642   if (y != NULL)
 643     {
 644       if (numeric_check (y, 1) == FAILURE)
 645         return FAILURE;
 646
 647       if (x->ts.type == BT_COMPLEX)
 648         {
 649           must_be (y, 1, "not be present if 'x' is COMPLEX");
 650           return FAILURE;
 651         }
 652     }
 653
 654   return SUCCESS;
 655 }
 656
 657
 658 try
 659 gfc_check_dble (gfc_expr * x)
 660 {
 661
 662   if (numeric_check (x, 0) == FAILURE)
 663     return FAILURE;
 664
 665   return SUCCESS;
 666 }
 667
 668
 669 try
 670 gfc_check_digits (gfc_expr * x)
 671 {
 672
 673   if (int_or_real_check (x, 0) == FAILURE)
 674     return FAILURE;
 675
 676   return SUCCESS;
 677 }
 678
 679
 680 try
 681 gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
 682 {
 683
 684   switch (vector_a->ts.type)
 685     {
 686     case BT_LOGICAL:
 687       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 688         return FAILURE;
 689       break;
 690
 691     case BT_INTEGER:
 692     case BT_REAL:
 693     case BT_COMPLEX:
 694       if (numeric_check (vector_b, 1) == FAILURE)
 695         return FAILURE;
 696       break;
 697
 698     default:
 699       must_be (vector_a, 0, "numeric or LOGICAL");
 700       return FAILURE;
 701     }
 702
 703   if (rank_check (vector_a, 0, 1) == FAILURE)
 704     return FAILURE;
 705
 706   if (rank_check (vector_b, 1, 1) == FAILURE)
 707     return FAILURE;
 708
 709   return SUCCESS;
 710 }
 711
 712
 713 try
 714 gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
 715                    gfc_expr * dim)
 716 {
 717
 718   if (array_check (array, 0) == FAILURE)
 719     return FAILURE;
 720
 721   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 722     return FAILURE;
 723
 724   if (array->rank == 1)
 725     {
 726       if (scalar_check (shift, 2) == FAILURE)
 727         return FAILURE;
 728     }
 729   else
 730     {
 731       /* TODO: more weird restrictions on shift.  */
 732     }
 733
 734   if (boundary != NULL)
 735     {
 736       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 737         return FAILURE;
 738
 739       /* TODO: more restrictions on boundary.  */
 740     }
 741
 742   if (dim_check (dim, 1, 1) == FAILURE)
 743     return FAILURE;
 744
 745   return SUCCESS;
 746 }
 747
 748
 749 try
 750 gfc_check_fnum (gfc_expr * unit)
 751 {
 752
 753   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
 754     return FAILURE;
 755
 756   if (scalar_check (unit, 0) == FAILURE)
 757     return FAILURE;
 758
 759   return SUCCESS;
 760 }
 761
 762
 763 /* This is used for the g77 one-argument Bessel functions, and the
 764    error function.  */
 765
 766 try
 767 gfc_check_g77_math1 (gfc_expr * x)
 768 {
 769
 770   if (scalar_check (x, 0) == FAILURE)
 771     return FAILURE;
 772
 773   if (type_check (x, 0, BT_REAL) == FAILURE)
 774     return FAILURE;
 775
 776   return SUCCESS;
 777 }
 778
 779
 780 try
 781 gfc_check_huge (gfc_expr * x)
 782 {
 783
 784   if (int_or_real_check (x, 0) == FAILURE)
 785     return FAILURE;
 786
 787   return SUCCESS;
 788 }
 789
 790
 791 /* Check that the single argument is an integer.  */
 792
 793 try
 794 gfc_check_i (gfc_expr * i)
 795 {
 796
 797   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 798     return FAILURE;
 799
 800   return SUCCESS;
 801 }
 802
 803
 804 try
 805 gfc_check_iand (gfc_expr * i, gfc_expr * j)
 806 {
 807
 808   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 809     return FAILURE;
 810
 811   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 812     return FAILURE;
 813
 814   if (i->ts.kind != j->ts.kind)
 815     {
 816       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 817                           &i->where) == FAILURE)
 818         return FAILURE;
 819     }
 820
 821   return SUCCESS;
 822 }
 823
 824
 825 try
 826 gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
 827 {
 828
 829   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 830     return FAILURE;
 831
 832   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 833     return FAILURE;
 834
 835   return SUCCESS;
 836 }
 837
 838
 839 try
 840 gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
 841 {
 842
 843   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 844     return FAILURE;
 845
 846   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 847     return FAILURE;
 848
 849   if (type_check (len, 2, BT_INTEGER) == FAILURE)
 850     return FAILURE;
 851
 852   return SUCCESS;
 853 }
 854
 855
 856 try
 857 gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
 858 {
 859
 860   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 861     return FAILURE;
 862
 863   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 864     return FAILURE;
 865
 866   return SUCCESS;
 867 }
 868
 869
 870 try
 871 gfc_check_idnint (gfc_expr * a)
 872 {
 873
 874   if (double_check (a, 0) == FAILURE)
 875     return FAILURE;
 876
 877   return SUCCESS;
 878 }
 879
 880
 881 try
 882 gfc_check_ieor (gfc_expr * i, gfc_expr * j)
 883 {
 884
 885   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 886     return FAILURE;
 887
 888   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 889     return FAILURE;
 890
 891   if (i->ts.kind != j->ts.kind)
 892     {
 893       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 894                           &i->where) == FAILURE)
 895         return FAILURE;
 896     }
 897
 898   return SUCCESS;
 899 }
 900
 901
 902 try
 903 gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
 904 {
 905
 906   if (type_check (string, 0, BT_CHARACTER) == FAILURE
 907       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
 908     return FAILURE;
 909
 910
 911   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
 912     return FAILURE;
 913
 914   if (string->ts.kind != substring->ts.kind)
 915     {
 916       must_be (substring, 1, "the same kind as 'string'");
 917       return FAILURE;
 918     }
 919
 920   return SUCCESS;
 921 }
 922
 923
 924 try
 925 gfc_check_int (gfc_expr * x, gfc_expr * kind)
 926 {
 927
 928   if (numeric_check (x, 0) == FAILURE
 929       || kind_check (kind, 1, BT_INTEGER) == FAILURE)
 930     return FAILURE;
 931
 932   return SUCCESS;
 933 }
 934
 935
 936 try
 937 gfc_check_ior (gfc_expr * i, gfc_expr * j)
 938 {
 939
 940   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 941     return FAILURE;
 942
 943   if (type_check (j, 1, BT_INTEGER) == FAILURE)
 944     return FAILURE;
 945
 946   if (i->ts.kind != j->ts.kind)
 947     {
 948       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 949                           &i->where) == FAILURE)
 950     return FAILURE;
 951     }
 952
 953   return SUCCESS;
 954 }
 955
 956
 957 try
 958 gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
 959 {
 960
 961   if (type_check (i, 0, BT_INTEGER) == FAILURE
 962       || type_check (shift, 1, BT_INTEGER) == FAILURE)
 963     return FAILURE;
 964
 965   return SUCCESS;
 966 }
 967
 968
 969 try
 970 gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
 971 {
 972
 973   if (type_check (i, 0, BT_INTEGER) == FAILURE
 974       || type_check (shift, 1, BT_INTEGER) == FAILURE)
 975     return FAILURE;
 976
 977   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
 978     return FAILURE;
 979
 980   return SUCCESS;
 981 }
 982
 983
 984 try
 985 gfc_check_kind (gfc_expr * x)
 986 {
 987
 988   if (x->ts.type == BT_DERIVED)
 989     {
 990       must_be (x, 0, "a non-derived type");
 991       return FAILURE;
 992     }
 993
 994   return SUCCESS;
 995 }
 996
 997
 998 try
 999 gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
1000 {
1001
1002   if (array_check (array, 0) == FAILURE)
1003     return FAILURE;
1004
1005   if (dim != NULL)
1006     {
1007       if (dim_check (dim, 1, 1) == FAILURE)
1008         return FAILURE;
1009
1010       if (dim_rank_check (dim, array, 1) == FAILURE)
1011         return FAILURE;
1012     }
1013   return SUCCESS;
1014 }
1015
1016
1017 try
1018 gfc_check_logical (gfc_expr * a, gfc_expr * kind)
1019 {
1020
1021   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1022     return FAILURE;
1023   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1024     return FAILURE;
1025
1026   return SUCCESS;
1027 }
1028
1029
1030 /* Min/max family.  */
1031
1032 static try
1033 min_max_args (gfc_actual_arglist * arg)
1034 {
1035
1036   if (arg == NULL || arg->next == NULL)
1037     {
1038       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1039                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1040       return FAILURE;
1041     }
1042
1043   return SUCCESS;
1044 }
1045
1046
1047 static try
1048 check_rest (bt type, int kind, gfc_actual_arglist * arg)
1049 {
1050   gfc_expr *x;
1051   int n;
1052
1053   if (min_max_args (arg) == FAILURE)
1054     return FAILURE;
1055
1056   n = 1;
1057
1058   for (; arg; arg = arg->next, n++)
1059     {
1060       x = arg->expr;
1061       if (x->ts.type != type || x->ts.kind != kind)
1062         {
1063           if (x->ts.type == type)
1064             {
1065               if (gfc_notify_std (GFC_STD_GNU,
1066                     "Extension: Different type kinds at %L", &x->where)
1067                   == FAILURE)
1068                 return FAILURE;
1069             }
1070           else
1071             {
1072               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
1073                          n, gfc_current_intrinsic, &x->where,
1074                          gfc_basic_typename (type), kind);
1075               return FAILURE;
1076             }
1077         }
1078     }
1079
1080   return SUCCESS;
1081 }
1082
1083
1084 try
1085 gfc_check_min_max (gfc_actual_arglist * arg)
1086 {
1087   gfc_expr *x;
1088
1089   if (min_max_args (arg) == FAILURE)
1090     return FAILURE;
1091
1092   x = arg->expr;
1093
1094   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1095     {
1096       gfc_error
1097         ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL",
1098          gfc_current_intrinsic, &x->where);
1099       return FAILURE;
1100     }
1101
1102   return check_rest (x->ts.type, x->ts.kind, arg);
1103 }
1104
1105
1106 try
1107 gfc_check_min_max_integer (gfc_actual_arglist * arg)
1108 {
1109
1110   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1111 }
1112
1113
1114 try
1115 gfc_check_min_max_real (gfc_actual_arglist * arg)
1116 {
1117
1118   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1119 }
1120
1121
1122 try
1123 gfc_check_min_max_double (gfc_actual_arglist * arg)
1124 {
1125
1126   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1127 }
1128
1129 /* End of min/max family.  */
1130
1131
1132 try
1133 gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
1134 {
1135
1136   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1137     {
1138       must_be (matrix_a, 0, "numeric or LOGICAL");
1139       return FAILURE;
1140     }
1141
1142   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1143     {
1144       must_be (matrix_b, 0, "numeric or LOGICAL");
1145       return FAILURE;
1146     }
1147
1148   switch (matrix_a->rank)
1149     {
1150     case 1:
1151       if (rank_check (matrix_b, 1, 2) == FAILURE)
1152         return FAILURE;
1153       break;
1154
1155     case 2:
1156       if (matrix_b->rank == 2)
1157         break;
1158       if (rank_check (matrix_b, 1, 1) == FAILURE)
1159         return FAILURE;
1160       break;
1161
1162     default:
1163       must_be (matrix_a, 0, "of rank 1 or 2");
1164       return FAILURE;
1165     }
1166
1167   return SUCCESS;
1168 }
1169
1170
1171 /* Whoever came up with this interface was probably on something.
1172    The possibilities for the occupation of the second and third
1173    parameters are:
1174
1175          Arg #2     Arg #3
1176          NULL       NULL
1177          DIM        NULL
1178          MASK       NULL
1179          NULL       MASK             minloc(array, mask=m)
1180          DIM        MASK
1181
1182    I.e. in the case of minloc(array,mask), mask will be in the second
1183    position of the argument list and we'll have to fix that up.  */
1184
1185 try
1186 gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
1187 {
1188   gfc_expr *a, *m, *d;
1189
1190   a = ap->expr;
1191   if (int_or_real_check (a, 0) == FAILURE
1192       || array_check (a, 0) == FAILURE)
1193     return FAILURE;
1194
1195   d = ap->next->expr;
1196   m = ap->next->next->expr;
1197
1198   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1199       && ap->next->name[0] == '\0')
1200     {
1201       m = d;
1202       d = NULL;
1203
1204       ap->next->expr = NULL;
1205       ap->next->next->expr = m;
1206     }
1207
1208   if (d != NULL
1209       && (scalar_check (d, 1) == FAILURE
1210       || type_check (d, 1, BT_INTEGER) == FAILURE))
1211     return FAILURE;
1212
1213   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1214     return FAILURE;
1215
1216   return SUCCESS;
1217 }
1218
1219
1220 /* Similar to minloc/maxloc, the argument list might need to be
1221    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1222    difference is that MINLOC/MAXLOC take an additional KIND argument.
1223    The possibilities are:
1224
1225          Arg #2     Arg #3
1226          NULL       NULL
1227          DIM        NULL
1228          MASK       NULL
1229          NULL       MASK             minval(array, mask=m)
1230          DIM        MASK
1231
1232    I.e. in the case of minval(array,mask), mask will be in the second
1233    position of the argument list and we'll have to fix that up.  */
1234
1235 static try
1236 check_reduction (gfc_actual_arglist * ap)
1237 {
1238   gfc_expr *m, *d;
1239
1240   d = ap->next->expr;
1241   m = ap->next->next->expr;
1242
1243   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1244       && ap->next->name[0] == '\0')
1245     {
1246       m = d;
1247       d = NULL;
1248
1249       ap->next->expr = NULL;
1250       ap->next->next->expr = m;
1251     }
1252
1253   if (d != NULL
1254       && (scalar_check (d, 1) == FAILURE
1255       || type_check (d, 1, BT_INTEGER) == FAILURE))
1256     return FAILURE;
1257
1258   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1259     return FAILURE;
1260
1261   return SUCCESS;
1262 }
1263
1264
1265 try
1266 gfc_check_minval_maxval (gfc_actual_arglist * ap)
1267 {
1268
1269   if (int_or_real_check (ap->expr, 0) == FAILURE
1270       || array_check (ap->expr, 0) == FAILURE)
1271     return FAILURE;
1272
1273   return check_reduction (ap);
1274 }
1275
1276
1277 try
1278 gfc_check_product_sum (gfc_actual_arglist * ap)
1279 {
1280
1281   if (numeric_check (ap->expr, 0) == FAILURE
1282       || array_check (ap->expr, 0) == FAILURE)
1283     return FAILURE;
1284
1285   return check_reduction (ap);
1286 }
1287
1288
1289 try
1290 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
1291 {
1292
1293   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1294     return FAILURE;
1295
1296   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1297     return FAILURE;
1298
1299   return SUCCESS;
1300 }
1301
1302
1303 try
1304 gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1305 {
1306
1307   if (type_check (x, 0, BT_REAL) == FAILURE)
1308     return FAILURE;
1309
1310   if (type_check (s, 1, BT_REAL) == FAILURE)
1311     return FAILURE;
1312
1313   return SUCCESS;
1314 }
1315
1316
1317 try
1318 gfc_check_null (gfc_expr * mold)
1319 {
1320   symbol_attribute attr;
1321
1322   if (mold == NULL)
1323     return SUCCESS;
1324
1325   if (variable_check (mold, 0) == FAILURE)
1326     return FAILURE;
1327
1328   attr = gfc_variable_attr (mold, NULL);
1329
1330   if (!attr.pointer)
1331     {
1332       must_be (mold, 0, "a POINTER");
1333       return FAILURE;
1334     }
1335
1336   return SUCCESS;
1337 }
1338
1339
1340 try
1341 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
1342 {
1343
1344   if (array_check (array, 0) == FAILURE)
1345     return FAILURE;
1346
1347   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1348     return FAILURE;
1349
1350   if (mask->rank != 0 && mask->rank != array->rank)
1351     {
1352       must_be (array, 0, "conformable with 'mask' argument");
1353       return FAILURE;
1354     }
1355
1356   if (vector != NULL)
1357     {
1358       if (same_type_check (array, 0, vector, 2) == FAILURE)
1359         return FAILURE;
1360
1361       if (rank_check (vector, 2, 1) == FAILURE)
1362         return FAILURE;
1363
1364       /* TODO: More constraints here.  */
1365     }
1366
1367   return SUCCESS;
1368 }
1369
1370
1371 try
1372 gfc_check_precision (gfc_expr * x)
1373 {
1374
1375   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1376     {
1377       must_be (x, 0, "of type REAL or COMPLEX");
1378       return FAILURE;
1379     }
1380
1381   return SUCCESS;
1382 }
1383
1384
1385 try
1386 gfc_check_present (gfc_expr * a)
1387 {
1388   gfc_symbol *sym;
1389
1390   if (variable_check (a, 0) == FAILURE)
1391     return FAILURE;
1392
1393   sym = a->symtree->n.sym;
1394   if (!sym->attr.dummy)
1395     {
1396       must_be (a, 0, "a dummy variable");
1397       return FAILURE;
1398     }
1399
1400   if (!sym->attr.optional)
1401     {
1402       must_be (a, 0, "an OPTIONAL dummy variable");
1403       return FAILURE;
1404     }
1405
1406   return SUCCESS;
1407 }
1408
1409
1410 try
1411 gfc_check_radix (gfc_expr * x)
1412 {
1413
1414   if (int_or_real_check (x, 0) == FAILURE)
1415     return FAILURE;
1416
1417   return SUCCESS;
1418 }
1419
1420
1421 try
1422 gfc_check_range (gfc_expr * x)
1423 {
1424
1425   if (numeric_check (x, 0) == FAILURE)
1426     return FAILURE;
1427
1428   return SUCCESS;
1429 }
1430
1431
1432 /* real, float, sngl.  */
1433 try
1434 gfc_check_real (gfc_expr * a, gfc_expr * kind)
1435 {
1436
1437   if (numeric_check (a, 0) == FAILURE)
1438     return FAILURE;
1439
1440   if (kind_check (kind, 1, BT_REAL) == FAILURE)
1441     return FAILURE;
1442
1443   return SUCCESS;
1444 }
1445
1446
1447 try
1448 gfc_check_repeat (gfc_expr * x, gfc_expr * y)
1449 {
1450
1451   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1452     return FAILURE;
1453
1454   if (scalar_check (x, 0) == FAILURE)
1455     return FAILURE;
1456
1457   if (type_check (y, 0, BT_INTEGER) == FAILURE)
1458     return FAILURE;
1459
1460   if (scalar_check (y, 1) == FAILURE)
1461     return FAILURE;
1462
1463   return SUCCESS;
1464 }
1465
1466
1467 try
1468 gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
1469                    gfc_expr * pad, gfc_expr * order)
1470 {
1471   mpz_t size;
1472   int m;
1473
1474   if (array_check (source, 0) == FAILURE)
1475     return FAILURE;
1476
1477   if (rank_check (shape, 1, 1) == FAILURE)
1478     return FAILURE;
1479
1480   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
1481     return FAILURE;
1482
1483   if (gfc_array_size (shape, &size) != SUCCESS)
1484     {
1485       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
1486                  "array of constant size", &shape->where);
1487       return FAILURE;
1488     }
1489
1490   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
1491   mpz_clear (size);
1492
1493   if (m > 0)
1494     {
1495       gfc_error
1496         ("'shape' argument of 'reshape' intrinsic at %L has more than "
1497          stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where);
1498       return FAILURE;
1499     }
1500
1501   if (pad != NULL)
1502     {
1503       if (same_type_check (source, 0, pad, 2) == FAILURE)
1504         return FAILURE;
1505       if (array_check (pad, 2) == FAILURE)
1506         return FAILURE;
1507     }
1508
1509   if (order != NULL && array_check (order, 3) == FAILURE)
1510     return FAILURE;
1511
1512   return SUCCESS;
1513 }
1514
1515
1516 try
1517 gfc_check_scale (gfc_expr * x, gfc_expr * i)
1518 {
1519
1520   if (type_check (x, 0, BT_REAL) == FAILURE)
1521     return FAILURE;
1522
1523   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1524     return FAILURE;
1525
1526   return SUCCESS;
1527 }
1528
1529
1530 try
1531 gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1532 {
1533
1534   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1535     return FAILURE;
1536
1537   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
1538     return FAILURE;
1539
1540   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1541     return FAILURE;
1542
1543   if (same_type_check (x, 0, y, 1) == FAILURE)
1544     return FAILURE;
1545
1546   return SUCCESS;
1547 }
1548
1549
1550 try
1551 gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
1552 {
1553
1554   if (p == NULL && r == NULL)
1555     {
1556       gfc_error ("Missing arguments to %s intrinsic at %L",
1557                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1558
1559       return FAILURE;
1560     }
1561
1562   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
1563     return FAILURE;
1564
1565   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
1566     return FAILURE;
1567
1568   return SUCCESS;
1569 }
1570
1571
1572 try
1573 gfc_check_set_exponent (gfc_expr * x, gfc_expr * i)
1574 {
1575
1576   if (type_check (x, 0, BT_REAL) == FAILURE)
1577     return FAILURE;
1578
1579   if (type_check (i, 1, BT_INTEGER) == FAILURE)
1580     return FAILURE;
1581
1582   return SUCCESS;
1583 }
1584
1585
1586 try
1587 gfc_check_shape (gfc_expr * source)
1588 {
1589   gfc_array_ref *ar;
1590
1591   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
1592     return SUCCESS;
1593
1594   ar = gfc_find_array_ref (source);
1595
1596   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
1597     {
1598       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
1599                  "an assumed size array", &source->where);
1600       return FAILURE;
1601     }
1602
1603   return SUCCESS;
1604 }
1605
1606
1607 try
1608 gfc_check_size (gfc_expr * array, gfc_expr * dim)
1609 {
1610
1611   if (array_check (array, 0) == FAILURE)
1612     return FAILURE;
1613
1614   if (dim != NULL)
1615     {
1616       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
1617         return FAILURE;
1618
1619       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
1620         return FAILURE;
1621
1622       if (dim_rank_check (dim, array, 0) == FAILURE)
1623         return FAILURE;
1624     }
1625
1626   return SUCCESS;
1627 }
1628
1629
1630 try
1631 gfc_check_sign (gfc_expr * a, gfc_expr * b)
1632 {
1633
1634   if (int_or_real_check (a, 0) == FAILURE)
1635     return FAILURE;
1636
1637   if (same_type_check (a, 0, b, 1) == FAILURE)
1638     return FAILURE;
1639
1640   return SUCCESS;
1641 }
1642
1643
1644 try
1645 gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
1646 {
1647
1648   if (source->rank >= GFC_MAX_DIMENSIONS)
1649     {
1650       must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS));
1651       return FAILURE;
1652     }
1653
1654   if (dim_check (dim, 1, 0) == FAILURE)
1655     return FAILURE;
1656
1657   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
1658     return FAILURE;
1659
1660   if (scalar_check (ncopies, 2) == FAILURE)
1661     return FAILURE;
1662
1663   return SUCCESS;
1664 }
1665
1666
1667 try
1668 gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
1669 {
1670
1671   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1672     return FAILURE;
1673
1674   if (scalar_check (unit, 0) == FAILURE)
1675     return FAILURE;
1676
1677   if (type_check (array, 1, BT_INTEGER) == FAILURE
1678       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
1679     return FAILURE;
1680
1681   if (array_check (array, 1) == FAILURE)
1682     return FAILURE;
1683
1684   return SUCCESS;
1685 }
1686
1687
1688 try
1689 gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
1690 {
1691
1692   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1693     return FAILURE;
1694
1695   if (scalar_check (unit, 0) == FAILURE)
1696     return FAILURE;
1697
1698   if (type_check (array, 1, BT_INTEGER) == FAILURE
1699       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1700     return FAILURE;
1701
1702   if (array_check (array, 1) == FAILURE)
1703     return FAILURE;
1704
1705   if (status == NULL)
1706     return SUCCESS;
1707
1708   if (type_check (status, 2, BT_INTEGER) == FAILURE
1709       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
1710     return FAILURE;
1711
1712   if (scalar_check (status, 2) == FAILURE)
1713     return FAILURE;
1714
1715   return SUCCESS;
1716 }
1717
1718
1719 try
1720 gfc_check_stat (gfc_expr * name, gfc_expr * array)
1721 {
1722
1723   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1724     return FAILURE;
1725
1726   if (type_check (array, 1, BT_INTEGER) == FAILURE
1727       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1728     return FAILURE;
1729
1730   if (array_check (array, 1) == FAILURE)
1731     return FAILURE;
1732
1733   return SUCCESS;
1734 }
1735
1736
1737 try
1738 gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
1739 {
1740
1741   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1742     return FAILURE;
1743
1744   if (type_check (array, 1, BT_INTEGER) == FAILURE
1745       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1746     return FAILURE;
1747
1748   if (array_check (array, 1) == FAILURE)
1749     return FAILURE;
1750
1751   if (status == NULL)
1752     return SUCCESS;
1753
1754   if (type_check (status, 2, BT_INTEGER) == FAILURE
1755       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
1756     return FAILURE;
1757
1758   if (scalar_check (status, 2) == FAILURE)
1759     return FAILURE;
1760
1761   return SUCCESS;
1762 }
1763
1764
1765 try
1766 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
1767                     gfc_expr * mold ATTRIBUTE_UNUSED,
1768                     gfc_expr * size)
1769 {
1770
1771   if (size != NULL)
1772     {
1773       if (type_check (size, 2, BT_INTEGER) == FAILURE)
1774         return FAILURE;
1775
1776       if (scalar_check (size, 2) == FAILURE)
1777         return FAILURE;
1778
1779       if (nonoptional_check (size, 2) == FAILURE)
1780         return FAILURE;
1781     }
1782
1783   return SUCCESS;
1784 }
1785
1786
1787 try
1788 gfc_check_transpose (gfc_expr * matrix)
1789 {
1790
1791   if (rank_check (matrix, 0, 2) == FAILURE)
1792     return FAILURE;
1793
1794   return SUCCESS;
1795 }
1796
1797
1798 try
1799 gfc_check_ubound (gfc_expr * array, gfc_expr * dim)
1800 {
1801
1802   if (array_check (array, 0) == FAILURE)
1803     return FAILURE;
1804
1805   if (dim != NULL)
1806     {
1807       if (dim_check (dim, 1, 1) == FAILURE)
1808         return FAILURE;
1809
1810       if (dim_rank_check (dim, array, 0) == FAILURE)
1811         return FAILURE;
1812     }
1813   return SUCCESS;
1814 }
1815
1816
1817 try
1818 gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
1819 {
1820
1821   if (rank_check (vector, 0, 1) == FAILURE)
1822     return FAILURE;
1823
1824   if (array_check (mask, 1) == FAILURE)
1825     return FAILURE;
1826
1827   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1828     return FAILURE;
1829
1830   if (same_type_check (vector, 0, field, 2) == FAILURE)
1831     return FAILURE;
1832
1833   return SUCCESS;
1834 }
1835
1836
1837 try
1838 gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1839 {
1840
1841   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1842     return FAILURE;
1843
1844   if (same_type_check (x, 0, y, 1) == FAILURE)
1845     return FAILURE;
1846
1847   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
1848     return FAILURE;
1849
1850   return SUCCESS;
1851 }
1852
1853
1854 try
1855 gfc_check_trim (gfc_expr * x)
1856 {
1857   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
1858     return FAILURE;
1859
1860   if (scalar_check (x, 0) == FAILURE)
1861     return FAILURE;
1862
1863    return SUCCESS;
1864 }
1865
1866
1867 /* Common check function for the half a dozen intrinsics that have a
1868    single real argument.  */
1869
1870 try
1871 gfc_check_x (gfc_expr * x)
1872 {
1873
1874   if (type_check (x, 0, BT_REAL) == FAILURE)
1875     return FAILURE;
1876
1877   return SUCCESS;
1878 }
1879
1880
1881 /************* Check functions for intrinsic subroutines *************/
1882
1883 try
1884 gfc_check_cpu_time (gfc_expr * time)
1885 {
1886
1887   if (scalar_check (time, 0) == FAILURE)
1888     return FAILURE;
1889
1890   if (type_check (time, 0, BT_REAL) == FAILURE)
1891     return FAILURE;
1892
1893   if (variable_check (time, 0) == FAILURE)
1894     return FAILURE;
1895
1896   return SUCCESS;
1897 }
1898
1899
1900 try
1901 gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
1902                          gfc_expr * zone, gfc_expr * values)
1903 {
1904
1905   if (date != NULL)
1906     {
1907       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
1908         return FAILURE;
1909       if (scalar_check (date, 0) == FAILURE)
1910         return FAILURE;
1911       if (variable_check (date, 0) == FAILURE)
1912         return FAILURE;
1913     }
1914
1915   if (time != NULL)
1916     {
1917       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
1918         return FAILURE;
1919       if (scalar_check (time, 1) == FAILURE)
1920         return FAILURE;
1921       if (variable_check (time, 1) == FAILURE)
1922         return FAILURE;
1923     }
1924
1925   if (zone != NULL)
1926     {
1927       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
1928         return FAILURE;
1929       if (scalar_check (zone, 2) == FAILURE)
1930         return FAILURE;
1931       if (variable_check (zone, 2) == FAILURE)
1932         return FAILURE;
1933     }
1934
1935   if (values != NULL)
1936     {
1937       if (type_check (values, 3, BT_INTEGER) == FAILURE)
1938         return FAILURE;
1939       if (array_check (values, 3) == FAILURE)
1940         return FAILURE;
1941       if (rank_check (values, 3, 1) == FAILURE)
1942         return FAILURE;
1943       if (variable_check (values, 3) == FAILURE)
1944         return FAILURE;
1945     }
1946
1947   return SUCCESS;
1948 }
1949
1950
1951 try
1952 gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
1953                   gfc_expr * to, gfc_expr * topos)
1954 {
1955
1956   if (type_check (from, 0, BT_INTEGER) == FAILURE)
1957     return FAILURE;
1958
1959   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
1960     return FAILURE;
1961
1962   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1963     return FAILURE;
1964
1965   if (same_type_check (from, 0, to, 3) == FAILURE)
1966     return FAILURE;
1967
1968   if (variable_check (to, 3) == FAILURE)
1969     return FAILURE;
1970
1971   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
1972     return FAILURE;
1973
1974   return SUCCESS;
1975 }
1976
1977
1978 try
1979 gfc_check_random_number (gfc_expr * harvest)
1980 {
1981
1982   if (type_check (harvest, 0, BT_REAL) == FAILURE)
1983     return FAILURE;
1984
1985   if (variable_check (harvest, 0) == FAILURE)
1986     return FAILURE;
1987
1988   return SUCCESS;
1989 }
1990
1991
1992 try
1993 gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
1994 {
1995
1996   if (size != NULL)
1997     {
1998       if (scalar_check (size, 0) == FAILURE)
1999         return FAILURE;
2000
2001       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2002         return FAILURE;
2003
2004       if (variable_check (size, 0) == FAILURE)
2005         return FAILURE;
2006
2007       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2008         return FAILURE;
2009     }
2010
2011   if (put != NULL)
2012     {
2013
2014       if (size != NULL)
2015         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2016                     &put->where);
2017
2018       if (array_check (put, 1) == FAILURE)
2019         return FAILURE;
2020
2021       if (rank_check (put, 1, 1) == FAILURE)
2022         return FAILURE;
2023
2024       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2025         return FAILURE;
2026
2027       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2028         return FAILURE;
2029     }
2030
2031   if (get != NULL)
2032     {
2033
2034       if (size != NULL || put != NULL)
2035         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2036                     &get->where);
2037
2038       if (array_check (get, 2) == FAILURE)
2039         return FAILURE;
2040
2041       if (rank_check (get, 2, 1) == FAILURE)
2042         return FAILURE;
2043
2044       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2045         return FAILURE;
2046
2047       if (variable_check (get, 2) == FAILURE)
2048         return FAILURE;
2049
2050       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2051         return FAILURE;
2052     }
2053
2054   return SUCCESS;
2055 }
2056
2057 try
2058 gfc_check_second_sub (gfc_expr * time)
2059 {
2060
2061   if (scalar_check (time, 0) == FAILURE)
2062     return FAILURE;
2063
2064   if (type_check (time, 0, BT_REAL) == FAILURE)
2065     return FAILURE;
2066
2067   if (kind_value_check(time, 0, 4) == FAILURE)
2068     return FAILURE;
2069
2070   return SUCCESS;
2071 }
2072
2073
2074 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2075    count, count_rate, and count_max are all optional arguments */
2076
2077 try
2078 gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
2079                         gfc_expr * count_max)
2080 {
2081
2082   if (count != NULL)
2083     {
2084       if (scalar_check (count, 0) == FAILURE)
2085         return FAILURE;
2086
2087       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2088         return FAILURE;
2089
2090       if (variable_check (count, 0) == FAILURE)
2091         return FAILURE;
2092     }
2093
2094   if (count_rate != NULL)
2095     {
2096       if (scalar_check (count_rate, 1) == FAILURE)
2097         return FAILURE;
2098
2099       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2100         return FAILURE;
2101
2102       if (variable_check (count_rate, 1) == FAILURE)
2103         return FAILURE;
2104
2105       if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
2106         return FAILURE;
2107
2108     }
2109
2110   if (count_max != NULL)
2111     {
2112       if (scalar_check (count_max, 2) == FAILURE)
2113         return FAILURE;
2114
2115       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2116         return FAILURE;
2117
2118       if (variable_check (count_max, 2) == FAILURE)
2119         return FAILURE;
2120
2121       if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
2122         return FAILURE;
2123
2124       if (count_rate != NULL
2125           && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
2126         return FAILURE;
2127
2128    }
2129
2130     return SUCCESS;
2131 }
2132
2133 try
2134 gfc_check_irand (gfc_expr * x)
2135 {
2136   if (x == NULL)
2137     return SUCCESS;
2138
2139   if (scalar_check (x, 0) == FAILURE)
2140     return FAILURE;
2141
2142   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2143     return FAILURE;
2144
2145   if (kind_value_check(x, 0, 4) == FAILURE)
2146     return FAILURE;
2147
2148   return SUCCESS;
2149 }
2150
2151 try
2152 gfc_check_rand (gfc_expr * x)
2153 {
2154   if (x == NULL)
2155     return SUCCESS;
2156
2157   if (scalar_check (x, 0) == FAILURE)
2158     return FAILURE;
2159
2160   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2161     return FAILURE;
2162
2163   if (kind_value_check(x, 0, 4) == FAILURE)
2164     return FAILURE;
2165
2166   return SUCCESS;
2167 }
2168
2169 try
2170 gfc_check_srand (gfc_expr * x)
2171 {
2172   if (scalar_check (x, 0) == FAILURE)
2173     return FAILURE;
2174
2175   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2176     return FAILURE;
2177
2178   if (kind_value_check(x, 0, 4) == FAILURE)
2179     return FAILURE;
2180
2181   return SUCCESS;
2182 }
2183
2184 try
2185 gfc_check_etime (gfc_expr * x)
2186 {
2187   if (array_check (x, 0) == FAILURE)
2188     return FAILURE;
2189
2190   if (rank_check (x, 0, 1) == FAILURE)
2191     return FAILURE;
2192
2193   if (variable_check (x, 0) == FAILURE)
2194     return FAILURE;
2195
2196   if (type_check (x, 0, BT_REAL) == FAILURE)
2197     return FAILURE;
2198
2199   if (kind_value_check(x, 0, 4) == FAILURE)
2200     return FAILURE;
2201
2202   return SUCCESS;
2203 }
2204
2205 try
2206 gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
2207 {
2208   if (array_check (values, 0) == FAILURE)
2209     return FAILURE;
2210
2211   if (rank_check (values, 0, 1) == FAILURE)
2212     return FAILURE;
2213
2214   if (variable_check (values, 0) == FAILURE)
2215     return FAILURE;
2216
2217   if (type_check (values, 0, BT_REAL) == FAILURE)
2218     return FAILURE;
2219
2220   if (kind_value_check(values, 0, 4) == FAILURE)
2221     return FAILURE;
2222
2223   if (scalar_check (time, 1) == FAILURE)
2224     return FAILURE;
2225
2226   if (type_check (time, 1, BT_REAL) == FAILURE)
2227     return FAILURE;
2228
2229   if (kind_value_check(time, 1, 4) == FAILURE)
2230     return FAILURE;
2231
2232   return SUCCESS;
2233 }
2234
2235
2236 try
2237 gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
2238 {
2239
2240   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
2241     return FAILURE;
2242
2243   if (status == NULL)
2244     return SUCCESS;
2245
2246   if (scalar_check (status, 1) == FAILURE)
2247     return FAILURE;
2248
2249   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2250     return FAILURE;
2251
2252   return SUCCESS;
2253 }
2254
2255
2256 try
2257 gfc_check_exit (gfc_expr * status)
2258 {
2259
2260   if (status == NULL)
2261   return SUCCESS;
2262
2263   if (type_check (status, 0, BT_INTEGER) == FAILURE)
2264     return FAILURE;
2265
2266   if (scalar_check (status, 0) == FAILURE)
2267     return FAILURE;
2268
2269   return SUCCESS;
2270 }
2271
2272
2273 try
2274 gfc_check_flush (gfc_expr * unit)
2275 {
2276
2277   if (unit == NULL)
2278     return SUCCESS;
2279
2280   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2281     return FAILURE;
2282
2283   if (scalar_check (unit, 0) == FAILURE)
2284     return FAILURE;
2285
2286   return SUCCESS;
2287 }
2288
2289
2290 try
2291 gfc_check_umask (gfc_expr * mask)
2292 {
2293
2294   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2295     return FAILURE;
2296
2297   if (scalar_check (mask, 0) == FAILURE)
2298     return FAILURE;
2299
2300   return SUCCESS;
2301 }
2302
2303
2304 try
2305 gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
2306 {
2307
2308   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
2309     return FAILURE;
2310
2311   if (scalar_check (mask, 0) == FAILURE)
2312     return FAILURE;
2313
2314   if (old == NULL)
2315     return SUCCESS;
2316
2317   if (scalar_check (old, 1) == FAILURE)
2318     return FAILURE;
2319
2320   if (type_check (old, 1, BT_INTEGER) == FAILURE)
2321     return FAILURE;
2322
2323   return SUCCESS;
2324 }
2325
2326
2327 try
2328 gfc_check_unlink (gfc_expr * name)
2329 {
2330
2331   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2332     return FAILURE;
2333
2334   return SUCCESS;
2335 }
2336
2337
2338 try
2339 gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
2340 {
2341
2342   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2343     return FAILURE;
2344
2345   if (status == NULL)
2346     return SUCCESS;
2347
2348   if (scalar_check (status, 1) == FAILURE)
2349     return FAILURE;
2350
2351   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2352     return FAILURE;
2353
2354   return SUCCESS;
2355 }
2356
2357
2358 try
2359 gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
2360 {
2361   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
2362     return FAILURE;
2363
2364   if (scalar_check (status, 1) == FAILURE)
2365     return FAILURE;
2366
2367   if (type_check (status, 1, BT_INTEGER) == FAILURE)
2368     return FAILURE;
2369
2370   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
2371     return FAILURE;
2372
2373   return SUCCESS;
2374 }