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