gcc/fortran/check.c

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