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 *arg)
1490 {
1491   gfc_expr *x, *first_arg;
1492   int n;
1493   char buffer[80];
1494
1495   if (min_max_args (arg) == FAILURE)
1496     return FAILURE;
1497
1498   n = 1;
1499
1500   first_arg = arg->expr;
1501   for (; arg; arg = arg->next, n++)
1502     {
1503       x = arg->expr;
1504       if (x->ts.type != type || x->ts.kind != kind)
1505         {
1506           if (x->ts.type == type)
1507             {
1508               if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1509                                   "kinds at %L", &x->where) == FAILURE)
1510                 return FAILURE;
1511             }
1512           else
1513             {
1514               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1515                          "%s(%d)", n, gfc_current_intrinsic, &x->where,
1516                          gfc_basic_typename (type), kind);
1517               return FAILURE;
1518             }
1519         }
1520
1521       snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1522                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n-1],
1523                 gfc_current_intrinsic);
1524       if (gfc_check_conformance (buffer, first_arg, x) == FAILURE)
1525         return FAILURE;
1526     }
1527
1528   return SUCCESS;
1529 }
1530
1531
1532 try
1533 gfc_check_min_max (gfc_actual_arglist *arg)
1534 {
1535   gfc_expr *x;
1536
1537   if (min_max_args (arg) == FAILURE)
1538     return FAILURE;
1539
1540   x = arg->expr;
1541
1542   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1543     {
1544       gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
1545                  "or REAL", gfc_current_intrinsic, &x->where);
1546       return FAILURE;
1547     }
1548
1549   return check_rest (x->ts.type, x->ts.kind, arg);
1550 }
1551
1552
1553 try
1554 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1555 {
1556   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1557 }
1558
1559
1560 try
1561 gfc_check_min_max_real (gfc_actual_arglist *arg)
1562 {
1563   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1564 }
1565
1566
1567 try
1568 gfc_check_min_max_double (gfc_actual_arglist *arg)
1569 {
1570   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1571 }
1572
1573
1574 /* End of min/max family.  */
1575
1576 try
1577 gfc_check_malloc (gfc_expr *size)
1578 {
1579   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1580     return FAILURE;
1581
1582   if (scalar_check (size, 0) == FAILURE)
1583     return FAILURE;
1584
1585   return SUCCESS;
1586 }
1587
1588
1589 try
1590 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1591 {
1592   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1593     {
1594       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1595                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1596                  gfc_current_intrinsic, &matrix_a->where);
1597       return FAILURE;
1598     }
1599
1600   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1601     {
1602       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1603                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1604                  gfc_current_intrinsic, &matrix_b->where);
1605       return FAILURE;
1606     }
1607
1608   switch (matrix_a->rank)
1609     {
1610     case 1:
1611       if (rank_check (matrix_b, 1, 2) == FAILURE)
1612         return FAILURE;
1613       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
1614       if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1615         {
1616           gfc_error ("different shape on dimension 1 for arguments '%s' "
1617                      "and '%s' at %L for intrinsic matmul",
1618                      gfc_current_intrinsic_arg[0],
1619                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1620           return FAILURE;
1621         }
1622       break;
1623
1624     case 2:
1625       if (matrix_b->rank != 2)
1626         {
1627           if (rank_check (matrix_b, 1, 1) == FAILURE)
1628             return FAILURE;
1629         }
1630       /* matrix_b has rank 1 or 2 here. Common check for the cases
1631          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1632          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
1633       if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1634         {
1635           gfc_error ("different shape on dimension 2 for argument '%s' and "
1636                      "dimension 1 for argument '%s' at %L for intrinsic "
1637                      "matmul", gfc_current_intrinsic_arg[0],
1638                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1639           return FAILURE;
1640         }
1641       break;
1642
1643     default:
1644       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1645                  "1 or 2", gfc_current_intrinsic_arg[0],
1646                  gfc_current_intrinsic, &matrix_a->where);
1647       return FAILURE;
1648     }
1649
1650   if (gfc_init_expr)
1651     return non_init_transformational ();
1652
1653   return SUCCESS;
1654 }
1655
1656
1657 /* Whoever came up with this interface was probably on something.
1658    The possibilities for the occupation of the second and third
1659    parameters are:
1660
1661          Arg #2     Arg #3
1662          NULL       NULL
1663          DIM    NULL
1664          MASK       NULL
1665          NULL       MASK             minloc(array, mask=m)
1666          DIM    MASK
1667
1668    I.e. in the case of minloc(array,mask), mask will be in the second
1669    position of the argument list and we'll have to fix that up.  */
1670
1671 try
1672 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1673 {
1674   gfc_expr *a, *m, *d;
1675
1676   a = ap->expr;
1677   if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1678     return FAILURE;
1679
1680   d = ap->next->expr;
1681   m = ap->next->next->expr;
1682
1683   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1684       && ap->next->name == NULL)
1685     {
1686       m = d;
1687       d = NULL;
1688       ap->next->expr = NULL;
1689       ap->next->next->expr = m;
1690     }
1691
1692   if (dim_check (d, 1, 1) == FAILURE)
1693     return FAILURE;
1694
1695   if (d && dim_rank_check (d, a, 0) == FAILURE)
1696     return FAILURE;
1697
1698   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1699     return FAILURE;
1700
1701   if (m != NULL)
1702     {
1703       char buffer[80];
1704       snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1705                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1706                 gfc_current_intrinsic);
1707       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1708         return FAILURE;
1709     }
1710
1711   if (gfc_init_expr)
1712     return non_init_transformational ();
1713
1714   return SUCCESS;
1715 }
1716
1717
1718 /* Similar to minloc/maxloc, the argument list might need to be
1719    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1720    difference is that MINLOC/MAXLOC take an additional KIND argument.
1721    The possibilities are:
1722
1723          Arg #2     Arg #3
1724          NULL       NULL
1725          DIM    NULL
1726          MASK       NULL
1727          NULL       MASK             minval(array, mask=m)
1728          DIM    MASK
1729
1730    I.e. in the case of minval(array,mask), mask will be in the second
1731    position of the argument list and we'll have to fix that up.  */
1732
1733 static try
1734 check_reduction (gfc_actual_arglist *ap)
1735 {
1736   gfc_expr *a, *m, *d;
1737
1738   a = ap->expr;
1739   d = ap->next->expr;
1740   m = ap->next->next->expr;
1741
1742   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1743       && ap->next->name == NULL)
1744     {
1745       m = d;
1746       d = NULL;
1747       ap->next->expr = NULL;
1748       ap->next->next->expr = m;
1749     }
1750
1751   if (dim_check (d, 1, 1) == FAILURE)
1752     return FAILURE;
1753
1754   if (d && dim_rank_check (d, a, 0) == FAILURE)
1755     return FAILURE;
1756
1757   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1758     return FAILURE;
1759
1760   if (m != NULL)
1761     {
1762       char buffer[80];
1763       snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1764                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1765                 gfc_current_intrinsic);
1766       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1767         return FAILURE;
1768     }
1769
1770   return SUCCESS;
1771 }
1772
1773
1774 try
1775 gfc_check_minval_maxval (gfc_actual_arglist *ap)
1776 {
1777   if (int_or_real_check (ap->expr, 0) == FAILURE
1778       || array_check (ap->expr, 0) == FAILURE)
1779     return FAILURE;
1780
1781   if (gfc_init_expr)
1782     return non_init_transformational ();
1783
1784   return check_reduction (ap);
1785 }
1786
1787
1788 try
1789 gfc_check_product_sum (gfc_actual_arglist *ap)
1790 {
1791   if (numeric_check (ap->expr, 0) == FAILURE
1792       || array_check (ap->expr, 0) == FAILURE)
1793     return FAILURE;
1794
1795   if (gfc_init_expr)
1796     return non_init_transformational ();
1797
1798   return check_reduction (ap);
1799 }
1800
1801
1802 try
1803 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
1804 {
1805   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1806     return FAILURE;
1807
1808   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1809     return FAILURE;
1810
1811   return SUCCESS;
1812 }
1813
1814 try
1815 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
1816 {
1817   symbol_attribute attr;
1818
1819   if (variable_check (from, 0) == FAILURE)
1820     return FAILURE;
1821
1822   if (array_check (from, 0) == FAILURE)
1823     return FAILURE;
1824
1825   attr = gfc_variable_attr (from, NULL);
1826   if (!attr.allocatable)
1827     {
1828       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1829                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1830                  &from->where);
1831       return FAILURE;
1832     }
1833
1834   if (variable_check (to, 0) == FAILURE)
1835     return FAILURE;
1836
1837   if (array_check (to, 0) == FAILURE)
1838     return FAILURE;
1839
1840   attr = gfc_variable_attr (to, NULL);
1841   if (!attr.allocatable)
1842     {
1843       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1844                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1845                  &to->where);
1846       return FAILURE;
1847     }
1848
1849   if (same_type_check (from, 0, to, 1) == FAILURE)
1850     return FAILURE;
1851
1852   if (to->rank != from->rank)
1853     {
1854       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1855                  "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1856                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1857                  &to->where,  from->rank, to->rank);
1858       return FAILURE;
1859     }
1860
1861   if (to->ts.kind != from->ts.kind)
1862     {
1863       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1864                  "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1865                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1866                  &to->where, from->ts.kind, to->ts.kind);
1867       return FAILURE;
1868     }
1869
1870   return SUCCESS;
1871 }
1872
1873
1874 try
1875 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
1876 {
1877   if (type_check (x, 0, BT_REAL) == FAILURE)
1878     return FAILURE;
1879
1880   if (type_check (s, 1, BT_REAL) == FAILURE)
1881     return FAILURE;
1882
1883   return SUCCESS;
1884 }
1885
1886
1887 try
1888 gfc_check_new_line (gfc_expr *a)
1889 {
1890   if (type_check (a, 0, BT_CHARACTER) == FAILURE)
1891     return FAILURE;
1892
1893   return SUCCESS;
1894 }
1895
1896
1897 try
1898 gfc_check_null (gfc_expr *mold)
1899 {
1900   symbol_attribute attr;
1901
1902   if (mold == NULL)
1903     return SUCCESS;
1904
1905   if (variable_check (mold, 0) == FAILURE)
1906     return FAILURE;
1907
1908   attr = gfc_variable_attr (mold, NULL);
1909
1910   if (!attr.pointer)
1911     {
1912       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
1913                  gfc_current_intrinsic_arg[0],
1914                  gfc_current_intrinsic, &mold->where);
1915       return FAILURE;
1916     }
1917
1918   return SUCCESS;
1919 }
1920
1921
1922 try
1923 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
1924 {
1925   char buffer[80];
1926
1927   if (array_check (array, 0) == FAILURE)
1928     return FAILURE;
1929
1930   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
1931     return FAILURE;
1932
1933   snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
1934             gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
1935             gfc_current_intrinsic);
1936   if (gfc_check_conformance (buffer, array, mask) == FAILURE)
1937     return FAILURE;
1938
1939   if (vector != NULL)
1940     {
1941       if (same_type_check (array, 0, vector, 2) == FAILURE)
1942         return FAILURE;
1943
1944       if (rank_check (vector, 2, 1) == FAILURE)
1945         return FAILURE;
1946
1947       /* TODO: More constraints here.  */
1948     }
1949
1950   if (gfc_init_expr)
1951     return non_init_transformational ();
1952
1953   return SUCCESS;
1954 }
1955
1956
1957 try
1958 gfc_check_precision (gfc_expr *x)
1959 {
1960   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
1961     {
1962       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
1963                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
1964                  gfc_current_intrinsic, &x->where);
1965       return FAILURE;
1966     }
1967
1968   return SUCCESS;
1969 }
1970
1971
1972 try
1973 gfc_check_present (gfc_expr *a)
1974 {
1975   gfc_symbol *sym;
1976
1977   if (variable_check (a, 0) == FAILURE)
1978     return FAILURE;
1979
1980   sym = a->symtree->n.sym;
1981   if (!sym->attr.dummy)
1982     {
1983       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
1984                  "dummy variable", gfc_current_intrinsic_arg[0],
1985                  gfc_current_intrinsic, &a->where);
1986       return FAILURE;
1987     }
1988
1989   if (!sym->attr.optional)
1990     {
1991       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
1992                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
1993                  gfc_current_intrinsic, &a->where);
1994       return FAILURE;
1995     }
1996
1997   /* 13.14.82  PRESENT(A)
1998      ......
1999      Argument.  A shall be the name of an optional dummy argument that is
2000      accessible in the subprogram in which the PRESENT function reference
2001      appears...  */
2002
2003   if (a->ref != NULL
2004       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2005            && a->ref->u.ar.type == AR_FULL))
2006     {
2007       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2008                  "subobject of '%s'", gfc_current_intrinsic_arg[0],
2009                  gfc_current_intrinsic, &a->where, sym->name);
2010       return FAILURE;
2011     }
2012
2013   return SUCCESS;
2014 }
2015
2016
2017 try
2018 gfc_check_radix (gfc_expr *x)
2019 {
2020   if (int_or_real_check (x, 0) == FAILURE)
2021     return FAILURE;
2022
2023   return SUCCESS;
2024 }
2025
2026
2027 try
2028 gfc_check_range (gfc_expr *x)
2029 {
2030   if (numeric_check (x, 0) == FAILURE)
2031     return FAILURE;
2032
2033   return SUCCESS;
2034 }
2035
2036
2037 /* real, float, sngl.  */
2038 try
2039 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2040 {
2041   if (numeric_check (a, 0) == FAILURE)
2042     return FAILURE;
2043
2044   if (kind_check (kind, 1, BT_REAL) == FAILURE)
2045     return FAILURE;
2046
2047   return SUCCESS;
2048 }
2049
2050
2051 try
2052 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2053 {
2054   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2055     return FAILURE;
2056
2057   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2058     return FAILURE;
2059
2060   return SUCCESS;
2061 }
2062
2063
2064 try
2065 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2066 {
2067   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2068     return FAILURE;
2069
2070   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2071     return FAILURE;
2072
2073   if (status == NULL)
2074     return SUCCESS;
2075
2076   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2077     return FAILURE;
2078
2079   if (scalar_check (status, 2) == FAILURE)
2080     return FAILURE;
2081
2082   return SUCCESS;
2083 }
2084
2085
2086 try
2087 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2088 {
2089   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2090     return FAILURE;
2091
2092   if (scalar_check (x, 0) == FAILURE)
2093     return FAILURE;
2094
2095   if (type_check (y, 0, BT_INTEGER) == FAILURE)
2096     return FAILURE;
2097
2098   if (scalar_check (y, 1) == FAILURE)
2099     return FAILURE;
2100
2101   return SUCCESS;
2102 }
2103
2104
2105 try
2106 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2107                    gfc_expr *pad, gfc_expr *order)
2108 {
2109   mpz_t size;
2110   mpz_t nelems;
2111   int m;
2112
2113   if (array_check (source, 0) == FAILURE)
2114     return FAILURE;
2115
2116   if (rank_check (shape, 1, 1) == FAILURE)
2117     return FAILURE;
2118
2119   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2120     return FAILURE;
2121
2122   if (gfc_array_size (shape, &size) != SUCCESS)
2123     {
2124       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2125                  "array of constant size", &shape->where);
2126       return FAILURE;
2127     }
2128
2129   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2130   mpz_clear (size);
2131
2132   if (m > 0)
2133     {
2134       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2135                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2136       return FAILURE;
2137     }
2138
2139   if (pad != NULL)
2140     {
2141       if (same_type_check (source, 0, pad, 2) == FAILURE)
2142         return FAILURE;
2143       if (array_check (pad, 2) == FAILURE)
2144         return FAILURE;
2145     }
2146
2147   if (order != NULL && array_check (order, 3) == FAILURE)
2148     return FAILURE;
2149
2150   if (pad == NULL && shape->expr_type == EXPR_ARRAY
2151       && gfc_is_constant_expr (shape)
2152       && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2153            && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2154     {
2155       /* Check the match in size between source and destination.  */
2156       if (gfc_array_size (source, &nelems) == SUCCESS)
2157         {
2158           gfc_constructor *c;
2159           bool test;
2160
2161           c = shape->value.constructor;
2162           mpz_init_set_ui (size, 1);
2163           for (; c; c = c->next)
2164             mpz_mul (size, size, c->expr->value.integer);
2165
2166           test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2167           mpz_clear (nelems);
2168           mpz_clear (size);
2169
2170           if (test)
2171             {
2172               gfc_error ("Without padding, there are not enough elements "
2173                          "in the intrinsic RESHAPE source at %L to match "
2174                          "the shape", &source->where);
2175               return FAILURE;
2176             }
2177         }
2178     }
2179
2180   return SUCCESS;
2181 }
2182
2183
2184 try
2185 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2186 {
2187   if (type_check (x, 0, BT_REAL) == FAILURE)
2188     return FAILURE;
2189
2190   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2191     return FAILURE;
2192
2193   return SUCCESS;
2194 }
2195
2196
2197 try
2198 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2199 {
2200   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2201     return FAILURE;
2202
2203   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2204     return FAILURE;
2205
2206   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2207     return FAILURE;
2208
2209   if (same_type_check (x, 0, y, 1) == FAILURE)
2210     return FAILURE;
2211
2212   return SUCCESS;
2213 }
2214
2215
2216 try
2217 gfc_check_secnds (gfc_expr *r)
2218 {
2219   if (type_check (r, 0, BT_REAL) == FAILURE)
2220     return FAILURE;
2221
2222   if (kind_value_check (r, 0, 4) == FAILURE)
2223     return FAILURE;
2224
2225   if (scalar_check (r, 0) == FAILURE)
2226     return FAILURE;
2227
2228   return SUCCESS;
2229 }
2230
2231
2232 try
2233 gfc_check_selected_int_kind (gfc_expr *r)
2234 {
2235   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2236     return FAILURE;
2237
2238   if (scalar_check (r, 0) == FAILURE)
2239     return FAILURE;
2240
2241   return SUCCESS;
2242 }
2243
2244
2245 try
2246 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2247 {
2248   if (p == NULL && r == NULL)
2249     {
2250       gfc_error ("Missing arguments to %s intrinsic at %L",
2251                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2252
2253       return FAILURE;
2254     }
2255
2256   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2257     return FAILURE;
2258
2259   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2260     return FAILURE;
2261
2262   return SUCCESS;
2263 }
2264
2265
2266 try
2267 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2268 {
2269   if (type_check (x, 0, BT_REAL) == FAILURE)
2270     return FAILURE;
2271
2272   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2273     return FAILURE;
2274
2275   return SUCCESS;
2276 }
2277
2278
2279 try
2280 gfc_check_shape (gfc_expr *source)
2281 {
2282   gfc_array_ref *ar;
2283
2284   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2285     return SUCCESS;
2286
2287   ar = gfc_find_array_ref (source);
2288
2289   if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
2290     {
2291       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2292                  "an assumed size array", &source->where);
2293       return FAILURE;
2294     }
2295
2296   return SUCCESS;
2297 }
2298
2299
2300 try
2301 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2302 {
2303   if (int_or_real_check (a, 0) == FAILURE)
2304     return FAILURE;
2305
2306   if (same_type_check (a, 0, b, 1) == FAILURE)
2307     return FAILURE;
2308
2309   return SUCCESS;
2310 }
2311
2312
2313 try
2314 gfc_check_size (gfc_expr *array, gfc_expr *dim)
2315 {
2316   if (array_check (array, 0) == FAILURE)
2317     return FAILURE;
2318
2319   if (dim != NULL)
2320     {
2321       if (type_check (dim, 1, BT_INTEGER) == FAILURE)
2322         return FAILURE;
2323
2324       if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
2325         return FAILURE;
2326
2327       if (dim_rank_check (dim, array, 0) == FAILURE)
2328         return FAILURE;
2329     }
2330
2331   return SUCCESS;
2332 }
2333
2334
2335 try
2336 gfc_check_sleep_sub (gfc_expr *seconds)
2337 {
2338   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2339     return FAILURE;
2340
2341   if (scalar_check (seconds, 0) == FAILURE)
2342     return FAILURE;
2343
2344   return SUCCESS;
2345 }
2346
2347
2348 try
2349 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2350 {
2351   if (source->rank >= GFC_MAX_DIMENSIONS)
2352     {
2353       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2354                  "than rank %d", gfc_current_intrinsic_arg[0],
2355                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2356
2357       return FAILURE;
2358     }
2359
2360   if (dim_check (dim, 1, 0) == FAILURE)
2361     return FAILURE;
2362
2363   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2364     return FAILURE;
2365
2366   if (scalar_check (ncopies, 2) == FAILURE)
2367     return FAILURE;
2368
2369   if (gfc_init_expr)
2370     return non_init_transformational ();
2371
2372   return SUCCESS;
2373 }
2374
2375
2376 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2377    functions).  */
2378
2379 try
2380 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2381 {
2382   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2383     return FAILURE;
2384
2385   if (scalar_check (unit, 0) == FAILURE)
2386     return FAILURE;
2387
2388   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2389     return FAILURE;
2390
2391   if (status == NULL)
2392     return SUCCESS;
2393
2394   if (type_check (status, 2, BT_INTEGER) == FAILURE
2395       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2396       || scalar_check (status, 2) == FAILURE)
2397     return FAILURE;
2398
2399   return SUCCESS;
2400 }
2401
2402
2403 try
2404 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2405 {
2406   return gfc_check_fgetputc_sub (unit, c, NULL);
2407 }
2408
2409
2410 try
2411 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2412 {
2413   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2414     return FAILURE;
2415
2416   if (status == NULL)
2417     return SUCCESS;
2418
2419   if (type_check (status, 1, BT_INTEGER) == FAILURE
2420       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2421       || scalar_check (status, 1) == FAILURE)
2422     return FAILURE;
2423
2424   return SUCCESS;
2425 }
2426
2427
2428 try
2429 gfc_check_fgetput (gfc_expr *c)
2430 {
2431   return gfc_check_fgetput_sub (c, NULL);
2432 }
2433
2434
2435 try
2436 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2437 {
2438   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2439     return FAILURE;
2440
2441   if (scalar_check (unit, 0) == FAILURE)
2442     return FAILURE;
2443
2444   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2445     return FAILURE;
2446
2447   if (scalar_check (offset, 1) == FAILURE)
2448     return FAILURE;
2449
2450   if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2451     return FAILURE;
2452
2453   if (scalar_check (whence, 2) == FAILURE)
2454     return FAILURE;
2455
2456   if (status == NULL)
2457     return SUCCESS;
2458
2459   if (type_check (status, 3, BT_INTEGER) == FAILURE)
2460     return FAILURE;
2461
2462   if (kind_value_check (status, 3, 4) == FAILURE)
2463     return FAILURE;
2464
2465   if (scalar_check (status, 3) == FAILURE)
2466     return FAILURE;
2467
2468   return SUCCESS;
2469 }
2470
2471
2472
2473 try
2474 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2475 {
2476   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2477     return FAILURE;
2478
2479   if (scalar_check (unit, 0) == FAILURE)
2480     return FAILURE;
2481
2482   if (type_check (array, 1, BT_INTEGER) == FAILURE
2483       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2484     return FAILURE;
2485
2486   if (array_check (array, 1) == FAILURE)
2487     return FAILURE;
2488
2489   return SUCCESS;
2490 }
2491
2492
2493 try
2494 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2495 {
2496   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2497     return FAILURE;
2498
2499   if (scalar_check (unit, 0) == FAILURE)
2500     return FAILURE;
2501
2502   if (type_check (array, 1, BT_INTEGER) == FAILURE
2503       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2504     return FAILURE;
2505
2506   if (array_check (array, 1) == FAILURE)
2507     return FAILURE;
2508
2509   if (status == NULL)
2510     return SUCCESS;
2511
2512   if (type_check (status, 2, BT_INTEGER) == FAILURE
2513       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2514     return FAILURE;
2515
2516   if (scalar_check (status, 2) == FAILURE)
2517     return FAILURE;
2518
2519   return SUCCESS;
2520 }
2521
2522
2523 try
2524 gfc_check_ftell (gfc_expr *unit)
2525 {
2526   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2527     return FAILURE;
2528
2529   if (scalar_check (unit, 0) == FAILURE)
2530     return FAILURE;
2531
2532   return SUCCESS;
2533 }
2534
2535
2536 try
2537 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2538 {
2539   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2540     return FAILURE;
2541
2542   if (scalar_check (unit, 0) == FAILURE)
2543     return FAILURE;
2544
2545   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2546     return FAILURE;
2547
2548   if (scalar_check (offset, 1) == FAILURE)
2549     return FAILURE;
2550
2551   return SUCCESS;
2552 }
2553
2554
2555 try
2556 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2557 {
2558   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2559     return FAILURE;
2560
2561   if (type_check (array, 1, BT_INTEGER) == FAILURE
2562       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2563     return FAILURE;
2564
2565   if (array_check (array, 1) == FAILURE)
2566     return FAILURE;
2567
2568   return SUCCESS;
2569 }
2570
2571
2572 try
2573 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2574 {
2575   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2576     return FAILURE;
2577
2578   if (type_check (array, 1, BT_INTEGER) == FAILURE
2579       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2580     return FAILURE;
2581
2582   if (array_check (array, 1) == FAILURE)
2583     return FAILURE;
2584
2585   if (status == NULL)
2586     return SUCCESS;
2587
2588   if (type_check (status, 2, BT_INTEGER) == FAILURE
2589       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2590     return FAILURE;
2591
2592   if (scalar_check (status, 2) == FAILURE)
2593     return FAILURE;
2594
2595   return SUCCESS;
2596 }
2597
2598
2599 try
2600 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2601                     gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2602 {
2603   if (size != NULL)
2604     {
2605       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2606         return FAILURE;
2607
2608       if (scalar_check (size, 2) == FAILURE)
2609         return FAILURE;
2610
2611       if (nonoptional_check (size, 2) == FAILURE)
2612         return FAILURE;
2613     }
2614
2615   return SUCCESS;
2616 }
2617
2618
2619 try
2620 gfc_check_transpose (gfc_expr *matrix)
2621 {
2622   if (rank_check (matrix, 0, 2) == FAILURE)
2623     return FAILURE;
2624
2625   if (gfc_init_expr)
2626     return non_init_transformational ();
2627
2628   return SUCCESS;
2629 }
2630
2631
2632 try
2633 gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
2634 {
2635   if (array_check (array, 0) == FAILURE)
2636     return FAILURE;
2637
2638   if (dim != NULL)
2639     {
2640       if (dim_check (dim, 1, 1) == FAILURE)
2641         return FAILURE;
2642
2643       if (dim_rank_check (dim, array, 0) == FAILURE)
2644         return FAILURE;
2645     }
2646
2647   return SUCCESS;
2648 }
2649
2650
2651 try
2652 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2653 {
2654   if (rank_check (vector, 0, 1) == FAILURE)
2655     return FAILURE;
2656
2657   if (array_check (mask, 1) == FAILURE)
2658     return FAILURE;
2659
2660   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2661     return FAILURE;
2662
2663   if (same_type_check (vector, 0, field, 2) == FAILURE)
2664     return FAILURE;
2665
2666   if (gfc_init_expr)
2667     return non_init_transformational ();
2668
2669   return SUCCESS;
2670 }
2671
2672
2673 try
2674 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2675 {
2676   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2677     return FAILURE;
2678
2679   if (same_type_check (x, 0, y, 1) == FAILURE)
2680     return FAILURE;
2681
2682   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2683     return FAILURE;
2684
2685   return SUCCESS;
2686 }
2687
2688
2689 try
2690 gfc_check_trim (gfc_expr *x)
2691 {
2692   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2693     return FAILURE;
2694
2695   if (scalar_check (x, 0) == FAILURE)
2696     return FAILURE;
2697
2698    return SUCCESS;
2699 }
2700
2701
2702 try
2703 gfc_check_ttynam (gfc_expr *unit)
2704 {
2705   if (scalar_check (unit, 0) == FAILURE)
2706     return FAILURE;
2707
2708   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2709     return FAILURE;
2710
2711   return SUCCESS;
2712 }
2713
2714
2715 /* Common check function for the half a dozen intrinsics that have a
2716    single real argument.  */
2717
2718 try
2719 gfc_check_x (gfc_expr *x)
2720 {
2721   if (type_check (x, 0, BT_REAL) == FAILURE)
2722     return FAILURE;
2723
2724   return SUCCESS;
2725 }
2726
2727
2728 /************* Check functions for intrinsic subroutines *************/
2729
2730 try
2731 gfc_check_cpu_time (gfc_expr *time)
2732 {
2733   if (scalar_check (time, 0) == FAILURE)
2734     return FAILURE;
2735
2736   if (type_check (time, 0, BT_REAL) == FAILURE)
2737     return FAILURE;
2738
2739   if (variable_check (time, 0) == FAILURE)
2740     return FAILURE;
2741
2742   return SUCCESS;
2743 }
2744
2745
2746 try
2747 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2748                          gfc_expr *zone, gfc_expr *values)
2749 {
2750   if (date != NULL)
2751     {
2752       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2753         return FAILURE;
2754       if (scalar_check (date, 0) == FAILURE)
2755         return FAILURE;
2756       if (variable_check (date, 0) == FAILURE)
2757         return FAILURE;
2758     }
2759
2760   if (time != NULL)
2761     {
2762       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2763         return FAILURE;
2764       if (scalar_check (time, 1) == FAILURE)
2765         return FAILURE;
2766       if (variable_check (time, 1) == FAILURE)
2767         return FAILURE;
2768     }
2769
2770   if (zone != NULL)
2771     {
2772       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2773         return FAILURE;
2774       if (scalar_check (zone, 2) == FAILURE)
2775         return FAILURE;
2776       if (variable_check (zone, 2) == FAILURE)
2777         return FAILURE;
2778     }
2779
2780   if (values != NULL)
2781     {
2782       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2783         return FAILURE;
2784       if (array_check (values, 3) == FAILURE)
2785         return FAILURE;
2786       if (rank_check (values, 3, 1) == FAILURE)
2787         return FAILURE;
2788       if (variable_check (values, 3) == FAILURE)
2789         return FAILURE;
2790     }
2791
2792   return SUCCESS;
2793 }
2794
2795
2796 try
2797 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2798                   gfc_expr *to, gfc_expr *topos)
2799 {
2800   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2801     return FAILURE;
2802
2803   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2804     return FAILURE;
2805
2806   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2807     return FAILURE;
2808
2809   if (same_type_check (from, 0, to, 3) == FAILURE)
2810     return FAILURE;
2811
2812   if (variable_check (to, 3) == FAILURE)
2813     return FAILURE;
2814
2815   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2816     return FAILURE;
2817
2818   return SUCCESS;
2819 }
2820
2821
2822 try
2823 gfc_check_random_number (gfc_expr *harvest)
2824 {
2825   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2826     return FAILURE;
2827
2828   if (variable_check (harvest, 0) == FAILURE)
2829     return FAILURE;
2830
2831   return SUCCESS;
2832 }
2833
2834
2835 try
2836 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2837 {
2838   if (size != NULL)
2839     {
2840       if (scalar_check (size, 0) == FAILURE)
2841         return FAILURE;
2842
2843       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2844         return FAILURE;
2845
2846       if (variable_check (size, 0) == FAILURE)
2847         return FAILURE;
2848
2849       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2850         return FAILURE;
2851     }
2852
2853   if (put != NULL)
2854     {
2855
2856       if (size != NULL)
2857         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2858                     &put->where);
2859
2860       if (array_check (put, 1) == FAILURE)
2861         return FAILURE;
2862
2863       if (rank_check (put, 1, 1) == FAILURE)
2864         return FAILURE;
2865
2866       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2867         return FAILURE;
2868
2869       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2870         return FAILURE;
2871     }
2872
2873   if (get != NULL)
2874     {
2875
2876       if (size != NULL || put != NULL)
2877         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2878                    &get->where);
2879
2880       if (array_check (get, 2) == FAILURE)
2881         return FAILURE;
2882
2883       if (rank_check (get, 2, 1) == FAILURE)
2884         return FAILURE;
2885
2886       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2887         return FAILURE;
2888
2889       if (variable_check (get, 2) == FAILURE)
2890         return FAILURE;
2891
2892       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2893         return FAILURE;
2894     }
2895
2896   return SUCCESS;
2897 }
2898
2899
2900 try
2901 gfc_check_second_sub (gfc_expr *time)
2902 {
2903   if (scalar_check (time, 0) == FAILURE)
2904     return FAILURE;
2905
2906   if (type_check (time, 0, BT_REAL) == FAILURE)
2907     return FAILURE;
2908
2909   if (kind_value_check(time, 0, 4) == FAILURE)
2910     return FAILURE;
2911
2912   return SUCCESS;
2913 }
2914
2915
2916 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2917    count, count_rate, and count_max are all optional arguments */
2918
2919 try
2920 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
2921                         gfc_expr *count_max)
2922 {
2923   if (count != NULL)
2924     {
2925       if (scalar_check (count, 0) == FAILURE)
2926         return FAILURE;
2927
2928       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2929         return FAILURE;
2930
2931       if (variable_check (count, 0) == FAILURE)
2932         return FAILURE;
2933     }
2934
2935   if (count_rate != NULL)
2936     {
2937       if (scalar_check (count_rate, 1) == FAILURE)
2938         return FAILURE;
2939
2940       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2941         return FAILURE;
2942
2943       if (variable_check (count_rate, 1) == FAILURE)
2944         return FAILURE;
2945
2946       if (count != NULL
2947           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2948         return FAILURE;
2949
2950     }
2951
2952   if (count_max != NULL)
2953     {
2954       if (scalar_check (count_max, 2) == FAILURE)
2955         return FAILURE;
2956
2957       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2958         return FAILURE;
2959
2960       if (variable_check (count_max, 2) == FAILURE)
2961         return FAILURE;
2962
2963       if (count != NULL
2964           && same_type_check (count, 0, count_max, 2) == FAILURE)
2965         return FAILURE;
2966
2967       if (count_rate != NULL
2968           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2969         return FAILURE;
2970     }
2971
2972   return SUCCESS;
2973 }
2974
2975
2976 try
2977 gfc_check_irand (gfc_expr *x)
2978 {
2979   if (x == NULL)
2980     return SUCCESS;
2981
2982   if (scalar_check (x, 0) == FAILURE)
2983     return FAILURE;
2984
2985   if (type_check (x, 0, BT_INTEGER) == FAILURE)
2986     return FAILURE;
2987
2988   if (kind_value_check(x, 0, 4) == FAILURE)
2989     return FAILURE;
2990
2991   return SUCCESS;
2992 }
2993
2994
2995 try
2996 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
2997 {
2998   if (scalar_check (seconds, 0) == FAILURE)
2999     return FAILURE;
3000
3001   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3002     return FAILURE;
3003
3004   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3005     {
3006       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3007                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3008                  gfc_current_intrinsic, &handler->where);
3009       return FAILURE;
3010     }
3011
3012   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3013     return FAILURE;
3014
3015   if (status == NULL)
3016     return SUCCESS;
3017
3018   if (scalar_check (status, 2) == FAILURE)
3019     return FAILURE;
3020
3021   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3022     return FAILURE;
3023
3024   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3025     return FAILURE;
3026
3027   return SUCCESS;
3028 }
3029
3030
3031 try
3032 gfc_check_rand (gfc_expr *x)
3033 {
3034   if (x == NULL)
3035     return SUCCESS;
3036
3037   if (scalar_check (x, 0) == FAILURE)
3038     return FAILURE;
3039
3040   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3041     return FAILURE;
3042
3043   if (kind_value_check(x, 0, 4) == FAILURE)
3044     return FAILURE;
3045
3046   return SUCCESS;
3047 }
3048
3049
3050 try
3051 gfc_check_srand (gfc_expr *x)
3052 {
3053   if (scalar_check (x, 0) == FAILURE)
3054     return FAILURE;
3055
3056   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3057     return FAILURE;
3058
3059   if (kind_value_check(x, 0, 4) == FAILURE)
3060     return FAILURE;
3061
3062   return SUCCESS;
3063 }
3064
3065
3066 try
3067 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3068 {
3069   if (scalar_check (time, 0) == FAILURE)
3070     return FAILURE;
3071
3072   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3073     return FAILURE;
3074
3075   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3076     return FAILURE;
3077
3078   return SUCCESS;
3079 }
3080
3081
3082 try
3083 gfc_check_etime (gfc_expr *x)
3084 {
3085   if (array_check (x, 0) == FAILURE)
3086     return FAILURE;
3087
3088   if (rank_check (x, 0, 1) == FAILURE)
3089     return FAILURE;
3090
3091   if (variable_check (x, 0) == FAILURE)
3092     return FAILURE;
3093
3094   if (type_check (x, 0, BT_REAL) == FAILURE)
3095     return FAILURE;
3096
3097   if (kind_value_check(x, 0, 4) == FAILURE)
3098     return FAILURE;
3099
3100   return SUCCESS;
3101 }
3102
3103
3104 try
3105 gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
3106 {
3107   if (array_check (values, 0) == FAILURE)
3108     return FAILURE;
3109
3110   if (rank_check (values, 0, 1) == FAILURE)
3111     return FAILURE;
3112
3113   if (variable_check (values, 0) == FAILURE)
3114     return FAILURE;
3115
3116   if (type_check (values, 0, BT_REAL) == FAILURE)
3117     return FAILURE;
3118
3119   if (kind_value_check(values, 0, 4) == FAILURE)
3120     return FAILURE;
3121
3122   if (scalar_check (time, 1) == FAILURE)
3123     return FAILURE;
3124
3125   if (type_check (time, 1, BT_REAL) == FAILURE)
3126     return FAILURE;
3127
3128   if (kind_value_check(time, 1, 4) == FAILURE)
3129     return FAILURE;
3130
3131   return SUCCESS;
3132 }
3133
3134
3135 try
3136 gfc_check_fdate_sub (gfc_expr *date)
3137 {
3138   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3139     return FAILURE;
3140
3141   return SUCCESS;
3142 }
3143
3144
3145 try
3146 gfc_check_gerror (gfc_expr *msg)
3147 {
3148   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3149     return FAILURE;
3150
3151   return SUCCESS;
3152 }
3153
3154
3155 try
3156 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3157 {
3158   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3159     return FAILURE;
3160
3161   if (status == NULL)
3162     return SUCCESS;
3163
3164   if (scalar_check (status, 1) == FAILURE)
3165     return FAILURE;
3166
3167   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3168     return FAILURE;
3169
3170   return SUCCESS;
3171 }
3172
3173
3174 try
3175 gfc_check_getlog (gfc_expr *msg)
3176 {
3177   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3178     return FAILURE;
3179
3180   return SUCCESS;
3181 }
3182
3183
3184 try
3185 gfc_check_exit (gfc_expr *status)
3186 {
3187   if (status == NULL)
3188     return SUCCESS;
3189
3190   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3191     return FAILURE;
3192
3193   if (scalar_check (status, 0) == FAILURE)
3194     return FAILURE;
3195
3196   return SUCCESS;
3197 }
3198
3199
3200 try
3201 gfc_check_flush (gfc_expr *unit)
3202 {
3203   if (unit == NULL)
3204     return SUCCESS;
3205
3206   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3207     return FAILURE;
3208
3209   if (scalar_check (unit, 0) == FAILURE)
3210     return FAILURE;
3211
3212   return SUCCESS;
3213 }
3214
3215
3216 try
3217 gfc_check_free (gfc_expr *i)
3218 {
3219   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3220     return FAILURE;
3221
3222   if (scalar_check (i, 0) == FAILURE)
3223     return FAILURE;
3224
3225   return SUCCESS;
3226 }
3227
3228
3229 try
3230 gfc_check_hostnm (gfc_expr *name)
3231 {
3232   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3233     return FAILURE;
3234
3235   return SUCCESS;
3236 }
3237
3238
3239 try
3240 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3241 {
3242   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3243     return FAILURE;
3244
3245   if (status == NULL)
3246     return SUCCESS;
3247
3248   if (scalar_check (status, 1) == FAILURE)
3249     return FAILURE;
3250
3251   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3252     return FAILURE;
3253
3254   return SUCCESS;
3255 }
3256
3257
3258 try
3259 gfc_check_itime_idate (gfc_expr *values)
3260 {
3261   if (array_check (values, 0) == FAILURE)
3262     return FAILURE;
3263
3264   if (rank_check (values, 0, 1) == FAILURE)
3265     return FAILURE;
3266
3267   if (variable_check (values, 0) == FAILURE)
3268     return FAILURE;
3269
3270   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3271     return FAILURE;
3272
3273   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3274     return FAILURE;
3275
3276   return SUCCESS;
3277 }
3278
3279
3280 try
3281 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3282 {
3283   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3284     return FAILURE;
3285
3286   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3287     return FAILURE;
3288
3289   if (scalar_check (time, 0) == FAILURE)
3290     return FAILURE;
3291
3292   if (array_check (values, 1) == FAILURE)
3293     return FAILURE;
3294
3295   if (rank_check (values, 1, 1) == FAILURE)
3296     return FAILURE;
3297
3298   if (variable_check (values, 1) == FAILURE)
3299     return FAILURE;
3300
3301   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3302     return FAILURE;
3303
3304   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3305     return FAILURE;
3306
3307   return SUCCESS;
3308 }
3309
3310
3311 try
3312 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3313 {
3314   if (scalar_check (unit, 0) == FAILURE)
3315     return FAILURE;
3316
3317   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3318     return FAILURE;
3319
3320   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3321     return FAILURE;
3322
3323   return SUCCESS;
3324 }
3325
3326
3327 try
3328 gfc_check_isatty (gfc_expr *unit)
3329 {
3330   if (unit == NULL)
3331     return FAILURE;
3332
3333   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3334     return FAILURE;
3335
3336   if (scalar_check (unit, 0) == FAILURE)
3337     return FAILURE;
3338
3339   return SUCCESS;
3340 }
3341
3342
3343 try
3344 gfc_check_perror (gfc_expr *string)
3345 {
3346   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3347     return FAILURE;
3348
3349   return SUCCESS;
3350 }
3351
3352
3353 try
3354 gfc_check_umask (gfc_expr *mask)
3355 {
3356   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3357     return FAILURE;
3358
3359   if (scalar_check (mask, 0) == FAILURE)
3360     return FAILURE;
3361
3362   return SUCCESS;
3363 }
3364
3365
3366 try
3367 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3368 {
3369   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3370     return FAILURE;
3371
3372   if (scalar_check (mask, 0) == FAILURE)
3373     return FAILURE;
3374
3375   if (old == NULL)
3376     return SUCCESS;
3377
3378   if (scalar_check (old, 1) == FAILURE)
3379     return FAILURE;
3380
3381   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3382     return FAILURE;
3383
3384   return SUCCESS;
3385 }
3386
3387
3388 try
3389 gfc_check_unlink (gfc_expr *name)
3390 {
3391   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3392     return FAILURE;
3393
3394   return SUCCESS;
3395 }
3396
3397
3398 try
3399 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3400 {
3401   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3402     return FAILURE;
3403
3404   if (status == NULL)
3405     return SUCCESS;
3406
3407   if (scalar_check (status, 1) == FAILURE)
3408     return FAILURE;
3409
3410   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3411     return FAILURE;
3412
3413   return SUCCESS;
3414 }
3415
3416
3417 try
3418 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3419 {
3420   if (scalar_check (number, 0) == FAILURE)
3421     return FAILURE;
3422
3423   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3424     return FAILURE;
3425
3426   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3427     {
3428       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3429                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3430                  gfc_current_intrinsic, &handler->where);
3431       return FAILURE;
3432     }
3433
3434   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3435     return FAILURE;
3436
3437   return SUCCESS;
3438 }
3439
3440
3441 try
3442 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3443 {
3444   if (scalar_check (number, 0) == FAILURE)
3445     return FAILURE;
3446
3447   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3448     return FAILURE;
3449
3450   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3451     {
3452       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3453                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3454                  gfc_current_intrinsic, &handler->where);
3455       return FAILURE;
3456     }
3457
3458   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3459     return FAILURE;
3460
3461   if (status == NULL)
3462     return SUCCESS;
3463
3464   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3465     return FAILURE;
3466
3467   if (scalar_check (status, 2) == FAILURE)
3468     return FAILURE;
3469
3470   return SUCCESS;
3471 }
3472
3473
3474 try
3475 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3476 {
3477   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3478     return FAILURE;
3479
3480   if (scalar_check (status, 1) == FAILURE)
3481     return FAILURE;
3482
3483   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3484     return FAILURE;
3485
3486   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3487     return FAILURE;
3488
3489   return SUCCESS;
3490 }
3491
3492
3493 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3494 try
3495 gfc_check_and (gfc_expr *i, gfc_expr *j)
3496 {
3497   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3498     {
3499       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3500                  "or LOGICAL", gfc_current_intrinsic_arg[0],
3501                  gfc_current_intrinsic, &i->where);
3502       return FAILURE;
3503     }
3504
3505   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3506     {
3507       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3508                  "or LOGICAL", gfc_current_intrinsic_arg[1],
3509                  gfc_current_intrinsic, &j->where);
3510       return FAILURE;
3511     }
3512
3513   if (i->ts.type != j->ts.type)
3514     {
3515       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3516                  "have the same type", gfc_current_intrinsic_arg[0],
3517                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3518                  &j->where);
3519       return FAILURE;
3520     }
3521
3522   if (scalar_check (i, 0) == FAILURE)
3523     return FAILURE;
3524
3525   if (scalar_check (j, 1) == FAILURE)
3526     return FAILURE;
3527
3528   return SUCCESS;
3529 }