gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23
  24 /* These functions check to see if an argument list is compatible with
  25    a particular intrinsic function or subroutine.  Presence of
  26    required arguments has already been established, the argument list
  27    has been sorted into the right order and has NULL arguments in the
  28    correct places for missing optional arguments.  */
  29
  30 #include "config.h"
  31 #include "system.h"
  32 #include "flags.h"
  33 #include "gfortran.h"
  34 #include "intrinsic.h"
  35
  36
  37 /* Check the type of an expression.  */
  38
  39 static try
  40 type_check (gfc_expr *e, int n, bt type)
  41 {
  42   if (e->ts.type == type)
  43     return SUCCESS;
  44
  45   gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
  46              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
  47              gfc_basic_typename (type));
  48
  49   return FAILURE;
  50 }
  51
  52
  53 /* Check that the expression is a numeric type.  */
  54
  55 static try
  56 numeric_check (gfc_expr *e, int n)
  57 {
  58   if (gfc_numeric_ts (&e->ts))
  59     return SUCCESS;
  60
  61   /* If the expression has not got a type, check if its namespace can
  62      offer a default type.  */
  63   if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
  64         && e->symtree->n.sym->ts.type == BT_UNKNOWN
  65         && gfc_set_default_type (e->symtree->n.sym, 0,
  66                                  e->symtree->n.sym->ns) == SUCCESS
  67         && gfc_numeric_ts (&e->symtree->n.sym->ts))
  68     {
  69       e->ts = e->symtree->n.sym->ts;
  70       return SUCCESS;
  71     }
  72
  73   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
  74              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
  75
  76   return FAILURE;
  77 }
  78
  79
  80 /* Check that an expression is integer or real.  */
  81
  82 static try
  83 int_or_real_check (gfc_expr *e, int n)
  84 {
  85   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
  86     {
  87       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
  88                  "or REAL", gfc_current_intrinsic_arg[n],
  89                  gfc_current_intrinsic, &e->where);
  90       return FAILURE;
  91     }
  92
  93   return SUCCESS;
  94 }
  95
  96
  97 /* Check that an expression is real or complex.  */
  98
  99 static try
 100 real_or_complex_check (gfc_expr *e, int n)
 101 {
 102   if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
 103     {
 104       gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
 105                  "or COMPLEX", gfc_current_intrinsic_arg[n],
 106                  gfc_current_intrinsic, &e->where);
 107       return FAILURE;
 108     }
 109
 110   return SUCCESS;
 111 }
 112
 113
 114 /* Check that the expression is an optional constant integer
 115    and that it specifies a valid kind for that type.  */
 116
 117 static try
 118 kind_check (gfc_expr *k, int n, bt type)
 119 {
 120   int kind;
 121
 122   if (k == NULL)
 123     return SUCCESS;
 124
 125   if (type_check (k, n, BT_INTEGER) == FAILURE)
 126     return FAILURE;
 127
 128   if (k->expr_type != EXPR_CONSTANT)
 129     {
 130       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
 131                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 132                  &k->where);
 133       return FAILURE;
 134     }
 135
 136   if (gfc_extract_int (k, &kind) != NULL
 137       || gfc_validate_kind (type, kind, true) < 0)
 138     {
 139       gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
 140                  &k->where);
 141       return FAILURE;
 142     }
 143
 144   return SUCCESS;
 145 }
 146
 147
 148 /* Make sure the expression is a double precision real.  */
 149
 150 static try
 151 double_check (gfc_expr *d, int n)
 152 {
 153   if (type_check (d, n, BT_REAL) == FAILURE)
 154     return FAILURE;
 155
 156   if (d->ts.kind != gfc_default_double_kind)
 157     {
 158       gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
 159                  "precision", gfc_current_intrinsic_arg[n],
 160                  gfc_current_intrinsic, &d->where);
 161       return FAILURE;
 162     }
 163
 164   return SUCCESS;
 165 }
 166
 167
 168 /* Make sure the expression is a logical array.  */
 169
 170 static try
 171 logical_array_check (gfc_expr *array, int n)
 172 {
 173   if (array->ts.type != BT_LOGICAL || array->rank == 0)
 174     {
 175       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
 176                  "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 177                  &array->where);
 178       return FAILURE;
 179     }
 180
 181   return SUCCESS;
 182 }
 183
 184
 185 /* Make sure an expression is an array.  */
 186
 187 static try
 188 array_check (gfc_expr *e, int n)
 189 {
 190   if (e->rank != 0)
 191     return SUCCESS;
 192
 193   gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
 194              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 195
 196   return FAILURE;
 197 }
 198
 199
 200 /* Make sure an expression is a scalar.  */
 201
 202 static try
 203 scalar_check (gfc_expr *e, int n)
 204 {
 205   if (e->rank == 0)
 206     return SUCCESS;
 207
 208   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
 209              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 210
 211   return FAILURE;
 212 }
 213
 214
 215 /* Make sure two expressions have the same type.  */
 216
 217 static try
 218 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
 219 {
 220   if (gfc_compare_types (&e->ts, &f->ts))
 221     return SUCCESS;
 222
 223   gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
 224              "and kind as '%s'", gfc_current_intrinsic_arg[m],
 225              gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
 226
 227   return FAILURE;
 228 }
 229
 230
 231 /* Make sure that an expression has a certain (nonzero) rank.  */
 232
 233 static try
 234 rank_check (gfc_expr *e, int n, int rank)
 235 {
 236   if (e->rank == rank)
 237     return SUCCESS;
 238
 239   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
 240              gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 241              &e->where, rank);
 242
 243   return FAILURE;
 244 }
 245
 246
 247 /* Make sure a variable expression is not an optional dummy argument.  */
 248
 249 static try
 250 nonoptional_check (gfc_expr *e, int n)
 251 {
 252   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
 253     {
 254       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
 255                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 256                  &e->where);
 257     }
 258
 259   /* TODO: Recursive check on nonoptional variables?  */
 260
 261   return SUCCESS;
 262 }
 263
 264
 265 /* Check that an expression has a particular kind.  */
 266
 267 static try
 268 kind_value_check (gfc_expr *e, int n, int k)
 269 {
 270   if (e->ts.kind == k)
 271     return SUCCESS;
 272
 273   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
 274              gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 275              &e->where, k);
 276
 277   return FAILURE;
 278 }
 279
 280
 281 /* Make sure an expression is a variable.  */
 282
 283 static try
 284 variable_check (gfc_expr *e, int n)
 285 {
 286   if ((e->expr_type == EXPR_VARIABLE
 287        && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
 288       || (e->expr_type == EXPR_FUNCTION
 289           && e->symtree->n.sym->result == e->symtree->n.sym))
 290     return SUCCESS;
 291
 292   if (e->expr_type == EXPR_VARIABLE
 293       && e->symtree->n.sym->attr.intent == INTENT_IN)
 294     {
 295       gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
 296                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 297                  &e->where);
 298       return FAILURE;
 299     }
 300
 301   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
 302              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 303
 304   return FAILURE;
 305 }
 306
 307
 308 /* Check the common DIM parameter for correctness.  */
 309
 310 static try
 311 dim_check (gfc_expr *dim, int n, int optional)
 312 {
 313   if (optional && dim == NULL)
 314     return SUCCESS;
 315
 316   if (dim == NULL)
 317     {
 318       gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
 319                  gfc_current_intrinsic, gfc_current_intrinsic_where);
 320       return FAILURE;
 321     }
 322
 323   if (type_check (dim, n, BT_INTEGER) == FAILURE)
 324     return FAILURE;
 325
 326   if (scalar_check (dim, n) == FAILURE)
 327     return FAILURE;
 328
 329   if (nonoptional_check (dim, n) == FAILURE)
 330     return FAILURE;
 331
 332   return SUCCESS;
 333 }
 334
 335
 336 /* If a DIM parameter is a constant, make sure that it is greater than
 337    zero and less than or equal to the rank of the given array.  If
 338    allow_assumed is zero then dim must be less than the rank of the array
 339    for assumed size arrays.  */
 340
 341 static try
 342 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
 343 {
 344   gfc_array_ref *ar;
 345   int rank;
 346
 347   if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
 348     return SUCCESS;
 349
 350   ar = gfc_find_array_ref (array);
 351   rank = array->rank;
 352   if (ar->as->type == AS_ASSUMED_SIZE
 353       && !allow_assumed
 354       && ar->type != AR_ELEMENT
 355       && ar->type != AR_SECTION)
 356     rank--;
 357
 358   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 359       || mpz_cmp_ui (dim->value.integer, rank) > 0)
 360     {
 361       gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
 362                  "dimension index", gfc_current_intrinsic, &dim->where);
 363
 364       return FAILURE;
 365     }
 366
 367   return SUCCESS;
 368 }
 369
 370
 371 /* Compare the size of a along dimension ai with the size of b along
 372    dimension bi, returning 0 if they are known not to be identical,
 373    and 1 if they are identical, or if this cannot be determined.  */
 374
 375 static int
 376 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 377 {
 378   mpz_t a_size, b_size;
 379   int ret;
 380
 381   gcc_assert (a->rank > ai);
 382   gcc_assert (b->rank > bi);
 383
 384   ret = 1;
 385
 386   if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
 387     {
 388       if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
 389         {
 390           if (mpz_cmp (a_size, b_size) != 0)
 391             ret = 0;
 392
 393           mpz_clear (b_size);
 394         }
 395       mpz_clear (a_size);
 396     }
 397   return ret;
 398 }
 399
 400
 401 /***** Check functions *****/
 402
 403 /* Check subroutine suitable for intrinsics taking a real argument and
 404    a kind argument for the result.  */
 405
 406 static try
 407 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
 408 {
 409   if (type_check (a, 0, BT_REAL) == FAILURE)
 410     return FAILURE;
 411   if (kind_check (kind, 1, type) == FAILURE)
 412     return FAILURE;
 413
 414   return SUCCESS;
 415 }
 416
 417
 418 /* Check subroutine suitable for ceiling, floor and nint.  */
 419
 420 try
 421 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
 422 {
 423   return check_a_kind (a, kind, BT_INTEGER);
 424 }
 425
 426
 427 /* Check subroutine suitable for aint, anint.  */
 428
 429 try
 430 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
 431 {
 432   return check_a_kind (a, kind, BT_REAL);
 433 }
 434
 435
 436 try
 437 gfc_check_abs (gfc_expr *a)
 438 {
 439   if (numeric_check (a, 0) == FAILURE)
 440     return FAILURE;
 441
 442   return SUCCESS;
 443 }
 444
 445
 446 try
 447 gfc_check_achar (gfc_expr *a)
 448 {
 449   if (type_check (a, 0, BT_INTEGER) == FAILURE)
 450     return FAILURE;
 451
 452   return SUCCESS;
 453 }
 454
 455
 456 try
 457 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
 458 {
 459   if (type_check (name, 0, BT_CHARACTER) == FAILURE
 460       || scalar_check (name, 0) == FAILURE)
 461     return FAILURE;
 462
 463   if (type_check (mode, 1, BT_CHARACTER) == FAILURE
 464       || scalar_check (mode, 1) == FAILURE)
 465     return FAILURE;
 466
 467   return SUCCESS;
 468 }
 469
 470
 471 try
 472 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
 473 {
 474   if (logical_array_check (mask, 0) == FAILURE)
 475     return FAILURE;
 476
 477   if (dim_check (dim, 1, 1) == FAILURE)
 478     return FAILURE;
 479
 480   return SUCCESS;
 481 }
 482
 483
 484 try
 485 gfc_check_allocated (gfc_expr *array)
 486 {
 487   symbol_attribute attr;
 488
 489   if (variable_check (array, 0) == FAILURE)
 490     return FAILURE;
 491
 492   if (array_check (array, 0) == FAILURE)
 493     return FAILURE;
 494
 495   attr = gfc_variable_attr (array, NULL);
 496   if (!attr.allocatable)
 497     {
 498       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
 499                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 500                  &array->where);
 501       return FAILURE;
 502     }
 503
 504   return SUCCESS;
 505 }
 506
 507
 508 /* Common check function where the first argument must be real or
 509    integer and the second argument must be the same as the first.  */
 510
 511 try
 512 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
 513 {
 514   if (int_or_real_check (a, 0) == FAILURE)
 515     return FAILURE;
 516
 517   if (a->ts.type != p->ts.type)
 518     {
 519       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
 520                  "have the same type", gfc_current_intrinsic_arg[0],
 521                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
 522                  &p->where);
 523       return FAILURE;
 524     }
 525
 526   if (a->ts.kind != p->ts.kind)
 527     {
 528       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 529                           &p->where) == FAILURE)
 530        return FAILURE;
 531     }
 532
 533   return SUCCESS;
 534 }
 535
 536
 537 try
 538 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
 539 {
 540   symbol_attribute attr;
 541   int i;
 542   try t;
 543   locus *where;
 544
 545   where = &pointer->where;
 546
 547   if (pointer->expr_type == EXPR_VARIABLE)
 548     attr = gfc_variable_attr (pointer, NULL);
 549   else if (pointer->expr_type == EXPR_FUNCTION)
 550     attr = pointer->symtree->n.sym->attr;
 551   else if (pointer->expr_type == EXPR_NULL)
 552     goto null_arg;
 553   else
 554     gcc_assert (0); /* Pointer must be a variable or a function.  */
 555
 556   if (!attr.pointer)
 557     {
 558       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
 559                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 560                  &pointer->where);
 561       return FAILURE;
 562     }
 563
 564   /* Target argument is optional.  */
 565   if (target == NULL)
 566     return SUCCESS;
 567
 568   where = &target->where;
 569   if (target->expr_type == EXPR_NULL)
 570     goto null_arg;
 571
 572   if (target->expr_type == EXPR_VARIABLE)
 573     attr = gfc_variable_attr (target, NULL);
 574   else if (target->expr_type == EXPR_FUNCTION)
 575     attr = target->symtree->n.sym->attr;
 576   else
 577     {
 578       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
 579                  "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
 580                  gfc_current_intrinsic, &target->where);
 581       return FAILURE;
 582     }
 583
 584   if (!attr.pointer && !attr.target)
 585     {
 586       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
 587                  "or a TARGET", gfc_current_intrinsic_arg[1],
 588                  gfc_current_intrinsic, &target->where);
 589       return FAILURE;
 590     }
 591
 592   t = SUCCESS;
 593   if (same_type_check (pointer, 0, target, 1) == FAILURE)
 594     t = FAILURE;
 595   if (rank_check (target, 0, pointer->rank) == FAILURE)
 596     t = FAILURE;
 597   if (target->rank > 0)
 598     {
 599       for (i = 0; i < target->rank; i++)
 600         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 601           {
 602             gfc_error ("Array section with a vector subscript at %L shall not "
 603                        "be the target of a pointer",
 604                        &target->where);
 605             t = FAILURE;
 606             break;
 607           }
 608     }
 609   return t;
 610
 611 null_arg:
 612
 613   gfc_error ("NULL pointer at %L is not permitted as actual argument "
 614              "of '%s' intrinsic function", where, gfc_current_intrinsic);
 615   return FAILURE;
 616
 617 }
 618
 619
 620 try
 621 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
 622 {
 623   if (type_check (y, 0, BT_REAL) == FAILURE)
 624     return FAILURE;
 625   if (same_type_check (y, 0, x, 1) == FAILURE)
 626     return FAILURE;
 627
 628   return SUCCESS;
 629 }
 630
 631
 632 /* BESJN and BESYN functions.  */
 633
 634 try
 635 gfc_check_besn (gfc_expr *n, gfc_expr *x)
 636 {
 637   if (type_check (n, 0, BT_INTEGER) == FAILURE)
 638     return FAILURE;
 639
 640   if (type_check (x, 1, BT_REAL) == FAILURE)
 641     return FAILURE;
 642
 643   return SUCCESS;
 644 }
 645
 646
 647 try
 648 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
 649 {
 650   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 651     return FAILURE;
 652   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 653     return FAILURE;
 654
 655   return SUCCESS;
 656 }
 657
 658
 659 try
 660 gfc_check_char (gfc_expr *i, gfc_expr *kind)
 661 {
 662   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 663     return FAILURE;
 664   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 665     return FAILURE;
 666
 667   return SUCCESS;
 668 }
 669
 670
 671 try
 672 gfc_check_chdir (gfc_expr *dir)
 673 {
 674   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 675     return FAILURE;
 676
 677   return SUCCESS;
 678 }
 679
 680
 681 try
 682 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
 683 {
 684   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 685     return FAILURE;
 686
 687   if (status == NULL)
 688     return SUCCESS;
 689
 690   if (type_check (status, 1, BT_INTEGER) == FAILURE)
 691     return FAILURE;
 692
 693   if (scalar_check (status, 1) == FAILURE)
 694     return FAILURE;
 695
 696   return SUCCESS;
 697 }
 698
 699
 700 try
 701 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
 702 {
 703   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
 704     return FAILURE;
 705
 706   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
 707     return FAILURE;
 708
 709   return SUCCESS;
 710 }
 711
 712
 713 try
 714 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
 715 {
 716   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
 717     return FAILURE;
 718
 719   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
 720     return FAILURE;
 721
 722   if (status == NULL)
 723     return SUCCESS;
 724
 725   if (type_check (status, 2, BT_INTEGER) == FAILURE)
 726     return FAILURE;
 727
 728   if (scalar_check (status, 2) == FAILURE)
 729     return FAILURE;
 730
 731   return SUCCESS;
 732 }
 733
 734
 735 try
 736 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 737 {
 738   if (numeric_check (x, 0) == FAILURE)
 739     return FAILURE;
 740
 741   if (y != NULL)
 742     {
 743       if (numeric_check (y, 1) == FAILURE)
 744         return FAILURE;
 745
 746       if (x->ts.type == BT_COMPLEX)
 747         {
 748           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 749                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 750                      gfc_current_intrinsic, &y->where);
 751           return FAILURE;
 752         }
 753     }
 754
 755   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 756     return FAILURE;
 757
 758   return SUCCESS;
 759 }
 760
 761
 762 try
 763 gfc_check_complex (gfc_expr *x, gfc_expr *y)
 764 {
 765   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
 766     {
 767       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
 768                  "or REAL", gfc_current_intrinsic_arg[0],
 769                  gfc_current_intrinsic, &x->where);
 770       return FAILURE;
 771     }
 772   if (scalar_check (x, 0) == FAILURE)
 773     return FAILURE;
 774
 775   if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
 776     {
 777       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
 778                  "or REAL", gfc_current_intrinsic_arg[1],
 779                  gfc_current_intrinsic, &y->where);
 780       return FAILURE;
 781     }
 782   if (scalar_check (y, 1) == FAILURE)
 783     return FAILURE;
 784
 785   return SUCCESS;
 786 }
 787
 788
 789 try
 790 gfc_check_count (gfc_expr *mask, gfc_expr *dim)
 791 {
 792   if (logical_array_check (mask, 0) == FAILURE)
 793     return FAILURE;
 794   if (dim_check (dim, 1, 1) == FAILURE)
 795     return FAILURE;
 796
 797   return SUCCESS;
 798 }
 799
 800
 801 try
 802 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
 803 {
 804   if (array_check (array, 0) == FAILURE)
 805     return FAILURE;
 806
 807   if (array->rank == 1)
 808     {
 809       if (scalar_check (shift, 1) == FAILURE)
 810         return FAILURE;
 811     }
 812   else
 813     {
 814       /* TODO: more requirements on shift parameter.  */
 815     }
 816
 817   if (dim_check (dim, 2, 1) == FAILURE)
 818     return FAILURE;
 819
 820   return SUCCESS;
 821 }
 822
 823
 824 try
 825 gfc_check_ctime (gfc_expr *time)
 826 {
 827   if (scalar_check (time, 0) == FAILURE)
 828     return FAILURE;
 829
 830   if (type_check (time, 0, BT_INTEGER) == FAILURE)
 831     return FAILURE;
 832
 833   return SUCCESS;
 834 }
 835
 836
 837 try
 838 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
 839 {
 840   if (numeric_check (x, 0) == FAILURE)
 841     return FAILURE;
 842
 843   if (y != NULL)
 844     {
 845       if (numeric_check (y, 1) == FAILURE)
 846         return FAILURE;
 847
 848       if (x->ts.type == BT_COMPLEX)
 849         {
 850           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 851                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 852                      gfc_current_intrinsic, &y->where);
 853           return FAILURE;
 854         }
 855     }
 856
 857   return SUCCESS;
 858 }
 859
 860
 861 try
 862 gfc_check_dble (gfc_expr *x)
 863 {
 864   if (numeric_check (x, 0) == FAILURE)
 865     return FAILURE;
 866
 867   return SUCCESS;
 868 }
 869
 870
 871 try
 872 gfc_check_digits (gfc_expr *x)
 873 {
 874   if (int_or_real_check (x, 0) == FAILURE)
 875     return FAILURE;
 876
 877   return SUCCESS;
 878 }
 879
 880
 881 try
 882 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
 883 {
 884   switch (vector_a->ts.type)
 885     {
 886     case BT_LOGICAL:
 887       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 888         return FAILURE;
 889       break;
 890
 891     case BT_INTEGER:
 892     case BT_REAL:
 893     case BT_COMPLEX:
 894       if (numeric_check (vector_b, 1) == FAILURE)
 895         return FAILURE;
 896       break;
 897
 898     default:
 899       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
 900                  "or LOGICAL", gfc_current_intrinsic_arg[0],
 901                  gfc_current_intrinsic, &vector_a->where);
 902       return FAILURE;
 903     }
 904
 905   if (rank_check (vector_a, 0, 1) == FAILURE)
 906     return FAILURE;
 907
 908   if (rank_check (vector_b, 1, 1) == FAILURE)
 909     return FAILURE;
 910
 911   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
 912     {
 913       gfc_error ("different shape for arguments '%s' and '%s' at %L for "
 914                  "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
 915                  gfc_current_intrinsic_arg[1], &vector_a->where);
 916       return FAILURE;
 917     }
 918
 919   return SUCCESS;
 920 }
 921
 922
 923 try
 924 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
 925                    gfc_expr *dim)
 926 {
 927   if (array_check (array, 0) == FAILURE)
 928     return FAILURE;
 929
 930   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 931     return FAILURE;
 932
 933   if (array->rank == 1)
 934     {
 935       if (scalar_check (shift, 2) == FAILURE)
 936         return FAILURE;
 937     }
 938   else
 939     {
 940       /* TODO: more weird restrictions on shift.  */
 941     }
 942
 943   if (boundary != NULL)
 944     {
 945       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 946         return FAILURE;
 947
 948       /* TODO: more restrictions on boundary.  */
 949     }
 950
 951   if (dim_check (dim, 1, 1) == FAILURE)
 952     return FAILURE;
 953
 954   return SUCCESS;
 955 }
 956
 957
 958 /* A single complex argument.  */
 959
 960 try
 961 gfc_check_fn_c (gfc_expr *a)
 962 {
 963   if (type_check (a, 0, BT_COMPLEX) == FAILURE)
 964     return FAILURE;
 965
 966   return SUCCESS;
 967 }
 968
 969
 970 /* A single real argument.  */
 971
 972 try
 973 gfc_check_fn_r (gfc_expr *a)
 974 {
 975   if (type_check (a, 0, BT_REAL) == FAILURE)
 976     return FAILURE;
 977
 978   return SUCCESS;
 979 }
 980
 981
 982 /* A single real or complex argument.  */
 983
 984 try
 985 gfc_check_fn_rc (gfc_expr *a)
 986 {
 987   if (real_or_complex_check (a, 0) == FAILURE)
 988     return FAILURE;
 989
 990   return SUCCESS;
 991 }
 992
 993
 994 try
 995 gfc_check_fnum (gfc_expr *unit)
 996 {
 997   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
 998     return FAILURE;
 999
1000   if (scalar_check (unit, 0) == FAILURE)
1001     return FAILURE;
1002
1003   return SUCCESS;
1004 }
1005
1006
1007 try
1008 gfc_check_huge (gfc_expr *x)
1009 {
1010   if (int_or_real_check (x, 0) == FAILURE)
1011     return FAILURE;
1012
1013   return SUCCESS;
1014 }
1015
1016
1017 /* Check that the single argument is an integer.  */
1018
1019 try
1020 gfc_check_i (gfc_expr *i)
1021 {
1022   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1023     return FAILURE;
1024
1025   return SUCCESS;
1026 }
1027
1028
1029 try
1030 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1031 {
1032   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1033     return FAILURE;
1034
1035   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1036     return FAILURE;
1037
1038   if (i->ts.kind != j->ts.kind)
1039     {
1040       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1041                           &i->where) == FAILURE)
1042         return FAILURE;
1043     }
1044
1045   return SUCCESS;
1046 }
1047
1048
1049 try
1050 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1051 {
1052   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1053     return FAILURE;
1054
1055   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1056     return FAILURE;
1057
1058   return SUCCESS;
1059 }
1060
1061
1062 try
1063 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1064 {
1065   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1066     return FAILURE;
1067
1068   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1069     return FAILURE;
1070
1071   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1072     return FAILURE;
1073
1074   return SUCCESS;
1075 }
1076
1077
1078 try
1079 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1080 {
1081   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1082     return FAILURE;
1083
1084   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1085     return FAILURE;
1086
1087   return SUCCESS;
1088 }
1089
1090
1091 try
1092 gfc_check_ichar_iachar (gfc_expr *c)
1093 {
1094   int i;
1095
1096   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1097     return FAILURE;
1098
1099   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1100     {
1101       gfc_expr *start;
1102       gfc_expr *end;
1103       gfc_ref *ref;
1104
1105       /* Substring references don't have the charlength set.  */
1106       ref = c->ref;
1107       while (ref && ref->type != REF_SUBSTRING)
1108         ref = ref->next;
1109
1110       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1111
1112       if (!ref)
1113         {
1114           /* Check that the argument is length one.  Non-constant lengths
1115              can't be checked here, so assume they are ok.  */
1116           if (c->ts.cl && c->ts.cl->length)
1117             {
1118               /* If we already have a length for this expression then use it.  */
1119               if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1120                 return SUCCESS;
1121               i = mpz_get_si (c->ts.cl->length->value.integer);
1122             }
1123           else
1124             return SUCCESS;
1125         }
1126       else
1127         {
1128           start = ref->u.ss.start;
1129           end = ref->u.ss.end;
1130
1131           gcc_assert (start);
1132           if (end == NULL || end->expr_type != EXPR_CONSTANT
1133               || start->expr_type != EXPR_CONSTANT)
1134             return SUCCESS;
1135
1136           i = mpz_get_si (end->value.integer) + 1
1137             - mpz_get_si (start->value.integer);
1138         }
1139     }
1140   else
1141     return SUCCESS;
1142
1143   if (i != 1)
1144     {
1145       gfc_error ("Argument of %s at %L must be of length one",
1146                  gfc_current_intrinsic, &c->where);
1147       return FAILURE;
1148     }
1149
1150   return SUCCESS;
1151 }
1152
1153
1154 try
1155 gfc_check_idnint (gfc_expr *a)
1156 {
1157   if (double_check (a, 0) == FAILURE)
1158     return FAILURE;
1159
1160   return SUCCESS;
1161 }
1162
1163
1164 try
1165 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1166 {
1167   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1168     return FAILURE;
1169
1170   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1171     return FAILURE;
1172
1173   if (i->ts.kind != j->ts.kind)
1174     {
1175       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1176                           &i->where) == FAILURE)
1177         return FAILURE;
1178     }
1179
1180   return SUCCESS;
1181 }
1182
1183
1184 try
1185 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
1186 {
1187   if (type_check (string, 0, BT_CHARACTER) == FAILURE
1188       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1189     return FAILURE;
1190
1191
1192   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1193     return FAILURE;
1194
1195   if (string->ts.kind != substring->ts.kind)
1196     {
1197       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1198                  "kind as '%s'", gfc_current_intrinsic_arg[1],
1199                  gfc_current_intrinsic, &substring->where,
1200                  gfc_current_intrinsic_arg[0]);
1201       return FAILURE;
1202     }
1203
1204   return SUCCESS;
1205 }
1206
1207
1208 try
1209 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1210 {
1211   if (numeric_check (x, 0) == FAILURE)
1212     return FAILURE;
1213
1214   if (kind != NULL)
1215     {
1216       if (type_check (kind, 1, BT_INTEGER) == FAILURE)
1217         return FAILURE;
1218
1219       if (scalar_check (kind, 1) == FAILURE)
1220         return FAILURE;
1221     }
1222
1223   return SUCCESS;
1224 }
1225
1226
1227 try
1228 gfc_check_intconv (gfc_expr *x)
1229 {
1230   if (numeric_check (x, 0) == FAILURE)
1231     return FAILURE;
1232
1233   return SUCCESS;
1234 }
1235
1236
1237 try
1238 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1239 {
1240   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1241     return FAILURE;
1242
1243   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1244     return FAILURE;
1245
1246   if (i->ts.kind != j->ts.kind)
1247     {
1248       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1249                           &i->where) == FAILURE)
1250         return FAILURE;
1251     }
1252
1253   return SUCCESS;
1254 }
1255
1256
1257 try
1258 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1259 {
1260   if (type_check (i, 0, BT_INTEGER) == FAILURE
1261       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1262     return FAILURE;
1263
1264   return SUCCESS;
1265 }
1266
1267
1268 try
1269 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1270 {
1271   if (type_check (i, 0, BT_INTEGER) == FAILURE
1272       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1273     return FAILURE;
1274
1275   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1276     return FAILURE;
1277
1278   return SUCCESS;
1279 }
1280
1281
1282 try
1283 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1284 {
1285   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1286     return FAILURE;
1287
1288   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1289     return FAILURE;
1290
1291   return SUCCESS;
1292 }
1293
1294
1295 try
1296 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1297 {
1298   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1299     return FAILURE;
1300
1301   if (scalar_check (pid, 0) == FAILURE)
1302     return FAILURE;
1303
1304   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1305     return FAILURE;
1306
1307   if (scalar_check (sig, 1) == FAILURE)
1308     return FAILURE;
1309
1310   if (status == NULL)
1311     return SUCCESS;
1312
1313   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1314     return FAILURE;
1315
1316   if (scalar_check (status, 2) == FAILURE)
1317     return FAILURE;
1318
1319   return SUCCESS;
1320 }
1321
1322
1323 try
1324 gfc_check_kind (gfc_expr *x)
1325 {
1326   if (x->ts.type == BT_DERIVED)
1327     {
1328       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1329                  "non-derived type", gfc_current_intrinsic_arg[0],
1330                  gfc_current_intrinsic, &x->where);
1331       return FAILURE;
1332     }
1333
1334   return SUCCESS;
1335 }
1336
1337
1338 try
1339 gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
1340 {
1341   if (array_check (array, 0) == FAILURE)
1342     return FAILURE;
1343
1344   if (dim != NULL)
1345     {
1346       if (dim_check (dim, 1, 1) == FAILURE)
1347         return FAILURE;
1348
1349       if (dim_rank_check (dim, array, 1) == FAILURE)
1350         return FAILURE;
1351     }
1352   return SUCCESS;
1353 }
1354
1355
1356 try
1357 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1358 {
1359   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1360     return FAILURE;
1361
1362   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1363     return FAILURE;
1364
1365   return SUCCESS;
1366 }
1367
1368
1369 try
1370 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1371 {
1372   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1373     return FAILURE;
1374
1375   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1376     return FAILURE;
1377
1378   if (status == NULL)
1379     return SUCCESS;
1380
1381   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1382     return FAILURE;
1383
1384   if (scalar_check (status, 2) == FAILURE)
1385     return FAILURE;
1386
1387   return SUCCESS;
1388 }
1389
1390
1391 try
1392 gfc_check_loc (gfc_expr *expr)
1393 {
1394   return variable_check (expr, 0);
1395 }
1396
1397
1398 try
1399 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1400 {
1401   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1402     return FAILURE;
1403
1404   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1405     return FAILURE;
1406
1407   return SUCCESS;
1408 }
1409
1410
1411 try
1412 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1413 {
1414   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1415     return FAILURE;
1416
1417   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1418     return FAILURE;
1419
1420   if (status == NULL)
1421     return SUCCESS;
1422
1423   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1424     return FAILURE;
1425
1426   if (scalar_check (status, 2) == FAILURE)
1427     return FAILURE;
1428
1429   return SUCCESS;
1430 }
1431
1432
1433 try
1434 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1435 {
1436   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1437     return FAILURE;
1438   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1439     return FAILURE;
1440
1441   return SUCCESS;
1442 }
1443
1444
1445 /* Min/max family.  */
1446
1447 static try
1448 min_max_args (gfc_actual_arglist *arg)
1449 {
1450   if (arg == NULL || arg->next == NULL)
1451     {
1452       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1453                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1454       return FAILURE;
1455     }
1456
1457   return SUCCESS;
1458 }
1459
1460
1461 static try
1462 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
1463 {
1464   gfc_actual_arglist *arg, *tmp;
1465
1466   gfc_expr *x;
1467   int m, n;
1468
1469   if (min_max_args (arglist) == FAILURE)
1470     return FAILURE;
1471
1472   for (arg = arglist, n=1; arg; arg = arg->next, n++)
1473     {
1474       x = arg->expr;
1475       if (x->ts.type != type || x->ts.kind != kind)
1476         {
1477           if (x->ts.type == type)
1478             {
1479               if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1480                                   "kinds at %L", &x->where) == FAILURE)
1481                 return FAILURE;
1482             }
1483           else
1484             {
1485               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1486                          "%s(%d)", n, gfc_current_intrinsic, &x->where,
1487                          gfc_basic_typename (type), kind);
1488               return FAILURE;
1489             }
1490         }
1491
1492       for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
1493         {
1494           char buffer[80];
1495           snprintf (buffer, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
1496                     m, n, gfc_current_intrinsic);
1497           if (gfc_check_conformance (buffer, tmp->expr, x) == FAILURE)
1498             return FAILURE;
1499         }
1500     }
1501
1502   return SUCCESS;
1503 }
1504
1505
1506 try
1507 gfc_check_min_max (gfc_actual_arglist *arg)
1508 {
1509   gfc_expr *x;
1510
1511   if (min_max_args (arg) == FAILURE)
1512     return FAILURE;
1513
1514   x = arg->expr;
1515
1516   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1517     {
1518       gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
1519                  "or REAL", gfc_current_intrinsic, &x->where);
1520       return FAILURE;
1521     }
1522
1523   return check_rest (x->ts.type, x->ts.kind, arg);
1524 }
1525
1526
1527 try
1528 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1529 {
1530   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1531 }
1532
1533
1534 try
1535 gfc_check_min_max_real (gfc_actual_arglist *arg)
1536 {
1537   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1538 }
1539
1540
1541 try
1542 gfc_check_min_max_double (gfc_actual_arglist *arg)
1543 {
1544   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1545 }
1546
1547
1548 /* End of min/max family.  */
1549
1550 try
1551 gfc_check_malloc (gfc_expr *size)
1552 {
1553   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1554     return FAILURE;
1555
1556   if (scalar_check (size, 0) == FAILURE)
1557     return FAILURE;
1558
1559   return SUCCESS;
1560 }
1561
1562
1563 try
1564 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1565 {
1566   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1567     {
1568       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1569                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1570                  gfc_current_intrinsic, &matrix_a->where);
1571       return FAILURE;
1572     }
1573
1574   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1575     {
1576       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1577                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1578                  gfc_current_intrinsic, &matrix_b->where);
1579       return FAILURE;
1580     }
1581
1582   switch (matrix_a->rank)
1583     {
1584     case 1:
1585       if (rank_check (matrix_b, 1, 2) == FAILURE)
1586         return FAILURE;
1587       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
1588       if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1589         {
1590           gfc_error ("different shape on dimension 1 for arguments '%s' "
1591                      "and '%s' at %L for intrinsic matmul",
1592                      gfc_current_intrinsic_arg[0],
1593                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1594           return FAILURE;
1595         }
1596       break;
1597
1598     case 2:
1599       if (matrix_b->rank != 2)
1600         {
1601           if (rank_check (matrix_b, 1, 1) == FAILURE)
1602             return FAILURE;
1603         }
1604       /* matrix_b has rank 1 or 2 here. Common check for the cases
1605          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1606          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
1607       if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1608         {
1609           gfc_error ("different shape on dimension 2 for argument '%s' and "
1610                      "dimension 1 for argument '%s' at %L for intrinsic "
1611                      "matmul", gfc_current_intrinsic_arg[0],
1612                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1613           return FAILURE;
1614         }
1615       break;
1616
1617     default:
1618       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1619                  "1 or 2", gfc_current_intrinsic_arg[0],
1620                  gfc_current_intrinsic, &matrix_a->where);
1621       return FAILURE;
1622     }
1623
1624   return SUCCESS;
1625 }
1626
1627
1628 /* Whoever came up with this interface was probably on something.
1629    The possibilities for the occupation of the second and third
1630    parameters are:
1631
1632          Arg #2     Arg #3
1633          NULL       NULL
1634          DIM    NULL
1635          MASK       NULL
1636          NULL       MASK             minloc(array, mask=m)
1637          DIM    MASK
1638
1639    I.e. in the case of minloc(array,mask), mask will be in the second
1640    position of the argument list and we'll have to fix that up.  */
1641
1642 try
1643 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1644 {
1645   gfc_expr *a, *m, *d;
1646
1647   a = ap->expr;
1648   if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1649     return FAILURE;
1650
1651   d = ap->next->expr;
1652   m = ap->next->next->expr;
1653
1654   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1655       && ap->next->name == NULL)
1656     {
1657       m = d;
1658       d = NULL;
1659       ap->next->expr = NULL;
1660       ap->next->next->expr = m;
1661     }
1662
1663   if (dim_check (d, 1, 1) == FAILURE)
1664     return FAILURE;
1665
1666   if (d && dim_rank_check (d, a, 0) == FAILURE)
1667     return FAILURE;
1668
1669   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1670     return FAILURE;
1671
1672   if (m != NULL)
1673     {
1674       char buffer[80];
1675       snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1676                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1677                 gfc_current_intrinsic);
1678       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1679         return FAILURE;
1680     }
1681
1682   return SUCCESS;
1683 }
1684
1685
1686 /* Similar to minloc/maxloc, the argument list might need to be
1687    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1688    difference is that MINLOC/MAXLOC take an additional KIND argument.
1689    The possibilities are:
1690
1691          Arg #2     Arg #3
1692          NULL       NULL
1693          DIM    NULL
1694          MASK       NULL
1695          NULL       MASK             minval(array, mask=m)
1696          DIM    MASK
1697
1698    I.e. in the case of minval(array,mask), mask will be in the second
1699    position of the argument list and we'll have to fix that up.  */
1700
1701 static try
1702 check_reduction (gfc_actual_arglist *ap)
1703 {
1704   gfc_expr *a, *m, *d;
1705
1706   a = ap->expr;
1707   d = ap->next->expr;
1708   m = ap->next->next->expr;
1709
1710   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1711       && ap->next->name == NULL)
1712     {
1713       m = d;
1714       d = NULL;
1715       ap->next->expr = NULL;
1716       ap->next->next->expr = m;
1717     }
1718
1719   if (dim_check (d, 1, 1) == FAILURE)
1720     return FAILURE;
1721
1722   if (d && dim_rank_check (d, a, 0) == FAILURE)
1723     return FAILURE;
1724
1725   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1726     return FAILURE;
1727
1728   if (m != NULL)
1729     {
1730       char buffer[80];
1731       snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1732                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1733                 gfc_current_intrinsic);
1734       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1735         return FAILURE;
1736     }
1737
1738   return SUCCESS;
1739 }
1740
1741
1742 try
1743 gfc_check_minval_maxval (gfc_actual_arglist *ap)
1744 {
1745   if (int_or_real_check (ap->expr, 0) == FAILURE
1746       || array_check (ap->expr, 0) == FAILURE)
1747     return FAILURE;
1748
1749   return check_reduction (ap);
1750 }
1751
1752
1753 try
1754 gfc_check_product_sum (gfc_actual_arglist *ap)
1755 {
1756   if (numeric_check (ap->expr, 0) == FAILURE
1757       || array_check (ap->expr, 0) == FAILURE)
1758     return FAILURE;
1759
1760   return check_reduction (ap);
1761 }
1762
1763
1764 try
1765 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
1766 {
1767   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1768     return FAILURE;
1769
1770   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1771     return FAILURE;
1772
1773   return SUCCESS;
1774 }
1775
1776 try
1777 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
1778 {
1779   symbol_attribute attr;
1780
1781   if (variable_check (from, 0) == FAILURE)
1782     return FAILURE;
1783
1784   if (array_check (from, 0) == FAILURE)
1785     return FAILURE;
1786
1787   attr = gfc_variable_attr (from, NULL);
1788   if (!attr.allocatable)
1789     {
1790       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1791                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1792                  &from->where);
1793       return FAILURE;
1794     }
1795
1796   if (variable_check (to, 0) == FAILURE)
1797     return FAILURE;
1798
1799   if (array_check (to, 0) == FAILURE)
1800     return FAILURE;
1801
1802   attr = gfc_variable_attr (to, NULL);
1803   if (!attr.allocatable)
1804     {
1805       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1806                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1807                  &to->where);
1808       return FAILURE;
1809     }
1810
1811   if (same_type_check (from, 0, to, 1) == FAILURE)
1812     return FAILURE;
1813
1814   if (to->rank != from->rank)
1815     {
1816       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1817                  "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1818                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1819                  &to->where,  from->rank, to->rank);
1820       return FAILURE;
1821     }
1822
1823   if (to->ts.kind != from->ts.kind)
1824     {
1825       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1826                  "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1827                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1828                  &to->where, from->ts.kind, to->ts.kind);
1829       return FAILURE;
1830     }
1831
1832   return SUCCESS;
1833 }
1834
1835
1836 try
1837 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
1838 {
1839   if (type_check (x, 0, BT_REAL) == FAILURE)
1840     return FAILURE;
1841
1842   if (type_check (s, 1, BT_REAL) == FAILURE)
1843     return FAILURE;
1844
1845   return SUCCESS;
1846 }
1847
1848
1849 try
1850 gfc_check_new_line (gfc_expr *a)
1851 {
1852   if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1853     return FAILURE;
1854
1855   return SUCCESS;
1856 }
1857
1858
1859 try
1860 gfc_check_null (gfc_expr *mold)
1861 {
1862   symbol_attribute attr;
1863
1864   if (mold == NULL)
1865     return SUCCESS;
1866
1867   if (variable_check (mold, 0) == FAILURE)
1868     return FAILURE;
1869
1870   attr = gfc_variable_attr (mold, NULL);
1871
1872   if (!attr.pointer)
1873     {
1874       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1875                  gfc_current_intrinsic_arg[0],
1876                  gfc_current_intrinsic, &mold->where);
1877       return FAILURE;
1878     }
1879
1880   return SUCCESS;
1881 }
1882
1883
1884 try
1885 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
1886 {
1887   char buffer[80];
1888
1889   if (array_check (array, 0) == FAILURE)
1890     return FAILURE;
1891
1892   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1893     return FAILURE;
1894
1895   snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1896             gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1897             gfc_current_intrinsic);
1898   if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1899     return FAILURE;
1900
1901   if (vector != NULL)
1902     {
1903       if (same_type_check (array, 0, vector, 2) == FAILURE)
1904         return FAILURE;
1905
1906       if (rank_check (vector, 2, 1) == FAILURE)
1907         return FAILURE;
1908
1909       /* TODO: More constraints here.  */
1910     }
1911
1912   return SUCCESS;
1913 }
1914
1915
1916 try
1917 gfc_check_precision (gfc_expr *x)
1918 {
1919   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1920     {
1921       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1922                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1923                  gfc_current_intrinsic, &x->where);
1924       return FAILURE;
1925     }
1926
1927   return SUCCESS;
1928 }
1929
1930
1931 try
1932 gfc_check_present (gfc_expr *a)
1933 {
1934   gfc_symbol *sym;
1935
1936   if (variable_check (a, 0) == FAILURE)
1937     return FAILURE;
1938
1939   sym = a->symtree->n.sym;
1940   if (!sym->attr.dummy)
1941     {
1942       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1943                  "dummy variable", gfc_current_intrinsic_arg[0],
1944                  gfc_current_intrinsic, &a->where);
1945       return FAILURE;
1946     }
1947
1948   if (!sym->attr.optional)
1949     {
1950       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1951                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1952                  gfc_current_intrinsic, &a->where);
1953       return FAILURE;
1954     }
1955
1956   /* 13.14.82  PRESENT(A)
1957      ......
1958      Argument.  A shall be the name of an optional dummy argument that is
1959      accessible in the subprogram in which the PRESENT function reference
1960      appears...  */
1961
1962   if (a->ref != NULL
1963       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
1964            && a->ref->u.ar.type == AR_FULL))
1965     {
1966       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
1967                  "subobject of '%s'", gfc_current_intrinsic_arg[0],
1968                  gfc_current_intrinsic, &a->where, sym->name);
1969       return FAILURE;
1970     }
1971
1972   return SUCCESS;
1973 }
1974
1975
1976 try
1977 gfc_check_radix (gfc_expr *x)
1978 {
1979   if (int_or_real_check (x, 0) == FAILURE)
1980     return FAILURE;
1981
1982   return SUCCESS;
1983 }
1984
1985
1986 try
1987 gfc_check_range (gfc_expr *x)
1988 {
1989   if (numeric_check (x, 0) == FAILURE)
1990     return FAILURE;
1991
1992   return SUCCESS;
1993 }
1994
1995
1996 /* real, float, sngl.  */
1997 try
1998 gfc_check_real (gfc_expr *a, gfc_expr *kind)
1999 {
2000   if (numeric_check (a, 0) == FAILURE)
2001     return FAILURE;
2002
2003   if (kind_check (kind, 1, BT_REAL) == FAILURE)
2004     return FAILURE;
2005
2006   return SUCCESS;
2007 }
2008
2009
2010 try
2011 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2012 {
2013   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2014     return FAILURE;
2015
2016   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2017     return FAILURE;
2018
2019   return SUCCESS;
2020 }
2021
2022
2023 try
2024 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2025 {
2026   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2027     return FAILURE;
2028
2029   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2030     return FAILURE;
2031
2032   if (status == NULL)
2033     return SUCCESS;
2034
2035   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2036     return FAILURE;
2037
2038   if (scalar_check (status, 2) == FAILURE)
2039     return FAILURE;
2040
2041   return SUCCESS;
2042 }
2043
2044
2045 try
2046 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2047 {
2048   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2049     return FAILURE;
2050
2051   if (scalar_check (x, 0) == FAILURE)
2052     return FAILURE;
2053
2054   if (type_check (y, 0, BT_INTEGER) == FAILURE)
2055     return FAILURE;
2056
2057   if (scalar_check (y, 1) == FAILURE)
2058     return FAILURE;
2059
2060   return SUCCESS;
2061 }
2062
2063
2064 try
2065 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2066                    gfc_expr *pad, gfc_expr *order)
2067 {
2068   mpz_t size;
2069   mpz_t nelems;
2070   int m;
2071
2072   if (array_check (source, 0) == FAILURE)
2073     return FAILURE;
2074
2075   if (rank_check (shape, 1, 1) == FAILURE)
2076     return FAILURE;
2077
2078   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2079     return FAILURE;
2080
2081   if (gfc_array_size (shape, &size) != SUCCESS)
2082     {
2083       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2084                  "array of constant size", &shape->where);
2085       return FAILURE;
2086     }
2087
2088   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2089   mpz_clear (size);
2090
2091   if (m > 0)
2092     {
2093       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2094                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2095       return FAILURE;
2096     }
2097
2098   if (pad != NULL)
2099     {
2100       if (same_type_check (source, 0, pad, 2) == FAILURE)
2101         return FAILURE;
2102       if (array_check (pad, 2) == FAILURE)
2103         return FAILURE;
2104     }
2105
2106   if (order != NULL && array_check (order, 3) == FAILURE)
2107     return FAILURE;
2108
2109   if (pad == NULL && shape->expr_type == EXPR_ARRAY
2110       && gfc_is_constant_expr (shape)
2111       && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2112            && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2113     {
2114       /* Check the match in size between source and destination.  */
2115       if (gfc_array_size (source, &nelems) == SUCCESS)
2116         {
2117           gfc_constructor *c;
2118           bool test;
2119
2120           c = shape->value.constructor;
2121           mpz_init_set_ui (size, 1);
2122           for (; c; c = c->next)
2123             mpz_mul (size, size, c->expr->value.integer);
2124
2125           test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2126           mpz_clear (nelems);
2127           mpz_clear (size);
2128
2129           if (test)
2130             {
2131               gfc_error ("Without padding, there are not enough elements "
2132                          "in the intrinsic RESHAPE source at %L to match "
2133                          "the shape", &source->where);
2134               return FAILURE;
2135             }
2136         }
2137     }
2138
2139   return SUCCESS;
2140 }
2141
2142
2143 try
2144 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2145 {
2146   if (type_check (x, 0, BT_REAL) == FAILURE)
2147     return FAILURE;
2148
2149   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2150     return FAILURE;
2151
2152   return SUCCESS;
2153 }
2154
2155
2156 try
2157 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2158 {
2159   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2160     return FAILURE;
2161
2162   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2163     return FAILURE;
2164
2165   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2166     return FAILURE;
2167
2168   if (same_type_check (x, 0, y, 1) == FAILURE)
2169     return FAILURE;
2170
2171   return SUCCESS;
2172 }
2173
2174
2175 try
2176 gfc_check_secnds (gfc_expr *r)
2177 {
2178   if (type_check (r, 0, BT_REAL) == FAILURE)
2179     return FAILURE;
2180
2181   if (kind_value_check (r, 0, 4) == FAILURE)
2182     return FAILURE;
2183
2184   if (scalar_check (r, 0) == FAILURE)
2185     return FAILURE;
2186
2187   return SUCCESS;
2188 }
2189
2190
2191 try
2192 gfc_check_selected_int_kind (gfc_expr *r)
2193 {
2194   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2195     return FAILURE;
2196
2197   if (scalar_check (r, 0) == FAILURE)
2198     return FAILURE;
2199
2200   return SUCCESS;
2201 }
2202
2203
2204 try
2205 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2206 {
2207   if (p == NULL && r == NULL)
2208     {
2209       gfc_error ("Missing arguments to %s intrinsic at %L",
2210                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2211
2212       return FAILURE;
2213     }
2214
2215   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2216     return FAILURE;
2217
2218   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2219     return FAILURE;
2220
2221   return SUCCESS;
2222 }
2223
2224
2225 try
2226 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2227 {
2228   if (type_check (x, 0, BT_REAL) == FAILURE)
2229     return FAILURE;
2230
2231   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2232     return FAILURE;
2233
2234   return SUCCESS;
2235 }
2236
2237
2238 try
2239 gfc_check_shape (gfc_expr *source)
2240 {
2241   gfc_array_ref *ar;
2242
2243   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2244     return SUCCESS;
2245
2246   ar = gfc_find_array_ref (source);
2247
2248   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2249     {
2250       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2251                  "an assumed size array", &source->where);
2252       return FAILURE;
2253     }
2254
2255   return SUCCESS;
2256 }
2257
2258
2259 try
2260 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2261 {
2262   if (int_or_real_check (a, 0) == FAILURE)
2263     return FAILURE;
2264
2265   if (same_type_check (a, 0, b, 1) == FAILURE)
2266     return FAILURE;
2267
2268   return SUCCESS;
2269 }
2270
2271
2272 try
2273 gfc_check_size (gfc_expr *array, gfc_expr *dim)
2274 {
2275   if (array_check (array, 0) == FAILURE)
2276     return FAILURE;
2277
2278   if (dim != NULL)
2279     {
2280       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2281         return FAILURE;
2282
2283       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2284         return FAILURE;
2285
2286       if (dim_rank_check (dim, array, 0) == FAILURE)
2287         return FAILURE;
2288     }
2289
2290   return SUCCESS;
2291 }
2292
2293
2294 try
2295 gfc_check_sizeof (gfc_expr *arg __attribute__((unused)))
2296 {
2297   return SUCCESS;
2298 }
2299
2300
2301 try
2302 gfc_check_sleep_sub (gfc_expr *seconds)
2303 {
2304   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2305     return FAILURE;
2306
2307   if (scalar_check (seconds, 0) == FAILURE)
2308     return FAILURE;
2309
2310   return SUCCESS;
2311 }
2312
2313
2314 try
2315 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2316 {
2317   if (source->rank >= GFC_MAX_DIMENSIONS)
2318     {
2319       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2320                  "than rank %d", gfc_current_intrinsic_arg[0],
2321                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2322
2323       return FAILURE;
2324     }
2325
2326   if (dim_check (dim, 1, 0) == FAILURE)
2327     return FAILURE;
2328
2329   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2330     return FAILURE;
2331
2332   if (scalar_check (ncopies, 2) == FAILURE)
2333     return FAILURE;
2334
2335   return SUCCESS;
2336 }
2337
2338
2339 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2340    functions).  */
2341
2342 try
2343 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2344 {
2345   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2346     return FAILURE;
2347
2348   if (scalar_check (unit, 0) == FAILURE)
2349     return FAILURE;
2350
2351   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2352     return FAILURE;
2353
2354   if (status == NULL)
2355     return SUCCESS;
2356
2357   if (type_check (status, 2, BT_INTEGER) == FAILURE
2358       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2359       || scalar_check (status, 2) == FAILURE)
2360     return FAILURE;
2361
2362   return SUCCESS;
2363 }
2364
2365
2366 try
2367 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2368 {
2369   return gfc_check_fgetputc_sub (unit, c, NULL);
2370 }
2371
2372
2373 try
2374 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2375 {
2376   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2377     return FAILURE;
2378
2379   if (status == NULL)
2380     return SUCCESS;
2381
2382   if (type_check (status, 1, BT_INTEGER) == FAILURE
2383       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2384       || scalar_check (status, 1) == FAILURE)
2385     return FAILURE;
2386
2387   return SUCCESS;
2388 }
2389
2390
2391 try
2392 gfc_check_fgetput (gfc_expr *c)
2393 {
2394   return gfc_check_fgetput_sub (c, NULL);
2395 }
2396
2397
2398 try
2399 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2400 {
2401   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2402     return FAILURE;
2403
2404   if (scalar_check (unit, 0) == FAILURE)
2405     return FAILURE;
2406
2407   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2408     return FAILURE;
2409
2410   if (scalar_check (offset, 1) == FAILURE)
2411     return FAILURE;
2412
2413   if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2414     return FAILURE;
2415
2416   if (scalar_check (whence, 2) == FAILURE)
2417     return FAILURE;
2418
2419   if (status == NULL)
2420     return SUCCESS;
2421
2422   if (type_check (status, 3, BT_INTEGER) == FAILURE)
2423     return FAILURE;
2424
2425   if (kind_value_check (status, 3, 4) == FAILURE)
2426     return FAILURE;
2427
2428   if (scalar_check (status, 3) == FAILURE)
2429     return FAILURE;
2430
2431   return SUCCESS;
2432 }
2433
2434
2435
2436 try
2437 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2438 {
2439   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2440     return FAILURE;
2441
2442   if (scalar_check (unit, 0) == FAILURE)
2443     return FAILURE;
2444
2445   if (type_check (array, 1, BT_INTEGER) == FAILURE
2446       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2447     return FAILURE;
2448
2449   if (array_check (array, 1) == FAILURE)
2450     return FAILURE;
2451
2452   return SUCCESS;
2453 }
2454
2455
2456 try
2457 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2458 {
2459   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2460     return FAILURE;
2461
2462   if (scalar_check (unit, 0) == FAILURE)
2463     return FAILURE;
2464
2465   if (type_check (array, 1, BT_INTEGER) == FAILURE
2466       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2467     return FAILURE;
2468
2469   if (array_check (array, 1) == FAILURE)
2470     return FAILURE;
2471
2472   if (status == NULL)
2473     return SUCCESS;
2474
2475   if (type_check (status, 2, BT_INTEGER) == FAILURE
2476       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2477     return FAILURE;
2478
2479   if (scalar_check (status, 2) == FAILURE)
2480     return FAILURE;
2481
2482   return SUCCESS;
2483 }
2484
2485
2486 try
2487 gfc_check_ftell (gfc_expr *unit)
2488 {
2489   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2490     return FAILURE;
2491
2492   if (scalar_check (unit, 0) == FAILURE)
2493     return FAILURE;
2494
2495   return SUCCESS;
2496 }
2497
2498
2499 try
2500 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2501 {
2502   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2503     return FAILURE;
2504
2505   if (scalar_check (unit, 0) == FAILURE)
2506     return FAILURE;
2507
2508   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2509     return FAILURE;
2510
2511   if (scalar_check (offset, 1) == FAILURE)
2512     return FAILURE;
2513
2514   return SUCCESS;
2515 }
2516
2517
2518 try
2519 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2520 {
2521   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2522     return FAILURE;
2523
2524   if (type_check (array, 1, BT_INTEGER) == FAILURE
2525       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2526     return FAILURE;
2527
2528   if (array_check (array, 1) == FAILURE)
2529     return FAILURE;
2530
2531   return SUCCESS;
2532 }
2533
2534
2535 try
2536 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2537 {
2538   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2539     return FAILURE;
2540
2541   if (type_check (array, 1, BT_INTEGER) == FAILURE
2542       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2543     return FAILURE;
2544
2545   if (array_check (array, 1) == FAILURE)
2546     return FAILURE;
2547
2548   if (status == NULL)
2549     return SUCCESS;
2550
2551   if (type_check (status, 2, BT_INTEGER) == FAILURE
2552       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2553     return FAILURE;
2554
2555   if (scalar_check (status, 2) == FAILURE)
2556     return FAILURE;
2557
2558   return SUCCESS;
2559 }
2560
2561
2562 try
2563 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2564                     gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2565 {
2566   if (mold->ts.type == BT_HOLLERITH)
2567     {
2568       gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
2569                  &mold->where, gfc_basic_typename (BT_HOLLERITH));
2570       return FAILURE;
2571     }
2572
2573   if (size != NULL)
2574     {
2575       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2576         return FAILURE;
2577
2578       if (scalar_check (size, 2) == FAILURE)
2579         return FAILURE;
2580
2581       if (nonoptional_check (size, 2) == FAILURE)
2582         return FAILURE;
2583     }
2584
2585   return SUCCESS;
2586 }
2587
2588
2589 try
2590 gfc_check_transpose (gfc_expr *matrix)
2591 {
2592   if (rank_check (matrix, 0, 2) == FAILURE)
2593     return FAILURE;
2594
2595   return SUCCESS;
2596 }
2597
2598
2599 try
2600 gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
2601 {
2602   if (array_check (array, 0) == FAILURE)
2603     return FAILURE;
2604
2605   if (dim != NULL)
2606     {
2607       if (dim_check (dim, 1, 1) == FAILURE)
2608         return FAILURE;
2609
2610       if (dim_rank_check (dim, array, 0) == FAILURE)
2611         return FAILURE;
2612     }
2613
2614   return SUCCESS;
2615 }
2616
2617
2618 try
2619 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2620 {
2621   if (rank_check (vector, 0, 1) == FAILURE)
2622     return FAILURE;
2623
2624   if (array_check (mask, 1) == FAILURE)
2625     return FAILURE;
2626
2627   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2628     return FAILURE;
2629
2630   if (same_type_check (vector, 0, field, 2) == FAILURE)
2631     return FAILURE;
2632
2633   return SUCCESS;
2634 }
2635
2636
2637 try
2638 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2639 {
2640   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2641     return FAILURE;
2642
2643   if (same_type_check (x, 0, y, 1) == FAILURE)
2644     return FAILURE;
2645
2646   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2647     return FAILURE;
2648
2649   return SUCCESS;
2650 }
2651
2652
2653 try
2654 gfc_check_trim (gfc_expr *x)
2655 {
2656   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2657     return FAILURE;
2658
2659   if (scalar_check (x, 0) == FAILURE)
2660     return FAILURE;
2661
2662    return SUCCESS;
2663 }
2664
2665
2666 try
2667 gfc_check_ttynam (gfc_expr *unit)
2668 {
2669   if (scalar_check (unit, 0) == FAILURE)
2670     return FAILURE;
2671
2672   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2673     return FAILURE;
2674
2675   return SUCCESS;
2676 }
2677
2678
2679 /* Common check function for the half a dozen intrinsics that have a
2680    single real argument.  */
2681
2682 try
2683 gfc_check_x (gfc_expr *x)
2684 {
2685   if (type_check (x, 0, BT_REAL) == FAILURE)
2686     return FAILURE;
2687
2688   return SUCCESS;
2689 }
2690
2691
2692 /************* Check functions for intrinsic subroutines *************/
2693
2694 try
2695 gfc_check_cpu_time (gfc_expr *time)
2696 {
2697   if (scalar_check (time, 0) == FAILURE)
2698     return FAILURE;
2699
2700   if (type_check (time, 0, BT_REAL) == FAILURE)
2701     return FAILURE;
2702
2703   if (variable_check (time, 0) == FAILURE)
2704     return FAILURE;
2705
2706   return SUCCESS;
2707 }
2708
2709
2710 try
2711 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2712                          gfc_expr *zone, gfc_expr *values)
2713 {
2714   if (date != NULL)
2715     {
2716       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2717         return FAILURE;
2718       if (scalar_check (date, 0) == FAILURE)
2719         return FAILURE;
2720       if (variable_check (date, 0) == FAILURE)
2721         return FAILURE;
2722     }
2723
2724   if (time != NULL)
2725     {
2726       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2727         return FAILURE;
2728       if (scalar_check (time, 1) == FAILURE)
2729         return FAILURE;
2730       if (variable_check (time, 1) == FAILURE)
2731         return FAILURE;
2732     }
2733
2734   if (zone != NULL)
2735     {
2736       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2737         return FAILURE;
2738       if (scalar_check (zone, 2) == FAILURE)
2739         return FAILURE;
2740       if (variable_check (zone, 2) == FAILURE)
2741         return FAILURE;
2742     }
2743
2744   if (values != NULL)
2745     {
2746       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2747         return FAILURE;
2748       if (array_check (values, 3) == FAILURE)
2749         return FAILURE;
2750       if (rank_check (values, 3, 1) == FAILURE)
2751         return FAILURE;
2752       if (variable_check (values, 3) == FAILURE)
2753         return FAILURE;
2754     }
2755
2756   return SUCCESS;
2757 }
2758
2759
2760 try
2761 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2762                   gfc_expr *to, gfc_expr *topos)
2763 {
2764   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2765     return FAILURE;
2766
2767   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2768     return FAILURE;
2769
2770   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2771     return FAILURE;
2772
2773   if (same_type_check (from, 0, to, 3) == FAILURE)
2774     return FAILURE;
2775
2776   if (variable_check (to, 3) == FAILURE)
2777     return FAILURE;
2778
2779   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2780     return FAILURE;
2781
2782   return SUCCESS;
2783 }
2784
2785
2786 try
2787 gfc_check_random_number (gfc_expr *harvest)
2788 {
2789   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2790     return FAILURE;
2791
2792   if (variable_check (harvest, 0) == FAILURE)
2793     return FAILURE;
2794
2795   return SUCCESS;
2796 }
2797
2798
2799 try
2800 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2801 {
2802   if (size != NULL)
2803     {
2804       if (scalar_check (size, 0) == FAILURE)
2805         return FAILURE;
2806
2807       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2808         return FAILURE;
2809
2810       if (variable_check (size, 0) == FAILURE)
2811         return FAILURE;
2812
2813       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2814         return FAILURE;
2815     }
2816
2817   if (put != NULL)
2818     {
2819
2820       if (size != NULL)
2821         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2822                     &put->where);
2823
2824       if (array_check (put, 1) == FAILURE)
2825         return FAILURE;
2826
2827       if (rank_check (put, 1, 1) == FAILURE)
2828         return FAILURE;
2829
2830       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2831         return FAILURE;
2832
2833       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2834         return FAILURE;
2835     }
2836
2837   if (get != NULL)
2838     {
2839
2840       if (size != NULL || put != NULL)
2841         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2842                    &get->where);
2843
2844       if (array_check (get, 2) == FAILURE)
2845         return FAILURE;
2846
2847       if (rank_check (get, 2, 1) == FAILURE)
2848         return FAILURE;
2849
2850       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2851         return FAILURE;
2852
2853       if (variable_check (get, 2) == FAILURE)
2854         return FAILURE;
2855
2856       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2857         return FAILURE;
2858     }
2859
2860   return SUCCESS;
2861 }
2862
2863
2864 try
2865 gfc_check_second_sub (gfc_expr *time)
2866 {
2867   if (scalar_check (time, 0) == FAILURE)
2868     return FAILURE;
2869
2870   if (type_check (time, 0, BT_REAL) == FAILURE)
2871     return FAILURE;
2872
2873   if (kind_value_check(time, 0, 4) == FAILURE)
2874     return FAILURE;
2875
2876   return SUCCESS;
2877 }
2878
2879
2880 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2881    count, count_rate, and count_max are all optional arguments */
2882
2883 try
2884 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
2885                         gfc_expr *count_max)
2886 {
2887   if (count != NULL)
2888     {
2889       if (scalar_check (count, 0) == FAILURE)
2890         return FAILURE;
2891
2892       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2893         return FAILURE;
2894
2895       if (variable_check (count, 0) == FAILURE)
2896         return FAILURE;
2897     }
2898
2899   if (count_rate != NULL)
2900     {
2901       if (scalar_check (count_rate, 1) == FAILURE)
2902         return FAILURE;
2903
2904       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2905         return FAILURE;
2906
2907       if (variable_check (count_rate, 1) == FAILURE)
2908         return FAILURE;
2909
2910       if (count != NULL
2911           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2912         return FAILURE;
2913
2914     }
2915
2916   if (count_max != NULL)
2917     {
2918       if (scalar_check (count_max, 2) == FAILURE)
2919         return FAILURE;
2920
2921       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2922         return FAILURE;
2923
2924       if (variable_check (count_max, 2) == FAILURE)
2925         return FAILURE;
2926
2927       if (count != NULL
2928           && same_type_check (count, 0, count_max, 2) == FAILURE)
2929         return FAILURE;
2930
2931       if (count_rate != NULL
2932           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2933         return FAILURE;
2934     }
2935
2936   return SUCCESS;
2937 }
2938
2939
2940 try
2941 gfc_check_irand (gfc_expr *x)
2942 {
2943   if (x == NULL)
2944     return SUCCESS;
2945
2946   if (scalar_check (x, 0) == FAILURE)
2947     return FAILURE;
2948
2949   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2950     return FAILURE;
2951
2952   if (kind_value_check(x, 0, 4) == FAILURE)
2953     return FAILURE;
2954
2955   return SUCCESS;
2956 }
2957
2958
2959 try
2960 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
2961 {
2962   if (scalar_check (seconds, 0) == FAILURE)
2963     return FAILURE;
2964
2965   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2966     return FAILURE;
2967
2968   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
2969     {
2970       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
2971                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
2972                  gfc_current_intrinsic, &handler->where);
2973       return FAILURE;
2974     }
2975
2976   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
2977     return FAILURE;
2978
2979   if (status == NULL)
2980     return SUCCESS;
2981
2982   if (scalar_check (status, 2) == FAILURE)
2983     return FAILURE;
2984
2985   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2986     return FAILURE;
2987
2988   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2989     return FAILURE;
2990
2991   return SUCCESS;
2992 }
2993
2994
2995 try
2996 gfc_check_rand (gfc_expr *x)
2997 {
2998   if (x == NULL)
2999     return SUCCESS;
3000
3001   if (scalar_check (x, 0) == FAILURE)
3002     return FAILURE;
3003
3004   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3005     return FAILURE;
3006
3007   if (kind_value_check(x, 0, 4) == FAILURE)
3008     return FAILURE;
3009
3010   return SUCCESS;
3011 }
3012
3013
3014 try
3015 gfc_check_srand (gfc_expr *x)
3016 {
3017   if (scalar_check (x, 0) == FAILURE)
3018     return FAILURE;
3019
3020   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3021     return FAILURE;
3022
3023   if (kind_value_check(x, 0, 4) == FAILURE)
3024     return FAILURE;
3025
3026   return SUCCESS;
3027 }
3028
3029
3030 try
3031 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3032 {
3033   if (scalar_check (time, 0) == FAILURE)
3034     return FAILURE;
3035
3036   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3037     return FAILURE;
3038
3039   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3040     return FAILURE;
3041
3042   return SUCCESS;
3043 }
3044
3045
3046 try
3047 gfc_check_etime (gfc_expr *x)
3048 {
3049   if (array_check (x, 0) == FAILURE)
3050     return FAILURE;
3051
3052   if (rank_check (x, 0, 1) == FAILURE)
3053     return FAILURE;
3054
3055   if (variable_check (x, 0) == FAILURE)
3056     return FAILURE;
3057
3058   if (type_check (x, 0, BT_REAL) == FAILURE)
3059     return FAILURE;
3060
3061   if (kind_value_check(x, 0, 4) == FAILURE)
3062     return FAILURE;
3063
3064   return SUCCESS;
3065 }
3066
3067
3068 try
3069 gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
3070 {
3071   if (array_check (values, 0) == FAILURE)
3072     return FAILURE;
3073
3074   if (rank_check (values, 0, 1) == FAILURE)
3075     return FAILURE;
3076
3077   if (variable_check (values, 0) == FAILURE)
3078     return FAILURE;
3079
3080   if (type_check (values, 0, BT_REAL) == FAILURE)
3081     return FAILURE;
3082
3083   if (kind_value_check(values, 0, 4) == FAILURE)
3084     return FAILURE;
3085
3086   if (scalar_check (time, 1) == FAILURE)
3087     return FAILURE;
3088
3089   if (type_check (time, 1, BT_REAL) == FAILURE)
3090     return FAILURE;
3091
3092   if (kind_value_check(time, 1, 4) == FAILURE)
3093     return FAILURE;
3094
3095   return SUCCESS;
3096 }
3097
3098
3099 try
3100 gfc_check_fdate_sub (gfc_expr *date)
3101 {
3102   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3103     return FAILURE;
3104
3105   return SUCCESS;
3106 }
3107
3108
3109 try
3110 gfc_check_gerror (gfc_expr *msg)
3111 {
3112   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3113     return FAILURE;
3114
3115   return SUCCESS;
3116 }
3117
3118
3119 try
3120 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3121 {
3122   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3123     return FAILURE;
3124
3125   if (status == NULL)
3126     return SUCCESS;
3127
3128   if (scalar_check (status, 1) == FAILURE)
3129     return FAILURE;
3130
3131   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3132     return FAILURE;
3133
3134   return SUCCESS;
3135 }
3136
3137
3138 try
3139 gfc_check_getlog (gfc_expr *msg)
3140 {
3141   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3142     return FAILURE;
3143
3144   return SUCCESS;
3145 }
3146
3147
3148 try
3149 gfc_check_exit (gfc_expr *status)
3150 {
3151   if (status == NULL)
3152     return SUCCESS;
3153
3154   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3155     return FAILURE;
3156
3157   if (scalar_check (status, 0) == FAILURE)
3158     return FAILURE;
3159
3160   return SUCCESS;
3161 }
3162
3163
3164 try
3165 gfc_check_flush (gfc_expr *unit)
3166 {
3167   if (unit == NULL)
3168     return SUCCESS;
3169
3170   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3171     return FAILURE;
3172
3173   if (scalar_check (unit, 0) == FAILURE)
3174     return FAILURE;
3175
3176   return SUCCESS;
3177 }
3178
3179
3180 try
3181 gfc_check_free (gfc_expr *i)
3182 {
3183   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3184     return FAILURE;
3185
3186   if (scalar_check (i, 0) == FAILURE)
3187     return FAILURE;
3188
3189   return SUCCESS;
3190 }
3191
3192
3193 try
3194 gfc_check_hostnm (gfc_expr *name)
3195 {
3196   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3197     return FAILURE;
3198
3199   return SUCCESS;
3200 }
3201
3202
3203 try
3204 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3205 {
3206   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3207     return FAILURE;
3208
3209   if (status == NULL)
3210     return SUCCESS;
3211
3212   if (scalar_check (status, 1) == FAILURE)
3213     return FAILURE;
3214
3215   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3216     return FAILURE;
3217
3218   return SUCCESS;
3219 }
3220
3221
3222 try
3223 gfc_check_itime_idate (gfc_expr *values)
3224 {
3225   if (array_check (values, 0) == FAILURE)
3226     return FAILURE;
3227
3228   if (rank_check (values, 0, 1) == FAILURE)
3229     return FAILURE;
3230
3231   if (variable_check (values, 0) == FAILURE)
3232     return FAILURE;
3233
3234   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3235     return FAILURE;
3236
3237   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3238     return FAILURE;
3239
3240   return SUCCESS;
3241 }
3242
3243
3244 try
3245 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3246 {
3247   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3248     return FAILURE;
3249
3250   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3251     return FAILURE;
3252
3253   if (scalar_check (time, 0) == FAILURE)
3254     return FAILURE;
3255
3256   if (array_check (values, 1) == FAILURE)
3257     return FAILURE;
3258
3259   if (rank_check (values, 1, 1) == FAILURE)
3260     return FAILURE;
3261
3262   if (variable_check (values, 1) == FAILURE)
3263     return FAILURE;
3264
3265   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3266     return FAILURE;
3267
3268   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3269     return FAILURE;
3270
3271   return SUCCESS;
3272 }
3273
3274
3275 try
3276 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3277 {
3278   if (scalar_check (unit, 0) == FAILURE)
3279     return FAILURE;
3280
3281   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3282     return FAILURE;
3283
3284   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3285     return FAILURE;
3286
3287   return SUCCESS;
3288 }
3289
3290
3291 try
3292 gfc_check_isatty (gfc_expr *unit)
3293 {
3294   if (unit == NULL)
3295     return FAILURE;
3296
3297   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3298     return FAILURE;
3299
3300   if (scalar_check (unit, 0) == FAILURE)
3301     return FAILURE;
3302
3303   return SUCCESS;
3304 }
3305
3306
3307 try
3308 gfc_check_perror (gfc_expr *string)
3309 {
3310   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3311     return FAILURE;
3312
3313   return SUCCESS;
3314 }
3315
3316
3317 try
3318 gfc_check_umask (gfc_expr *mask)
3319 {
3320   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3321     return FAILURE;
3322
3323   if (scalar_check (mask, 0) == FAILURE)
3324     return FAILURE;
3325
3326   return SUCCESS;
3327 }
3328
3329
3330 try
3331 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3332 {
3333   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3334     return FAILURE;
3335
3336   if (scalar_check (mask, 0) == FAILURE)
3337     return FAILURE;
3338
3339   if (old == NULL)
3340     return SUCCESS;
3341
3342   if (scalar_check (old, 1) == FAILURE)
3343     return FAILURE;
3344
3345   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3346     return FAILURE;
3347
3348   return SUCCESS;
3349 }
3350
3351
3352 try
3353 gfc_check_unlink (gfc_expr *name)
3354 {
3355   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3356     return FAILURE;
3357
3358   return SUCCESS;
3359 }
3360
3361
3362 try
3363 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3364 {
3365   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3366     return FAILURE;
3367
3368   if (status == NULL)
3369     return SUCCESS;
3370
3371   if (scalar_check (status, 1) == FAILURE)
3372     return FAILURE;
3373
3374   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3375     return FAILURE;
3376
3377   return SUCCESS;
3378 }
3379
3380
3381 try
3382 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3383 {
3384   if (scalar_check (number, 0) == FAILURE)
3385     return FAILURE;
3386
3387   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3388     return FAILURE;
3389
3390   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3391     {
3392       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3393                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3394                  gfc_current_intrinsic, &handler->where);
3395       return FAILURE;
3396     }
3397
3398   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3399     return FAILURE;
3400
3401   return SUCCESS;
3402 }
3403
3404
3405 try
3406 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3407 {
3408   if (scalar_check (number, 0) == FAILURE)
3409     return FAILURE;
3410
3411   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3412     return FAILURE;
3413
3414   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3415     {
3416       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3417                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3418                  gfc_current_intrinsic, &handler->where);
3419       return FAILURE;
3420     }
3421
3422   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3423     return FAILURE;
3424
3425   if (status == NULL)
3426     return SUCCESS;
3427
3428   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3429     return FAILURE;
3430
3431   if (scalar_check (status, 2) == FAILURE)
3432     return FAILURE;
3433
3434   return SUCCESS;
3435 }
3436
3437
3438 try
3439 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3440 {
3441   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3442     return FAILURE;
3443
3444   if (scalar_check (status, 1) == FAILURE)
3445     return FAILURE;
3446
3447   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3448     return FAILURE;
3449
3450   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3451     return FAILURE;
3452
3453   return SUCCESS;
3454 }
3455
3456
3457 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3458 try
3459 gfc_check_and (gfc_expr *i, gfc_expr *j)
3460 {
3461   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3462     {
3463       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3464                  "or LOGICAL", gfc_current_intrinsic_arg[0],
3465                  gfc_current_intrinsic, &i->where);
3466       return FAILURE;
3467     }
3468
3469   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3470     {
3471       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3472                  "or LOGICAL", gfc_current_intrinsic_arg[1],
3473                  gfc_current_intrinsic, &j->where);
3474       return FAILURE;
3475     }
3476
3477   if (i->ts.type != j->ts.type)
3478     {
3479       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3480                  "have the same type", gfc_current_intrinsic_arg[0],
3481                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3482                  &j->where);
3483       return FAILURE;
3484     }
3485
3486   if (scalar_check (i, 0) == FAILURE)
3487     return FAILURE;
3488
3489   if (scalar_check (j, 1) == FAILURE)
3490     return FAILURE;
3491
3492   return SUCCESS;
3493 }