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_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
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 (offset, 1, BT_INTEGER) == FAILURE)
2473     return FAILURE;
2474
2475   if (scalar_check (offset, 1) == FAILURE)
2476     return FAILURE;
2477
2478   if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2479     return FAILURE;
2480
2481   if (scalar_check (whence, 2) == FAILURE)
2482     return FAILURE;
2483
2484   if (status == NULL)
2485     return SUCCESS;
2486
2487   if (type_check (status, 3, BT_INTEGER) == FAILURE)
2488     return FAILURE;
2489
2490   if (kind_value_check (status, 3, 4) == FAILURE)
2491     return FAILURE;
2492
2493   if (scalar_check (status, 3) == FAILURE)
2494     return FAILURE;
2495
2496   return SUCCESS;
2497 }
2498
2499
2500
2501 try
2502 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2503 {
2504   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2505     return FAILURE;
2506
2507   if (scalar_check (unit, 0) == FAILURE)
2508     return FAILURE;
2509
2510   if (type_check (array, 1, BT_INTEGER) == FAILURE
2511       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2512     return FAILURE;
2513
2514   if (array_check (array, 1) == FAILURE)
2515     return FAILURE;
2516
2517   return SUCCESS;
2518 }
2519
2520
2521 try
2522 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2523 {
2524   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2525     return FAILURE;
2526
2527   if (scalar_check (unit, 0) == FAILURE)
2528     return FAILURE;
2529
2530   if (type_check (array, 1, BT_INTEGER) == FAILURE
2531       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2532     return FAILURE;
2533
2534   if (array_check (array, 1) == FAILURE)
2535     return FAILURE;
2536
2537   if (status == NULL)
2538     return SUCCESS;
2539
2540   if (type_check (status, 2, BT_INTEGER) == FAILURE
2541       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2542     return FAILURE;
2543
2544   if (scalar_check (status, 2) == FAILURE)
2545     return FAILURE;
2546
2547   return SUCCESS;
2548 }
2549
2550
2551 try
2552 gfc_check_ftell (gfc_expr *unit)
2553 {
2554   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2555     return FAILURE;
2556
2557   if (scalar_check (unit, 0) == FAILURE)
2558     return FAILURE;
2559
2560   return SUCCESS;
2561 }
2562
2563
2564 try
2565 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2566 {
2567   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2568     return FAILURE;
2569
2570   if (scalar_check (unit, 0) == FAILURE)
2571     return FAILURE;
2572
2573   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2574     return FAILURE;
2575
2576   if (scalar_check (offset, 1) == FAILURE)
2577     return FAILURE;
2578
2579   return SUCCESS;
2580 }
2581
2582
2583 try
2584 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2585 {
2586   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2587     return FAILURE;
2588
2589   if (type_check (array, 1, BT_INTEGER) == FAILURE
2590       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2591     return FAILURE;
2592
2593   if (array_check (array, 1) == FAILURE)
2594     return FAILURE;
2595
2596   return SUCCESS;
2597 }
2598
2599
2600 try
2601 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2602 {
2603   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2604     return FAILURE;
2605
2606   if (type_check (array, 1, BT_INTEGER) == FAILURE
2607       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2608     return FAILURE;
2609
2610   if (array_check (array, 1) == FAILURE)
2611     return FAILURE;
2612
2613   if (status == NULL)
2614     return SUCCESS;
2615
2616   if (type_check (status, 2, BT_INTEGER) == FAILURE
2617       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2618     return FAILURE;
2619
2620   if (scalar_check (status, 2) == FAILURE)
2621     return FAILURE;
2622
2623   return SUCCESS;
2624 }
2625
2626
2627 try
2628 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2629                     gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2630 {
2631   if (size != NULL)
2632     {
2633       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2634         return FAILURE;
2635
2636       if (scalar_check (size, 2) == FAILURE)
2637         return FAILURE;
2638
2639       if (nonoptional_check (size, 2) == FAILURE)
2640         return FAILURE;
2641     }
2642
2643   return SUCCESS;
2644 }
2645
2646
2647 try
2648 gfc_check_transpose (gfc_expr *matrix)
2649 {
2650   if (rank_check (matrix, 0, 2) == FAILURE)
2651     return FAILURE;
2652
2653   if (gfc_init_expr)
2654     return non_init_transformational ();
2655
2656   return SUCCESS;
2657 }
2658
2659
2660 try
2661 gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
2662 {
2663   if (array_check (array, 0) == FAILURE)
2664     return FAILURE;
2665
2666   if (dim != NULL)
2667     {
2668       if (dim_check (dim, 1, 1) == FAILURE)
2669         return FAILURE;
2670
2671       if (dim_rank_check (dim, array, 0) == FAILURE)
2672         return FAILURE;
2673     }
2674
2675   return SUCCESS;
2676 }
2677
2678
2679 try
2680 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2681 {
2682   if (rank_check (vector, 0, 1) == FAILURE)
2683     return FAILURE;
2684
2685   if (array_check (mask, 1) == FAILURE)
2686     return FAILURE;
2687
2688   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2689     return FAILURE;
2690
2691   if (same_type_check (vector, 0, field, 2) == FAILURE)
2692     return FAILURE;
2693
2694   if (gfc_init_expr)
2695     return non_init_transformational ();
2696
2697   return SUCCESS;
2698 }
2699
2700
2701 try
2702 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2703 {
2704   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2705     return FAILURE;
2706
2707   if (same_type_check (x, 0, y, 1) == FAILURE)
2708     return FAILURE;
2709
2710   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2711     return FAILURE;
2712
2713   return SUCCESS;
2714 }
2715
2716
2717 try
2718 gfc_check_trim (gfc_expr *x)
2719 {
2720   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2721     return FAILURE;
2722
2723   if (scalar_check (x, 0) == FAILURE)
2724     return FAILURE;
2725
2726    return SUCCESS;
2727 }
2728
2729
2730 try
2731 gfc_check_ttynam (gfc_expr *unit)
2732 {
2733   if (scalar_check (unit, 0) == FAILURE)
2734     return FAILURE;
2735
2736   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2737     return FAILURE;
2738
2739   return SUCCESS;
2740 }
2741
2742
2743 /* Common check function for the half a dozen intrinsics that have a
2744    single real argument.  */
2745
2746 try
2747 gfc_check_x (gfc_expr *x)
2748 {
2749   if (type_check (x, 0, BT_REAL) == FAILURE)
2750     return FAILURE;
2751
2752   return SUCCESS;
2753 }
2754
2755
2756 /************* Check functions for intrinsic subroutines *************/
2757
2758 try
2759 gfc_check_cpu_time (gfc_expr *time)
2760 {
2761   if (scalar_check (time, 0) == FAILURE)
2762     return FAILURE;
2763
2764   if (type_check (time, 0, BT_REAL) == FAILURE)
2765     return FAILURE;
2766
2767   if (variable_check (time, 0) == FAILURE)
2768     return FAILURE;
2769
2770   return SUCCESS;
2771 }
2772
2773
2774 try
2775 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2776                          gfc_expr *zone, gfc_expr *values)
2777 {
2778   if (date != NULL)
2779     {
2780       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2781         return FAILURE;
2782       if (scalar_check (date, 0) == FAILURE)
2783         return FAILURE;
2784       if (variable_check (date, 0) == FAILURE)
2785         return FAILURE;
2786     }
2787
2788   if (time != NULL)
2789     {
2790       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2791         return FAILURE;
2792       if (scalar_check (time, 1) == FAILURE)
2793         return FAILURE;
2794       if (variable_check (time, 1) == FAILURE)
2795         return FAILURE;
2796     }
2797
2798   if (zone != NULL)
2799     {
2800       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2801         return FAILURE;
2802       if (scalar_check (zone, 2) == FAILURE)
2803         return FAILURE;
2804       if (variable_check (zone, 2) == FAILURE)
2805         return FAILURE;
2806     }
2807
2808   if (values != NULL)
2809     {
2810       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2811         return FAILURE;
2812       if (array_check (values, 3) == FAILURE)
2813         return FAILURE;
2814       if (rank_check (values, 3, 1) == FAILURE)
2815         return FAILURE;
2816       if (variable_check (values, 3) == FAILURE)
2817         return FAILURE;
2818     }
2819
2820   return SUCCESS;
2821 }
2822
2823
2824 try
2825 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2826                   gfc_expr *to, gfc_expr *topos)
2827 {
2828   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2829     return FAILURE;
2830
2831   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2832     return FAILURE;
2833
2834   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2835     return FAILURE;
2836
2837   if (same_type_check (from, 0, to, 3) == FAILURE)
2838     return FAILURE;
2839
2840   if (variable_check (to, 3) == FAILURE)
2841     return FAILURE;
2842
2843   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2844     return FAILURE;
2845
2846   return SUCCESS;
2847 }
2848
2849
2850 try
2851 gfc_check_random_number (gfc_expr *harvest)
2852 {
2853   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2854     return FAILURE;
2855
2856   if (variable_check (harvest, 0) == FAILURE)
2857     return FAILURE;
2858
2859   return SUCCESS;
2860 }
2861
2862
2863 try
2864 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2865 {
2866   if (size != NULL)
2867     {
2868       if (scalar_check (size, 0) == FAILURE)
2869         return FAILURE;
2870
2871       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2872         return FAILURE;
2873
2874       if (variable_check (size, 0) == FAILURE)
2875         return FAILURE;
2876
2877       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
2878         return FAILURE;
2879     }
2880
2881   if (put != NULL)
2882     {
2883
2884       if (size != NULL)
2885         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2886                     &put->where);
2887
2888       if (array_check (put, 1) == FAILURE)
2889         return FAILURE;
2890
2891       if (rank_check (put, 1, 1) == FAILURE)
2892         return FAILURE;
2893
2894       if (type_check (put, 1, BT_INTEGER) == FAILURE)
2895         return FAILURE;
2896
2897       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
2898         return FAILURE;
2899     }
2900
2901   if (get != NULL)
2902     {
2903
2904       if (size != NULL || put != NULL)
2905         gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
2906                    &get->where);
2907
2908       if (array_check (get, 2) == FAILURE)
2909         return FAILURE;
2910
2911       if (rank_check (get, 2, 1) == FAILURE)
2912         return FAILURE;
2913
2914       if (type_check (get, 2, BT_INTEGER) == FAILURE)
2915         return FAILURE;
2916
2917       if (variable_check (get, 2) == FAILURE)
2918         return FAILURE;
2919
2920       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
2921         return FAILURE;
2922     }
2923
2924   return SUCCESS;
2925 }
2926
2927
2928 try
2929 gfc_check_second_sub (gfc_expr *time)
2930 {
2931   if (scalar_check (time, 0) == FAILURE)
2932     return FAILURE;
2933
2934   if (type_check (time, 0, BT_REAL) == FAILURE)
2935     return FAILURE;
2936
2937   if (kind_value_check(time, 0, 4) == FAILURE)
2938     return FAILURE;
2939
2940   return SUCCESS;
2941 }
2942
2943
2944 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
2945    count, count_rate, and count_max are all optional arguments */
2946
2947 try
2948 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
2949                         gfc_expr *count_max)
2950 {
2951   if (count != NULL)
2952     {
2953       if (scalar_check (count, 0) == FAILURE)
2954         return FAILURE;
2955
2956       if (type_check (count, 0, BT_INTEGER) == FAILURE)
2957         return FAILURE;
2958
2959       if (variable_check (count, 0) == FAILURE)
2960         return FAILURE;
2961     }
2962
2963   if (count_rate != NULL)
2964     {
2965       if (scalar_check (count_rate, 1) == FAILURE)
2966         return FAILURE;
2967
2968       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
2969         return FAILURE;
2970
2971       if (variable_check (count_rate, 1) == FAILURE)
2972         return FAILURE;
2973
2974       if (count != NULL
2975           && same_type_check (count, 0, count_rate, 1) == FAILURE)
2976         return FAILURE;
2977
2978     }
2979
2980   if (count_max != NULL)
2981     {
2982       if (scalar_check (count_max, 2) == FAILURE)
2983         return FAILURE;
2984
2985       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
2986         return FAILURE;
2987
2988       if (variable_check (count_max, 2) == FAILURE)
2989         return FAILURE;
2990
2991       if (count != NULL
2992           && same_type_check (count, 0, count_max, 2) == FAILURE)
2993         return FAILURE;
2994
2995       if (count_rate != NULL
2996           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
2997         return FAILURE;
2998     }
2999
3000   return SUCCESS;
3001 }
3002
3003
3004 try
3005 gfc_check_irand (gfc_expr *x)
3006 {
3007   if (x == NULL)
3008     return SUCCESS;
3009
3010   if (scalar_check (x, 0) == FAILURE)
3011     return FAILURE;
3012
3013   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3014     return FAILURE;
3015
3016   if (kind_value_check(x, 0, 4) == FAILURE)
3017     return FAILURE;
3018
3019   return SUCCESS;
3020 }
3021
3022
3023 try
3024 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3025 {
3026   if (scalar_check (seconds, 0) == FAILURE)
3027     return FAILURE;
3028
3029   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3030     return FAILURE;
3031
3032   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3033     {
3034       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3035                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3036                  gfc_current_intrinsic, &handler->where);
3037       return FAILURE;
3038     }
3039
3040   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3041     return FAILURE;
3042
3043   if (status == NULL)
3044     return SUCCESS;
3045
3046   if (scalar_check (status, 2) == FAILURE)
3047     return FAILURE;
3048
3049   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3050     return FAILURE;
3051
3052   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3053     return FAILURE;
3054
3055   return SUCCESS;
3056 }
3057
3058
3059 try
3060 gfc_check_rand (gfc_expr *x)
3061 {
3062   if (x == NULL)
3063     return SUCCESS;
3064
3065   if (scalar_check (x, 0) == FAILURE)
3066     return FAILURE;
3067
3068   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3069     return FAILURE;
3070
3071   if (kind_value_check(x, 0, 4) == FAILURE)
3072     return FAILURE;
3073
3074   return SUCCESS;
3075 }
3076
3077
3078 try
3079 gfc_check_srand (gfc_expr *x)
3080 {
3081   if (scalar_check (x, 0) == FAILURE)
3082     return FAILURE;
3083
3084   if (type_check (x, 0, BT_INTEGER) == 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_ctime_sub (gfc_expr *time, gfc_expr *result)
3096 {
3097   if (scalar_check (time, 0) == FAILURE)
3098     return FAILURE;
3099
3100   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3101     return FAILURE;
3102
3103   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3104     return FAILURE;
3105
3106   return SUCCESS;
3107 }
3108
3109
3110 try
3111 gfc_check_etime (gfc_expr *x)
3112 {
3113   if (array_check (x, 0) == FAILURE)
3114     return FAILURE;
3115
3116   if (rank_check (x, 0, 1) == FAILURE)
3117     return FAILURE;
3118
3119   if (variable_check (x, 0) == FAILURE)
3120     return FAILURE;
3121
3122   if (type_check (x, 0, BT_REAL) == FAILURE)
3123     return FAILURE;
3124
3125   if (kind_value_check(x, 0, 4) == FAILURE)
3126     return FAILURE;
3127
3128   return SUCCESS;
3129 }
3130
3131
3132 try
3133 gfc_check_etime_sub (gfc_expr *values, gfc_expr *time)
3134 {
3135   if (array_check (values, 0) == FAILURE)
3136     return FAILURE;
3137
3138   if (rank_check (values, 0, 1) == FAILURE)
3139     return FAILURE;
3140
3141   if (variable_check (values, 0) == FAILURE)
3142     return FAILURE;
3143
3144   if (type_check (values, 0, BT_REAL) == FAILURE)
3145     return FAILURE;
3146
3147   if (kind_value_check(values, 0, 4) == FAILURE)
3148     return FAILURE;
3149
3150   if (scalar_check (time, 1) == FAILURE)
3151     return FAILURE;
3152
3153   if (type_check (time, 1, BT_REAL) == FAILURE)
3154     return FAILURE;
3155
3156   if (kind_value_check(time, 1, 4) == FAILURE)
3157     return FAILURE;
3158
3159   return SUCCESS;
3160 }
3161
3162
3163 try
3164 gfc_check_fdate_sub (gfc_expr *date)
3165 {
3166   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3167     return FAILURE;
3168
3169   return SUCCESS;
3170 }
3171
3172
3173 try
3174 gfc_check_gerror (gfc_expr *msg)
3175 {
3176   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3177     return FAILURE;
3178
3179   return SUCCESS;
3180 }
3181
3182
3183 try
3184 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3185 {
3186   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3187     return FAILURE;
3188
3189   if (status == NULL)
3190     return SUCCESS;
3191
3192   if (scalar_check (status, 1) == FAILURE)
3193     return FAILURE;
3194
3195   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3196     return FAILURE;
3197
3198   return SUCCESS;
3199 }
3200
3201
3202 try
3203 gfc_check_getlog (gfc_expr *msg)
3204 {
3205   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3206     return FAILURE;
3207
3208   return SUCCESS;
3209 }
3210
3211
3212 try
3213 gfc_check_exit (gfc_expr *status)
3214 {
3215   if (status == NULL)
3216     return SUCCESS;
3217
3218   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3219     return FAILURE;
3220
3221   if (scalar_check (status, 0) == FAILURE)
3222     return FAILURE;
3223
3224   return SUCCESS;
3225 }
3226
3227
3228 try
3229 gfc_check_flush (gfc_expr *unit)
3230 {
3231   if (unit == NULL)
3232     return SUCCESS;
3233
3234   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3235     return FAILURE;
3236
3237   if (scalar_check (unit, 0) == FAILURE)
3238     return FAILURE;
3239
3240   return SUCCESS;
3241 }
3242
3243
3244 try
3245 gfc_check_free (gfc_expr *i)
3246 {
3247   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3248     return FAILURE;
3249
3250   if (scalar_check (i, 0) == FAILURE)
3251     return FAILURE;
3252
3253   return SUCCESS;
3254 }
3255
3256
3257 try
3258 gfc_check_hostnm (gfc_expr *name)
3259 {
3260   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3261     return FAILURE;
3262
3263   return SUCCESS;
3264 }
3265
3266
3267 try
3268 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3269 {
3270   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3271     return FAILURE;
3272
3273   if (status == NULL)
3274     return SUCCESS;
3275
3276   if (scalar_check (status, 1) == FAILURE)
3277     return FAILURE;
3278
3279   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3280     return FAILURE;
3281
3282   return SUCCESS;
3283 }
3284
3285
3286 try
3287 gfc_check_itime_idate (gfc_expr *values)
3288 {
3289   if (array_check (values, 0) == FAILURE)
3290     return FAILURE;
3291
3292   if (rank_check (values, 0, 1) == FAILURE)
3293     return FAILURE;
3294
3295   if (variable_check (values, 0) == FAILURE)
3296     return FAILURE;
3297
3298   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3299     return FAILURE;
3300
3301   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3302     return FAILURE;
3303
3304   return SUCCESS;
3305 }
3306
3307
3308 try
3309 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3310 {
3311   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3312     return FAILURE;
3313
3314   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3315     return FAILURE;
3316
3317   if (scalar_check (time, 0) == FAILURE)
3318     return FAILURE;
3319
3320   if (array_check (values, 1) == FAILURE)
3321     return FAILURE;
3322
3323   if (rank_check (values, 1, 1) == FAILURE)
3324     return FAILURE;
3325
3326   if (variable_check (values, 1) == FAILURE)
3327     return FAILURE;
3328
3329   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3330     return FAILURE;
3331
3332   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3333     return FAILURE;
3334
3335   return SUCCESS;
3336 }
3337
3338
3339 try
3340 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3341 {
3342   if (scalar_check (unit, 0) == FAILURE)
3343     return FAILURE;
3344
3345   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3346     return FAILURE;
3347
3348   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3349     return FAILURE;
3350
3351   return SUCCESS;
3352 }
3353
3354
3355 try
3356 gfc_check_isatty (gfc_expr *unit)
3357 {
3358   if (unit == NULL)
3359     return FAILURE;
3360
3361   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3362     return FAILURE;
3363
3364   if (scalar_check (unit, 0) == FAILURE)
3365     return FAILURE;
3366
3367   return SUCCESS;
3368 }
3369
3370
3371 try
3372 gfc_check_perror (gfc_expr *string)
3373 {
3374   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3375     return FAILURE;
3376
3377   return SUCCESS;
3378 }
3379
3380
3381 try
3382 gfc_check_umask (gfc_expr *mask)
3383 {
3384   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3385     return FAILURE;
3386
3387   if (scalar_check (mask, 0) == FAILURE)
3388     return FAILURE;
3389
3390   return SUCCESS;
3391 }
3392
3393
3394 try
3395 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3396 {
3397   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3398     return FAILURE;
3399
3400   if (scalar_check (mask, 0) == FAILURE)
3401     return FAILURE;
3402
3403   if (old == NULL)
3404     return SUCCESS;
3405
3406   if (scalar_check (old, 1) == FAILURE)
3407     return FAILURE;
3408
3409   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3410     return FAILURE;
3411
3412   return SUCCESS;
3413 }
3414
3415
3416 try
3417 gfc_check_unlink (gfc_expr *name)
3418 {
3419   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3420     return FAILURE;
3421
3422   return SUCCESS;
3423 }
3424
3425
3426 try
3427 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3428 {
3429   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3430     return FAILURE;
3431
3432   if (status == NULL)
3433     return SUCCESS;
3434
3435   if (scalar_check (status, 1) == FAILURE)
3436     return FAILURE;
3437
3438   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3439     return FAILURE;
3440
3441   return SUCCESS;
3442 }
3443
3444
3445 try
3446 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3447 {
3448   if (scalar_check (number, 0) == FAILURE)
3449     return FAILURE;
3450
3451   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3452     return FAILURE;
3453
3454   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3455     {
3456       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3457                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3458                  gfc_current_intrinsic, &handler->where);
3459       return FAILURE;
3460     }
3461
3462   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3463     return FAILURE;
3464
3465   return SUCCESS;
3466 }
3467
3468
3469 try
3470 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3471 {
3472   if (scalar_check (number, 0) == FAILURE)
3473     return FAILURE;
3474
3475   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3476     return FAILURE;
3477
3478   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3479     {
3480       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3481                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3482                  gfc_current_intrinsic, &handler->where);
3483       return FAILURE;
3484     }
3485
3486   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3487     return FAILURE;
3488
3489   if (status == NULL)
3490     return SUCCESS;
3491
3492   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3493     return FAILURE;
3494
3495   if (scalar_check (status, 2) == FAILURE)
3496     return FAILURE;
3497
3498   return SUCCESS;
3499 }
3500
3501
3502 try
3503 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3504 {
3505   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3506     return FAILURE;
3507
3508   if (scalar_check (status, 1) == FAILURE)
3509     return FAILURE;
3510
3511   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3512     return FAILURE;
3513
3514   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3515     return FAILURE;
3516
3517   return SUCCESS;
3518 }
3519
3520
3521 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3522 try
3523 gfc_check_and (gfc_expr *i, gfc_expr *j)
3524 {
3525   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3526     {
3527       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3528                  "or LOGICAL", gfc_current_intrinsic_arg[0],
3529                  gfc_current_intrinsic, &i->where);
3530       return FAILURE;
3531     }
3532
3533   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3534     {
3535       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3536                  "or LOGICAL", gfc_current_intrinsic_arg[1],
3537                  gfc_current_intrinsic, &j->where);
3538       return FAILURE;
3539     }
3540
3541   if (i->ts.type != j->ts.type)
3542     {
3543       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3544                  "have the same type", gfc_current_intrinsic_arg[0],
3545                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3546                  &j->where);
3547       return FAILURE;
3548     }
3549
3550   if (scalar_check (i, 0) == FAILURE)
3551     return FAILURE;
3552
3553   if (scalar_check (j, 1) == FAILURE)
3554     return FAILURE;
3555
3556   return SUCCESS;
3557 }