gcc/fortran/check.c

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