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