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