gcc/fortran/check.c

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