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