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