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