gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22
  23 /* These functions check to see if an argument list is compatible with
  24    a particular intrinsic function or subroutine.  Presence of
  25    required arguments has already been established, the argument list
  26    has been sorted into the right order and has NULL arguments in the
  27    correct places for missing optional arguments.  */
  28
  29 #include "config.h"
  30 #include "system.h"
  31 #include "flags.h"
  32 #include "gfortran.h"
  33 #include "intrinsic.h"
  34
  35
  36 /* Make sure an expression is a scalar.  */
  37
  38 static 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       if (same_type_check (array, 0, vector, 2) == FAILURE)
2153         return FAILURE;
2154
2155       if (rank_check (vector, 2, 1) == FAILURE)
2156         return FAILURE;
2157
2158       /* TODO: More constraints here.  */
2159     }
2160
2161   return SUCCESS;
2162 }
2163
2164
2165 gfc_try
2166 gfc_check_precision (gfc_expr *x)
2167 {
2168   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
2169     {
2170       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2171                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
2172                  gfc_current_intrinsic, &x->where);
2173       return FAILURE;
2174     }
2175
2176   return SUCCESS;
2177 }
2178
2179
2180 gfc_try
2181 gfc_check_present (gfc_expr *a)
2182 {
2183   gfc_symbol *sym;
2184
2185   if (variable_check (a, 0) == FAILURE)
2186     return FAILURE;
2187
2188   sym = a->symtree->n.sym;
2189   if (!sym->attr.dummy)
2190     {
2191       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2192                  "dummy variable", gfc_current_intrinsic_arg[0],
2193                  gfc_current_intrinsic, &a->where);
2194       return FAILURE;
2195     }
2196
2197   if (!sym->attr.optional)
2198     {
2199       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2200                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2201                  gfc_current_intrinsic, &a->where);
2202       return FAILURE;
2203     }
2204
2205   /* 13.14.82  PRESENT(A)
2206      ......
2207      Argument.  A shall be the name of an optional dummy argument that is
2208      accessible in the subprogram in which the PRESENT function reference
2209      appears...  */
2210
2211   if (a->ref != NULL
2212       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2213            && a->ref->u.ar.type == AR_FULL))
2214     {
2215       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2216                  "subobject of '%s'", gfc_current_intrinsic_arg[0],
2217                  gfc_current_intrinsic, &a->where, sym->name);
2218       return FAILURE;
2219     }
2220
2221   return SUCCESS;
2222 }
2223
2224
2225 gfc_try
2226 gfc_check_radix (gfc_expr *x)
2227 {
2228   if (int_or_real_check (x, 0) == FAILURE)
2229     return FAILURE;
2230
2231   return SUCCESS;
2232 }
2233
2234
2235 gfc_try
2236 gfc_check_range (gfc_expr *x)
2237 {
2238   if (numeric_check (x, 0) == FAILURE)
2239     return FAILURE;
2240
2241   return SUCCESS;
2242 }
2243
2244
2245 /* real, float, sngl.  */
2246 gfc_try
2247 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2248 {
2249   if (numeric_check (a, 0) == FAILURE)
2250     return FAILURE;
2251
2252   if (kind_check (kind, 1, BT_REAL) == FAILURE)
2253     return FAILURE;
2254
2255   return SUCCESS;
2256 }
2257
2258
2259 gfc_try
2260 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2261 {
2262   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2263     return FAILURE;
2264   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2265     return FAILURE;
2266
2267   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2268     return FAILURE;
2269   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2270     return FAILURE;
2271
2272   return SUCCESS;
2273 }
2274
2275
2276 gfc_try
2277 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2278 {
2279   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2280     return FAILURE;
2281   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2282     return FAILURE;
2283
2284   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2285     return FAILURE;
2286   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2287     return FAILURE;
2288
2289   if (status == NULL)
2290     return SUCCESS;
2291
2292   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2293     return FAILURE;
2294
2295   if (scalar_check (status, 2) == FAILURE)
2296     return FAILURE;
2297
2298   return SUCCESS;
2299 }
2300
2301
2302 gfc_try
2303 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2304 {
2305   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2306     return FAILURE;
2307
2308   if (scalar_check (x, 0) == FAILURE)
2309     return FAILURE;
2310
2311   if (type_check (y, 0, BT_INTEGER) == FAILURE)
2312     return FAILURE;
2313
2314   if (scalar_check (y, 1) == FAILURE)
2315     return FAILURE;
2316
2317   return SUCCESS;
2318 }
2319
2320
2321 gfc_try
2322 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2323                    gfc_expr *pad, gfc_expr *order)
2324 {
2325   mpz_t size;
2326   mpz_t nelems;
2327   int m;
2328
2329   if (array_check (source, 0) == FAILURE)
2330     return FAILURE;
2331
2332   if (rank_check (shape, 1, 1) == FAILURE)
2333     return FAILURE;
2334
2335   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2336     return FAILURE;
2337
2338   if (gfc_array_size (shape, &size) != SUCCESS)
2339     {
2340       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2341                  "array of constant size", &shape->where);
2342       return FAILURE;
2343     }
2344
2345   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2346   mpz_clear (size);
2347
2348   if (m > 0)
2349     {
2350       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2351                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2352       return FAILURE;
2353     }
2354
2355   if (pad != NULL)
2356     {
2357       if (same_type_check (source, 0, pad, 2) == FAILURE)
2358         return FAILURE;
2359       if (array_check (pad, 2) == FAILURE)
2360         return FAILURE;
2361     }
2362
2363   if (order != NULL && array_check (order, 3) == FAILURE)
2364     return FAILURE;
2365
2366   if (pad == NULL && shape->expr_type == EXPR_ARRAY
2367       && gfc_is_constant_expr (shape)
2368       && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2369            && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2370     {
2371       /* Check the match in size between source and destination.  */
2372       if (gfc_array_size (source, &nelems) == SUCCESS)
2373         {
2374           gfc_constructor *c;
2375           bool test;
2376
2377           c = shape->value.constructor;
2378           mpz_init_set_ui (size, 1);
2379           for (; c; c = c->next)
2380             mpz_mul (size, size, c->expr->value.integer);
2381
2382           test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2383           mpz_clear (nelems);
2384           mpz_clear (size);
2385
2386           if (test)
2387             {
2388               gfc_error ("Without padding, there are not enough elements "
2389                          "in the intrinsic RESHAPE source at %L to match "
2390                          "the shape", &source->where);
2391               return FAILURE;
2392             }
2393         }
2394     }
2395
2396   return SUCCESS;
2397 }
2398
2399
2400 gfc_try
2401 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2402 {
2403   if (type_check (x, 0, BT_REAL) == FAILURE)
2404     return FAILURE;
2405
2406   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2407     return FAILURE;
2408
2409   return SUCCESS;
2410 }
2411
2412
2413 gfc_try
2414 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2415 {
2416   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2417     return FAILURE;
2418
2419   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2420     return FAILURE;
2421
2422   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2423     return FAILURE;
2424
2425   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2426     return FAILURE;
2427   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2428                               "with KIND argument at %L",
2429                               gfc_current_intrinsic, &kind->where) == FAILURE)
2430     return FAILURE;
2431
2432   if (same_type_check (x, 0, y, 1) == FAILURE)
2433     return FAILURE;
2434
2435   return SUCCESS;
2436 }
2437
2438
2439 gfc_try
2440 gfc_check_secnds (gfc_expr *r)
2441 {
2442   if (type_check (r, 0, BT_REAL) == FAILURE)
2443     return FAILURE;
2444
2445   if (kind_value_check (r, 0, 4) == FAILURE)
2446     return FAILURE;
2447
2448   if (scalar_check (r, 0) == FAILURE)
2449     return FAILURE;
2450
2451   return SUCCESS;
2452 }
2453
2454
2455 gfc_try
2456 gfc_check_selected_char_kind (gfc_expr *name)
2457 {
2458   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2459     return FAILURE;
2460
2461   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
2462     return FAILURE;
2463
2464   if (scalar_check (name, 0) == FAILURE)
2465     return FAILURE;
2466
2467   return SUCCESS;
2468 }
2469
2470
2471 gfc_try
2472 gfc_check_selected_int_kind (gfc_expr *r)
2473 {
2474   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2475     return FAILURE;
2476
2477   if (scalar_check (r, 0) == FAILURE)
2478     return FAILURE;
2479
2480   return SUCCESS;
2481 }
2482
2483
2484 gfc_try
2485 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2486 {
2487   if (p == NULL && r == NULL)
2488     {
2489       gfc_error ("Missing arguments to %s intrinsic at %L",
2490                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2491
2492       return FAILURE;
2493     }
2494
2495   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2496     return FAILURE;
2497
2498   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2499     return FAILURE;
2500
2501   return SUCCESS;
2502 }
2503
2504
2505 gfc_try
2506 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2507 {
2508   if (type_check (x, 0, BT_REAL) == FAILURE)
2509     return FAILURE;
2510
2511   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2512     return FAILURE;
2513
2514   return SUCCESS;
2515 }
2516
2517
2518 gfc_try
2519 gfc_check_shape (gfc_expr *source)
2520 {
2521   gfc_array_ref *ar;
2522
2523   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2524     return SUCCESS;
2525
2526   ar = gfc_find_array_ref (source);
2527
2528   if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
2529     {
2530       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2531                  "an assumed size array", &source->where);
2532       return FAILURE;
2533     }
2534
2535   return SUCCESS;
2536 }
2537
2538
2539 gfc_try
2540 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2541 {
2542   if (int_or_real_check (a, 0) == FAILURE)
2543     return FAILURE;
2544
2545   if (same_type_check (a, 0, b, 1) == FAILURE)
2546     return FAILURE;
2547
2548   return SUCCESS;
2549 }
2550
2551
2552 gfc_try
2553 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2554 {
2555   if (array_check (array, 0) == FAILURE)
2556     return FAILURE;
2557
2558   if (dim != NULL)
2559     {
2560       if (dim_check (dim, 1, true) == FAILURE)
2561         return FAILURE;
2562
2563       if (dim_rank_check (dim, array, 0) == FAILURE)
2564         return FAILURE;
2565     }
2566
2567   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2568     return FAILURE;
2569   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2570                               "with KIND argument at %L",
2571                               gfc_current_intrinsic, &kind->where) == FAILURE)
2572     return FAILURE;
2573
2574
2575   return SUCCESS;
2576 }
2577
2578
2579 gfc_try
2580 gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
2581 {
2582   return SUCCESS;
2583 }
2584
2585
2586 gfc_try
2587 gfc_check_sleep_sub (gfc_expr *seconds)
2588 {
2589   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2590     return FAILURE;
2591
2592   if (scalar_check (seconds, 0) == FAILURE)
2593     return FAILURE;
2594
2595   return SUCCESS;
2596 }
2597
2598
2599 gfc_try
2600 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2601 {
2602   if (source->rank >= GFC_MAX_DIMENSIONS)
2603     {
2604       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2605                  "than rank %d", gfc_current_intrinsic_arg[0],
2606                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2607
2608       return FAILURE;
2609     }
2610
2611   if (dim == NULL)
2612     return FAILURE;
2613
2614   if (dim_check (dim, 1, false) == FAILURE)
2615     return FAILURE;
2616
2617   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2618     return FAILURE;
2619
2620   if (scalar_check (ncopies, 2) == FAILURE)
2621     return FAILURE;
2622
2623   return SUCCESS;
2624 }
2625
2626
2627 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2628    functions).  */
2629
2630 gfc_try
2631 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2632 {
2633   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2634     return FAILURE;
2635
2636   if (scalar_check (unit, 0) == FAILURE)
2637     return FAILURE;
2638
2639   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2640     return FAILURE;
2641   if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
2642     return FAILURE;
2643
2644   if (status == NULL)
2645     return SUCCESS;
2646
2647   if (type_check (status, 2, BT_INTEGER) == FAILURE
2648       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2649       || scalar_check (status, 2) == FAILURE)
2650     return FAILURE;
2651
2652   return SUCCESS;
2653 }
2654
2655
2656 gfc_try
2657 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2658 {
2659   return gfc_check_fgetputc_sub (unit, c, NULL);
2660 }
2661
2662
2663 gfc_try
2664 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2665 {
2666   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2667     return FAILURE;
2668   if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
2669     return FAILURE;
2670
2671   if (status == NULL)
2672     return SUCCESS;
2673
2674   if (type_check (status, 1, BT_INTEGER) == FAILURE
2675       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2676       || scalar_check (status, 1) == FAILURE)
2677     return FAILURE;
2678
2679   return SUCCESS;
2680 }
2681
2682
2683 gfc_try
2684 gfc_check_fgetput (gfc_expr *c)
2685 {
2686   return gfc_check_fgetput_sub (c, NULL);
2687 }
2688
2689
2690 gfc_try
2691 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2692 {
2693   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2694     return FAILURE;
2695
2696   if (scalar_check (unit, 0) == FAILURE)
2697     return FAILURE;
2698
2699   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2700     return FAILURE;
2701
2702   if (scalar_check (offset, 1) == FAILURE)
2703     return FAILURE;
2704
2705   if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2706     return FAILURE;
2707
2708   if (scalar_check (whence, 2) == FAILURE)
2709     return FAILURE;
2710
2711   if (status == NULL)
2712     return SUCCESS;
2713
2714   if (type_check (status, 3, BT_INTEGER) == FAILURE)
2715     return FAILURE;
2716
2717   if (kind_value_check (status, 3, 4) == FAILURE)
2718     return FAILURE;
2719
2720   if (scalar_check (status, 3) == FAILURE)
2721     return FAILURE;
2722
2723   return SUCCESS;
2724 }
2725
2726
2727
2728 gfc_try
2729 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2730 {
2731   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2732     return FAILURE;
2733
2734   if (scalar_check (unit, 0) == FAILURE)
2735     return FAILURE;
2736
2737   if (type_check (array, 1, BT_INTEGER) == FAILURE
2738       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2739     return FAILURE;
2740
2741   if (array_check (array, 1) == FAILURE)
2742     return FAILURE;
2743
2744   return SUCCESS;
2745 }
2746
2747
2748 gfc_try
2749 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2750 {
2751   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2752     return FAILURE;
2753
2754   if (scalar_check (unit, 0) == FAILURE)
2755     return FAILURE;
2756
2757   if (type_check (array, 1, BT_INTEGER) == FAILURE
2758       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2759     return FAILURE;
2760
2761   if (array_check (array, 1) == FAILURE)
2762     return FAILURE;
2763
2764   if (status == NULL)
2765     return SUCCESS;
2766
2767   if (type_check (status, 2, BT_INTEGER) == FAILURE
2768       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2769     return FAILURE;
2770
2771   if (scalar_check (status, 2) == FAILURE)
2772     return FAILURE;
2773
2774   return SUCCESS;
2775 }
2776
2777
2778 gfc_try
2779 gfc_check_ftell (gfc_expr *unit)
2780 {
2781   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2782     return FAILURE;
2783
2784   if (scalar_check (unit, 0) == FAILURE)
2785     return FAILURE;
2786
2787   return SUCCESS;
2788 }
2789
2790
2791 gfc_try
2792 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2793 {
2794   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2795     return FAILURE;
2796
2797   if (scalar_check (unit, 0) == FAILURE)
2798     return FAILURE;
2799
2800   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2801     return FAILURE;
2802
2803   if (scalar_check (offset, 1) == FAILURE)
2804     return FAILURE;
2805
2806   return SUCCESS;
2807 }
2808
2809
2810 gfc_try
2811 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2812 {
2813   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2814     return FAILURE;
2815   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
2816     return FAILURE;
2817
2818   if (type_check (array, 1, BT_INTEGER) == FAILURE
2819       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2820     return FAILURE;
2821
2822   if (array_check (array, 1) == FAILURE)
2823     return FAILURE;
2824
2825   return SUCCESS;
2826 }
2827
2828
2829 gfc_try
2830 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2831 {
2832   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2833     return FAILURE;
2834   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
2835     return FAILURE;
2836
2837   if (type_check (array, 1, BT_INTEGER) == FAILURE
2838       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2839     return FAILURE;
2840
2841   if (array_check (array, 1) == FAILURE)
2842     return FAILURE;
2843
2844   if (status == NULL)
2845     return SUCCESS;
2846
2847   if (type_check (status, 2, BT_INTEGER) == FAILURE
2848       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2849     return FAILURE;
2850
2851   if (scalar_check (status, 2) == FAILURE)
2852     return FAILURE;
2853
2854   return SUCCESS;
2855 }
2856
2857
2858 gfc_try
2859 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2860                     gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2861 {
2862   if (mold->ts.type == BT_HOLLERITH)
2863     {
2864       gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
2865                  &mold->where, gfc_basic_typename (BT_HOLLERITH));
2866       return FAILURE;
2867     }
2868
2869   if (size != NULL)
2870     {
2871       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2872         return FAILURE;
2873
2874       if (scalar_check (size, 2) == FAILURE)
2875         return FAILURE;
2876
2877       if (nonoptional_check (size, 2) == FAILURE)
2878         return FAILURE;
2879     }
2880
2881   return SUCCESS;
2882 }
2883
2884
2885 gfc_try
2886 gfc_check_transpose (gfc_expr *matrix)
2887 {
2888   if (rank_check (matrix, 0, 2) == FAILURE)
2889     return FAILURE;
2890
2891   return SUCCESS;
2892 }
2893
2894
2895 gfc_try
2896 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2897 {
2898   if (array_check (array, 0) == FAILURE)
2899     return FAILURE;
2900
2901   if (dim != NULL)
2902     {
2903       if (dim_check (dim, 1, false) == FAILURE)
2904         return FAILURE;
2905
2906       if (dim_rank_check (dim, array, 0) == FAILURE)
2907         return FAILURE;
2908     }
2909
2910   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2911     return FAILURE;
2912   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2913                               "with KIND argument at %L",
2914                               gfc_current_intrinsic, &kind->where) == FAILURE)
2915     return FAILURE;
2916
2917   return SUCCESS;
2918 }
2919
2920
2921 gfc_try
2922 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2923 {
2924   if (rank_check (vector, 0, 1) == FAILURE)
2925     return FAILURE;
2926
2927   if (array_check (mask, 1) == FAILURE)
2928     return FAILURE;
2929
2930   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2931     return FAILURE;
2932
2933   if (same_type_check (vector, 0, field, 2) == FAILURE)
2934     return FAILURE;
2935
2936   if (mask->rank != field->rank && field->rank != 0)
2937     {
2938       gfc_error ("FIELD argument at %L of UNPACK must have the same rank as "
2939                  "MASK or be a scalar", &field->where);
2940       return FAILURE;
2941     }
2942
2943   if (mask->rank == field->rank)
2944     {
2945       int i;
2946       for (i = 0; i < field->rank; i++)
2947         if (! identical_dimen_shape (mask, i, field, i))
2948         {
2949           gfc_error ("Different shape in dimension %d for MASK and FIELD "
2950                      "arguments of UNPACK at %L", mask->rank, &field->where);
2951           return FAILURE;
2952         }
2953     }
2954
2955   return SUCCESS;
2956 }
2957
2958
2959 gfc_try
2960 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2961 {
2962   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2963     return FAILURE;
2964
2965   if (same_type_check (x, 0, y, 1) == FAILURE)
2966     return FAILURE;
2967
2968   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2969     return FAILURE;
2970
2971   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2972     return FAILURE;
2973   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2974                               "with KIND argument at %L",
2975                               gfc_current_intrinsic, &kind->where) == FAILURE)
2976     return FAILURE;
2977
2978   return SUCCESS;
2979 }
2980
2981
2982 gfc_try
2983 gfc_check_trim (gfc_expr *x)
2984 {
2985   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2986     return FAILURE;
2987
2988   if (scalar_check (x, 0) == FAILURE)
2989     return FAILURE;
2990
2991    return SUCCESS;
2992 }
2993
2994
2995 gfc_try
2996 gfc_check_ttynam (gfc_expr *unit)
2997 {
2998   if (scalar_check (unit, 0) == FAILURE)
2999     return FAILURE;
3000
3001   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3002     return FAILURE;
3003
3004   return SUCCESS;
3005 }
3006
3007
3008 /* Common check function for the half a dozen intrinsics that have a
3009    single real argument.  */
3010
3011 gfc_try
3012 gfc_check_x (gfc_expr *x)
3013 {
3014   if (type_check (x, 0, BT_REAL) == FAILURE)
3015     return FAILURE;
3016
3017   return SUCCESS;
3018 }
3019
3020
3021 /************* Check functions for intrinsic subroutines *************/
3022
3023 gfc_try
3024 gfc_check_cpu_time (gfc_expr *time)
3025 {
3026   if (scalar_check (time, 0) == FAILURE)
3027     return FAILURE;
3028
3029   if (type_check (time, 0, BT_REAL) == FAILURE)
3030     return FAILURE;
3031
3032   if (variable_check (time, 0) == FAILURE)
3033     return FAILURE;
3034
3035   return SUCCESS;
3036 }
3037
3038
3039 gfc_try
3040 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
3041                          gfc_expr *zone, gfc_expr *values)
3042 {
3043   if (date != NULL)
3044     {
3045       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3046         return FAILURE;
3047       if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3048         return FAILURE;
3049       if (scalar_check (date, 0) == FAILURE)
3050         return FAILURE;
3051       if (variable_check (date, 0) == FAILURE)
3052         return FAILURE;
3053     }
3054
3055   if (time != NULL)
3056     {
3057       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
3058         return FAILURE;
3059       if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
3060         return FAILURE;
3061       if (scalar_check (time, 1) == FAILURE)
3062         return FAILURE;
3063       if (variable_check (time, 1) == FAILURE)
3064         return FAILURE;
3065     }
3066
3067   if (zone != NULL)
3068     {
3069       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
3070         return FAILURE;
3071       if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
3072         return FAILURE;
3073       if (scalar_check (zone, 2) == FAILURE)
3074         return FAILURE;
3075       if (variable_check (zone, 2) == FAILURE)
3076         return FAILURE;
3077     }
3078
3079   if (values != NULL)
3080     {
3081       if (type_check (values, 3, BT_INTEGER) == FAILURE)
3082         return FAILURE;
3083       if (array_check (values, 3) == FAILURE)
3084         return FAILURE;
3085       if (rank_check (values, 3, 1) == FAILURE)
3086         return FAILURE;
3087       if (variable_check (values, 3) == FAILURE)
3088         return FAILURE;
3089     }
3090
3091   return SUCCESS;
3092 }
3093
3094
3095 gfc_try
3096 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
3097                   gfc_expr *to, gfc_expr *topos)
3098 {
3099   if (type_check (from, 0, BT_INTEGER) == FAILURE)
3100     return FAILURE;
3101
3102   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
3103     return FAILURE;
3104
3105   if (type_check (len, 2, BT_INTEGER) == FAILURE)
3106     return FAILURE;
3107
3108   if (same_type_check (from, 0, to, 3) == FAILURE)
3109     return FAILURE;
3110
3111   if (variable_check (to, 3) == FAILURE)
3112     return FAILURE;
3113
3114   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
3115     return FAILURE;
3116
3117   return SUCCESS;
3118 }
3119
3120
3121 gfc_try
3122 gfc_check_random_number (gfc_expr *harvest)
3123 {
3124   if (type_check (harvest, 0, BT_REAL) == FAILURE)
3125     return FAILURE;
3126
3127   if (variable_check (harvest, 0) == FAILURE)
3128     return FAILURE;
3129
3130   return SUCCESS;
3131 }
3132
3133
3134 gfc_try
3135 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
3136 {
3137   unsigned int nargs = 0, kiss_size;
3138   locus *where = NULL;
3139   mpz_t put_size, get_size;
3140   bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran.  */
3141
3142   have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
3143
3144   /* Keep the number of bytes in sync with kiss_size in
3145      libgfortran/intrinsics/random.c.  */
3146   kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
3147
3148   if (size != NULL)
3149     {
3150       if (size->expr_type != EXPR_VARIABLE
3151           || !size->symtree->n.sym->attr.optional)
3152         nargs++;
3153
3154       if (scalar_check (size, 0) == FAILURE)
3155         return FAILURE;
3156
3157       if (type_check (size, 0, BT_INTEGER) == FAILURE)
3158         return FAILURE;
3159
3160       if (variable_check (size, 0) == FAILURE)
3161         return FAILURE;
3162
3163       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3164         return FAILURE;
3165     }
3166
3167   if (put != NULL)
3168     {
3169       if (put->expr_type != EXPR_VARIABLE
3170           || !put->symtree->n.sym->attr.optional)
3171         {
3172           nargs++;
3173           where = &put->where;
3174         }
3175
3176       if (array_check (put, 1) == FAILURE)
3177         return FAILURE;
3178
3179       if (rank_check (put, 1, 1) == FAILURE)
3180         return FAILURE;
3181
3182       if (type_check (put, 1, BT_INTEGER) == FAILURE)
3183         return FAILURE;
3184
3185       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3186         return FAILURE;
3187
3188       if (gfc_array_size (put, &put_size) == SUCCESS
3189           && mpz_get_ui (put_size) < kiss_size)
3190         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3191                    "too small (%i/%i)",
3192                    gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
3193                    (int) mpz_get_ui (put_size), kiss_size);
3194     }
3195
3196   if (get != NULL)
3197     {
3198       if (get->expr_type != EXPR_VARIABLE
3199           || !get->symtree->n.sym->attr.optional)
3200         {
3201           nargs++;
3202           where = &get->where;
3203         }
3204
3205       if (array_check (get, 2) == FAILURE)
3206         return FAILURE;
3207
3208       if (rank_check (get, 2, 1) == FAILURE)
3209         return FAILURE;
3210
3211       if (type_check (get, 2, BT_INTEGER) == FAILURE)
3212         return FAILURE;
3213
3214       if (variable_check (get, 2) == FAILURE)
3215         return FAILURE;
3216
3217       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3218         return FAILURE;
3219
3220        if (gfc_array_size (get, &get_size) == SUCCESS
3221           && mpz_get_ui (get_size) < kiss_size)
3222         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
3223                    "too small (%i/%i)",
3224                    gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
3225                    (int) mpz_get_ui (get_size), kiss_size);
3226     }
3227
3228   /* RANDOM_SEED may not have more than one non-optional argument.  */
3229   if (nargs > 1)
3230     gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3231
3232   return SUCCESS;
3233 }
3234
3235
3236 gfc_try
3237 gfc_check_second_sub (gfc_expr *time)
3238 {
3239   if (scalar_check (time, 0) == FAILURE)
3240     return FAILURE;
3241
3242   if (type_check (time, 0, BT_REAL) == FAILURE)
3243     return FAILURE;
3244
3245   if (kind_value_check(time, 0, 4) == FAILURE)
3246     return FAILURE;
3247
3248   return SUCCESS;
3249 }
3250
3251
3252 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
3253    count, count_rate, and count_max are all optional arguments */
3254
3255 gfc_try
3256 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3257                         gfc_expr *count_max)
3258 {
3259   if (count != NULL)
3260     {
3261       if (scalar_check (count, 0) == FAILURE)
3262         return FAILURE;
3263
3264       if (type_check (count, 0, BT_INTEGER) == FAILURE)
3265         return FAILURE;
3266
3267       if (variable_check (count, 0) == FAILURE)
3268         return FAILURE;
3269     }
3270
3271   if (count_rate != NULL)
3272     {
3273       if (scalar_check (count_rate, 1) == FAILURE)
3274         return FAILURE;
3275
3276       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3277         return FAILURE;
3278
3279       if (variable_check (count_rate, 1) == FAILURE)
3280         return FAILURE;
3281
3282       if (count != NULL
3283           && same_type_check (count, 0, count_rate, 1) == FAILURE)
3284         return FAILURE;
3285
3286     }
3287
3288   if (count_max != NULL)
3289     {
3290       if (scalar_check (count_max, 2) == FAILURE)
3291         return FAILURE;
3292
3293       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3294         return FAILURE;
3295
3296       if (variable_check (count_max, 2) == FAILURE)
3297         return FAILURE;
3298
3299       if (count != NULL
3300           && same_type_check (count, 0, count_max, 2) == FAILURE)
3301         return FAILURE;
3302
3303       if (count_rate != NULL
3304           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3305         return FAILURE;
3306     }
3307
3308   return SUCCESS;
3309 }
3310
3311
3312 gfc_try
3313 gfc_check_irand (gfc_expr *x)
3314 {
3315   if (x == NULL)
3316     return SUCCESS;
3317
3318   if (scalar_check (x, 0) == FAILURE)
3319     return FAILURE;
3320
3321   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3322     return FAILURE;
3323
3324   if (kind_value_check(x, 0, 4) == FAILURE)
3325     return FAILURE;
3326
3327   return SUCCESS;
3328 }
3329
3330
3331 gfc_try
3332 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3333 {
3334   if (scalar_check (seconds, 0) == FAILURE)
3335     return FAILURE;
3336
3337   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3338     return FAILURE;
3339
3340   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3341     {
3342       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3343                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3344                  gfc_current_intrinsic, &handler->where);
3345       return FAILURE;
3346     }
3347
3348   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3349     return FAILURE;
3350
3351   if (status == NULL)
3352     return SUCCESS;
3353
3354   if (scalar_check (status, 2) == FAILURE)
3355     return FAILURE;
3356
3357   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3358     return FAILURE;
3359
3360   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3361     return FAILURE;
3362
3363   return SUCCESS;
3364 }
3365
3366
3367 gfc_try
3368 gfc_check_rand (gfc_expr *x)
3369 {
3370   if (x == NULL)
3371     return SUCCESS;
3372
3373   if (scalar_check (x, 0) == FAILURE)
3374     return FAILURE;
3375
3376   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3377     return FAILURE;
3378
3379   if (kind_value_check(x, 0, 4) == FAILURE)
3380     return FAILURE;
3381
3382   return SUCCESS;
3383 }
3384
3385
3386 gfc_try
3387 gfc_check_srand (gfc_expr *x)
3388 {
3389   if (scalar_check (x, 0) == FAILURE)
3390     return FAILURE;
3391
3392   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3393     return FAILURE;
3394
3395   if (kind_value_check(x, 0, 4) == FAILURE)
3396     return FAILURE;
3397
3398   return SUCCESS;
3399 }
3400
3401
3402 gfc_try
3403 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3404 {
3405   if (scalar_check (time, 0) == FAILURE)
3406     return FAILURE;
3407   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3408     return FAILURE;
3409
3410   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3411     return FAILURE;
3412   if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
3413     return FAILURE;
3414
3415   return SUCCESS;
3416 }
3417
3418
3419 gfc_try
3420 gfc_check_dtime_etime (gfc_expr *x)
3421 {
3422   if (array_check (x, 0) == FAILURE)
3423     return FAILURE;
3424
3425   if (rank_check (x, 0, 1) == FAILURE)
3426     return FAILURE;
3427
3428   if (variable_check (x, 0) == FAILURE)
3429     return FAILURE;
3430
3431   if (type_check (x, 0, BT_REAL) == FAILURE)
3432     return FAILURE;
3433
3434   if (kind_value_check(x, 0, 4) == FAILURE)
3435     return FAILURE;
3436
3437   return SUCCESS;
3438 }
3439
3440
3441 gfc_try
3442 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3443 {
3444   if (array_check (values, 0) == FAILURE)
3445     return FAILURE;
3446
3447   if (rank_check (values, 0, 1) == FAILURE)
3448     return FAILURE;
3449
3450   if (variable_check (values, 0) == FAILURE)
3451     return FAILURE;
3452
3453   if (type_check (values, 0, BT_REAL) == FAILURE)
3454     return FAILURE;
3455
3456   if (kind_value_check(values, 0, 4) == FAILURE)
3457     return FAILURE;
3458
3459   if (scalar_check (time, 1) == FAILURE)
3460     return FAILURE;
3461
3462   if (type_check (time, 1, BT_REAL) == FAILURE)
3463     return FAILURE;
3464
3465   if (kind_value_check(time, 1, 4) == FAILURE)
3466     return FAILURE;
3467
3468   return SUCCESS;
3469 }
3470
3471
3472 gfc_try
3473 gfc_check_fdate_sub (gfc_expr *date)
3474 {
3475   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3476     return FAILURE;
3477   if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3478     return FAILURE;
3479
3480   return SUCCESS;
3481 }
3482
3483
3484 gfc_try
3485 gfc_check_gerror (gfc_expr *msg)
3486 {
3487   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3488     return FAILURE;
3489   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3490     return FAILURE;
3491
3492   return SUCCESS;
3493 }
3494
3495
3496 gfc_try
3497 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3498 {
3499   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3500     return FAILURE;
3501   if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
3502     return FAILURE;
3503
3504   if (status == NULL)
3505     return SUCCESS;
3506
3507   if (scalar_check (status, 1) == FAILURE)
3508     return FAILURE;
3509
3510   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3511     return FAILURE;
3512
3513   return SUCCESS;
3514 }
3515
3516
3517 gfc_try
3518 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
3519 {
3520   if (type_check (pos, 0, BT_INTEGER) == FAILURE)
3521     return FAILURE;
3522
3523   if (pos->ts.kind > gfc_default_integer_kind)
3524     {
3525       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3526                  "not wider than the default kind (%d)",
3527                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3528                  &pos->where, gfc_default_integer_kind);
3529       return FAILURE;
3530     }
3531
3532   if (type_check (value, 1, BT_CHARACTER) == FAILURE)
3533     return FAILURE;
3534   if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
3535     return FAILURE;
3536
3537   return SUCCESS;
3538 }
3539
3540
3541 gfc_try
3542 gfc_check_getlog (gfc_expr *msg)
3543 {
3544   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3545     return FAILURE;
3546   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3547     return FAILURE;
3548
3549   return SUCCESS;
3550 }
3551
3552
3553 gfc_try
3554 gfc_check_exit (gfc_expr *status)
3555 {
3556   if (status == NULL)
3557     return SUCCESS;
3558
3559   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3560     return FAILURE;
3561
3562   if (scalar_check (status, 0) == FAILURE)
3563     return FAILURE;
3564
3565   return SUCCESS;
3566 }
3567
3568
3569 gfc_try
3570 gfc_check_flush (gfc_expr *unit)
3571 {
3572   if (unit == NULL)
3573     return SUCCESS;
3574
3575   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3576     return FAILURE;
3577
3578   if (scalar_check (unit, 0) == FAILURE)
3579     return FAILURE;
3580
3581   return SUCCESS;
3582 }
3583
3584
3585 gfc_try
3586 gfc_check_free (gfc_expr *i)
3587 {
3588   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3589     return FAILURE;
3590
3591   if (scalar_check (i, 0) == FAILURE)
3592     return FAILURE;
3593
3594   return SUCCESS;
3595 }
3596
3597
3598 gfc_try
3599 gfc_check_hostnm (gfc_expr *name)
3600 {
3601   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3602     return FAILURE;
3603   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3604     return FAILURE;
3605
3606   return SUCCESS;
3607 }
3608
3609
3610 gfc_try
3611 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3612 {
3613   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3614     return FAILURE;
3615   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3616     return FAILURE;
3617
3618   if (status == NULL)
3619     return SUCCESS;
3620
3621   if (scalar_check (status, 1) == FAILURE)
3622     return FAILURE;
3623
3624   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3625     return FAILURE;
3626
3627   return SUCCESS;
3628 }
3629
3630
3631 gfc_try
3632 gfc_check_itime_idate (gfc_expr *values)
3633 {
3634   if (array_check (values, 0) == FAILURE)
3635     return FAILURE;
3636
3637   if (rank_check (values, 0, 1) == FAILURE)
3638     return FAILURE;
3639
3640   if (variable_check (values, 0) == FAILURE)
3641     return FAILURE;
3642
3643   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3644     return FAILURE;
3645
3646   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3647     return FAILURE;
3648
3649   return SUCCESS;
3650 }
3651
3652
3653 gfc_try
3654 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3655 {
3656   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3657     return FAILURE;
3658
3659   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3660     return FAILURE;
3661
3662   if (scalar_check (time, 0) == FAILURE)
3663     return FAILURE;
3664
3665   if (array_check (values, 1) == FAILURE)
3666     return FAILURE;
3667
3668   if (rank_check (values, 1, 1) == FAILURE)
3669     return FAILURE;
3670
3671   if (variable_check (values, 1) == FAILURE)
3672     return FAILURE;
3673
3674   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3675     return FAILURE;
3676
3677   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3678     return FAILURE;
3679
3680   return SUCCESS;
3681 }
3682
3683
3684 gfc_try
3685 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3686 {
3687   if (scalar_check (unit, 0) == FAILURE)
3688     return FAILURE;
3689
3690   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3691     return FAILURE;
3692
3693   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3694     return FAILURE;
3695   if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
3696     return FAILURE;
3697
3698   return SUCCESS;
3699 }
3700
3701
3702 gfc_try
3703 gfc_check_isatty (gfc_expr *unit)
3704 {
3705   if (unit == NULL)
3706     return FAILURE;
3707
3708   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3709     return FAILURE;
3710
3711   if (scalar_check (unit, 0) == FAILURE)
3712     return FAILURE;
3713
3714   return SUCCESS;
3715 }
3716
3717
3718 gfc_try
3719 gfc_check_isnan (gfc_expr *x)
3720 {
3721   if (type_check (x, 0, BT_REAL) == FAILURE)
3722     return FAILURE;
3723
3724   return SUCCESS;
3725 }
3726
3727
3728 gfc_try
3729 gfc_check_perror (gfc_expr *string)
3730 {
3731   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3732     return FAILURE;
3733   if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
3734     return FAILURE;
3735
3736   return SUCCESS;
3737 }
3738
3739
3740 gfc_try
3741 gfc_check_umask (gfc_expr *mask)
3742 {
3743   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3744     return FAILURE;
3745
3746   if (scalar_check (mask, 0) == FAILURE)
3747     return FAILURE;
3748
3749   return SUCCESS;
3750 }
3751
3752
3753 gfc_try
3754 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3755 {
3756   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3757     return FAILURE;
3758
3759   if (scalar_check (mask, 0) == FAILURE)
3760     return FAILURE;
3761
3762   if (old == NULL)
3763     return SUCCESS;
3764
3765   if (scalar_check (old, 1) == FAILURE)
3766     return FAILURE;
3767
3768   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3769     return FAILURE;
3770
3771   return SUCCESS;
3772 }
3773
3774
3775 gfc_try
3776 gfc_check_unlink (gfc_expr *name)
3777 {
3778   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3779     return FAILURE;
3780   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3781     return FAILURE;
3782
3783   return SUCCESS;
3784 }
3785
3786
3787 gfc_try
3788 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3789 {
3790   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3791     return FAILURE;
3792   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3793     return FAILURE;
3794
3795   if (status == NULL)
3796     return SUCCESS;
3797
3798   if (scalar_check (status, 1) == FAILURE)
3799     return FAILURE;
3800
3801   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3802     return FAILURE;
3803
3804   return SUCCESS;
3805 }
3806
3807
3808 gfc_try
3809 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3810 {
3811   if (scalar_check (number, 0) == FAILURE)
3812     return FAILURE;
3813
3814   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3815     return FAILURE;
3816
3817   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3818     {
3819       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3820                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3821                  gfc_current_intrinsic, &handler->where);
3822       return FAILURE;
3823     }
3824
3825   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3826     return FAILURE;
3827
3828   return SUCCESS;
3829 }
3830
3831
3832 gfc_try
3833 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3834 {
3835   if (scalar_check (number, 0) == FAILURE)
3836     return FAILURE;
3837
3838   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3839     return FAILURE;
3840
3841   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3842     {
3843       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3844                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3845                  gfc_current_intrinsic, &handler->where);
3846       return FAILURE;
3847     }
3848
3849   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3850     return FAILURE;
3851
3852   if (status == NULL)
3853     return SUCCESS;
3854
3855   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3856     return FAILURE;
3857
3858   if (scalar_check (status, 2) == FAILURE)
3859     return FAILURE;
3860
3861   return SUCCESS;
3862 }
3863
3864
3865 gfc_try
3866 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3867 {
3868   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3869     return FAILURE;
3870   if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
3871     return FAILURE;
3872
3873   if (scalar_check (status, 1) == FAILURE)
3874     return FAILURE;
3875
3876   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3877     return FAILURE;
3878
3879   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3880     return FAILURE;
3881
3882   return SUCCESS;
3883 }
3884
3885
3886 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3887 gfc_try
3888 gfc_check_and (gfc_expr *i, gfc_expr *j)
3889 {
3890   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3891     {
3892       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3893                  "or LOGICAL", gfc_current_intrinsic_arg[0],
3894                  gfc_current_intrinsic, &i->where);
3895       return FAILURE;
3896     }
3897
3898   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3899     {
3900       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3901                  "or LOGICAL", gfc_current_intrinsic_arg[1],
3902                  gfc_current_intrinsic, &j->where);
3903       return FAILURE;
3904     }
3905
3906   if (i->ts.type != j->ts.type)
3907     {
3908       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3909                  "have the same type", gfc_current_intrinsic_arg[0],
3910                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3911                  &j->where);
3912       return FAILURE;
3913     }
3914
3915   if (scalar_check (i, 0) == FAILURE)
3916     return FAILURE;
3917
3918   if (scalar_check (j, 1) == FAILURE)
3919     return FAILURE;
3920
3921   return SUCCESS;
3922 }