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;
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 these values in sync with kiss_size in libgfortran/random.c.  */
3145   kiss_size = have_gfc_real_16 ? 12 : 8;
3146
3147   if (size != NULL)
3148     {
3149       if (size->expr_type != EXPR_VARIABLE
3150           || !size->symtree->n.sym->attr.optional)
3151         nargs++;
3152
3153       if (scalar_check (size, 0) == FAILURE)
3154         return FAILURE;
3155
3156       if (type_check (size, 0, BT_INTEGER) == FAILURE)
3157         return FAILURE;
3158
3159       if (variable_check (size, 0) == FAILURE)
3160         return FAILURE;
3161
3162       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3163         return FAILURE;
3164     }
3165
3166   if (put != NULL)
3167     {
3168       if (put->expr_type != EXPR_VARIABLE
3169           || !put->symtree->n.sym->attr.optional)
3170         {
3171           nargs++;
3172           where = &put->where;
3173         }
3174
3175       if (array_check (put, 1) == FAILURE)
3176         return FAILURE;
3177
3178       if (rank_check (put, 1, 1) == FAILURE)
3179         return FAILURE;
3180
3181       if (type_check (put, 1, BT_INTEGER) == FAILURE)
3182         return FAILURE;
3183
3184       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3185         return FAILURE;
3186
3187       if (gfc_array_size (put, &put_size) == SUCCESS
3188           && mpz_get_ui (put_size) < kiss_size)
3189         gfc_error ("Array PUT of intrinsic %s is too small (%i/%i) at %L",
3190                    gfc_current_intrinsic, (int) mpz_get_ui (put_size),
3191                    kiss_size, where);
3192     }
3193
3194   if (get != NULL)
3195     {
3196       if (get->expr_type != EXPR_VARIABLE
3197           || !get->symtree->n.sym->attr.optional)
3198         {
3199           nargs++;
3200           where = &get->where;
3201         }
3202
3203       if (array_check (get, 2) == FAILURE)
3204         return FAILURE;
3205
3206       if (rank_check (get, 2, 1) == FAILURE)
3207         return FAILURE;
3208
3209       if (type_check (get, 2, BT_INTEGER) == FAILURE)
3210         return FAILURE;
3211
3212       if (variable_check (get, 2) == FAILURE)
3213         return FAILURE;
3214
3215       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3216         return FAILURE;
3217     }
3218
3219   /* RANDOM_SEED may not have more than one non-optional argument.  */
3220   if (nargs > 1)
3221     gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3222
3223   return SUCCESS;
3224 }
3225
3226
3227 gfc_try
3228 gfc_check_second_sub (gfc_expr *time)
3229 {
3230   if (scalar_check (time, 0) == FAILURE)
3231     return FAILURE;
3232
3233   if (type_check (time, 0, BT_REAL) == FAILURE)
3234     return FAILURE;
3235
3236   if (kind_value_check(time, 0, 4) == FAILURE)
3237     return FAILURE;
3238
3239   return SUCCESS;
3240 }
3241
3242
3243 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
3244    count, count_rate, and count_max are all optional arguments */
3245
3246 gfc_try
3247 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3248                         gfc_expr *count_max)
3249 {
3250   if (count != NULL)
3251     {
3252       if (scalar_check (count, 0) == FAILURE)
3253         return FAILURE;
3254
3255       if (type_check (count, 0, BT_INTEGER) == FAILURE)
3256         return FAILURE;
3257
3258       if (variable_check (count, 0) == FAILURE)
3259         return FAILURE;
3260     }
3261
3262   if (count_rate != NULL)
3263     {
3264       if (scalar_check (count_rate, 1) == FAILURE)
3265         return FAILURE;
3266
3267       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3268         return FAILURE;
3269
3270       if (variable_check (count_rate, 1) == FAILURE)
3271         return FAILURE;
3272
3273       if (count != NULL
3274           && same_type_check (count, 0, count_rate, 1) == FAILURE)
3275         return FAILURE;
3276
3277     }
3278
3279   if (count_max != NULL)
3280     {
3281       if (scalar_check (count_max, 2) == FAILURE)
3282         return FAILURE;
3283
3284       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3285         return FAILURE;
3286
3287       if (variable_check (count_max, 2) == FAILURE)
3288         return FAILURE;
3289
3290       if (count != NULL
3291           && same_type_check (count, 0, count_max, 2) == FAILURE)
3292         return FAILURE;
3293
3294       if (count_rate != NULL
3295           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3296         return FAILURE;
3297     }
3298
3299   return SUCCESS;
3300 }
3301
3302
3303 gfc_try
3304 gfc_check_irand (gfc_expr *x)
3305 {
3306   if (x == NULL)
3307     return SUCCESS;
3308
3309   if (scalar_check (x, 0) == FAILURE)
3310     return FAILURE;
3311
3312   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3313     return FAILURE;
3314
3315   if (kind_value_check(x, 0, 4) == FAILURE)
3316     return FAILURE;
3317
3318   return SUCCESS;
3319 }
3320
3321
3322 gfc_try
3323 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3324 {
3325   if (scalar_check (seconds, 0) == FAILURE)
3326     return FAILURE;
3327
3328   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3329     return FAILURE;
3330
3331   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3332     {
3333       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3334                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3335                  gfc_current_intrinsic, &handler->where);
3336       return FAILURE;
3337     }
3338
3339   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3340     return FAILURE;
3341
3342   if (status == NULL)
3343     return SUCCESS;
3344
3345   if (scalar_check (status, 2) == FAILURE)
3346     return FAILURE;
3347
3348   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3349     return FAILURE;
3350
3351   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3352     return FAILURE;
3353
3354   return SUCCESS;
3355 }
3356
3357
3358 gfc_try
3359 gfc_check_rand (gfc_expr *x)
3360 {
3361   if (x == NULL)
3362     return SUCCESS;
3363
3364   if (scalar_check (x, 0) == FAILURE)
3365     return FAILURE;
3366
3367   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3368     return FAILURE;
3369
3370   if (kind_value_check(x, 0, 4) == FAILURE)
3371     return FAILURE;
3372
3373   return SUCCESS;
3374 }
3375
3376
3377 gfc_try
3378 gfc_check_srand (gfc_expr *x)
3379 {
3380   if (scalar_check (x, 0) == FAILURE)
3381     return FAILURE;
3382
3383   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3384     return FAILURE;
3385
3386   if (kind_value_check(x, 0, 4) == FAILURE)
3387     return FAILURE;
3388
3389   return SUCCESS;
3390 }
3391
3392
3393 gfc_try
3394 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3395 {
3396   if (scalar_check (time, 0) == FAILURE)
3397     return FAILURE;
3398   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3399     return FAILURE;
3400
3401   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3402     return FAILURE;
3403   if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
3404     return FAILURE;
3405
3406   return SUCCESS;
3407 }
3408
3409
3410 gfc_try
3411 gfc_check_dtime_etime (gfc_expr *x)
3412 {
3413   if (array_check (x, 0) == FAILURE)
3414     return FAILURE;
3415
3416   if (rank_check (x, 0, 1) == FAILURE)
3417     return FAILURE;
3418
3419   if (variable_check (x, 0) == FAILURE)
3420     return FAILURE;
3421
3422   if (type_check (x, 0, BT_REAL) == FAILURE)
3423     return FAILURE;
3424
3425   if (kind_value_check(x, 0, 4) == FAILURE)
3426     return FAILURE;
3427
3428   return SUCCESS;
3429 }
3430
3431
3432 gfc_try
3433 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3434 {
3435   if (array_check (values, 0) == FAILURE)
3436     return FAILURE;
3437
3438   if (rank_check (values, 0, 1) == FAILURE)
3439     return FAILURE;
3440
3441   if (variable_check (values, 0) == FAILURE)
3442     return FAILURE;
3443
3444   if (type_check (values, 0, BT_REAL) == FAILURE)
3445     return FAILURE;
3446
3447   if (kind_value_check(values, 0, 4) == FAILURE)
3448     return FAILURE;
3449
3450   if (scalar_check (time, 1) == FAILURE)
3451     return FAILURE;
3452
3453   if (type_check (time, 1, BT_REAL) == FAILURE)
3454     return FAILURE;
3455
3456   if (kind_value_check(time, 1, 4) == FAILURE)
3457     return FAILURE;
3458
3459   return SUCCESS;
3460 }
3461
3462
3463 gfc_try
3464 gfc_check_fdate_sub (gfc_expr *date)
3465 {
3466   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3467     return FAILURE;
3468   if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
3469     return FAILURE;
3470
3471   return SUCCESS;
3472 }
3473
3474
3475 gfc_try
3476 gfc_check_gerror (gfc_expr *msg)
3477 {
3478   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3479     return FAILURE;
3480   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3481     return FAILURE;
3482
3483   return SUCCESS;
3484 }
3485
3486
3487 gfc_try
3488 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3489 {
3490   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3491     return FAILURE;
3492   if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
3493     return FAILURE;
3494
3495   if (status == NULL)
3496     return SUCCESS;
3497
3498   if (scalar_check (status, 1) == FAILURE)
3499     return FAILURE;
3500
3501   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3502     return FAILURE;
3503
3504   return SUCCESS;
3505 }
3506
3507
3508 gfc_try
3509 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
3510 {
3511   if (type_check (pos, 0, BT_INTEGER) == FAILURE)
3512     return FAILURE;
3513
3514   if (pos->ts.kind > gfc_default_integer_kind)
3515     {
3516       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3517                  "not wider than the default kind (%d)",
3518                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3519                  &pos->where, gfc_default_integer_kind);
3520       return FAILURE;
3521     }
3522
3523   if (type_check (value, 1, BT_CHARACTER) == FAILURE)
3524     return FAILURE;
3525   if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
3526     return FAILURE;
3527
3528   return SUCCESS;
3529 }
3530
3531
3532 gfc_try
3533 gfc_check_getlog (gfc_expr *msg)
3534 {
3535   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3536     return FAILURE;
3537   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
3538     return FAILURE;
3539
3540   return SUCCESS;
3541 }
3542
3543
3544 gfc_try
3545 gfc_check_exit (gfc_expr *status)
3546 {
3547   if (status == NULL)
3548     return SUCCESS;
3549
3550   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3551     return FAILURE;
3552
3553   if (scalar_check (status, 0) == FAILURE)
3554     return FAILURE;
3555
3556   return SUCCESS;
3557 }
3558
3559
3560 gfc_try
3561 gfc_check_flush (gfc_expr *unit)
3562 {
3563   if (unit == NULL)
3564     return SUCCESS;
3565
3566   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3567     return FAILURE;
3568
3569   if (scalar_check (unit, 0) == FAILURE)
3570     return FAILURE;
3571
3572   return SUCCESS;
3573 }
3574
3575
3576 gfc_try
3577 gfc_check_free (gfc_expr *i)
3578 {
3579   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3580     return FAILURE;
3581
3582   if (scalar_check (i, 0) == FAILURE)
3583     return FAILURE;
3584
3585   return SUCCESS;
3586 }
3587
3588
3589 gfc_try
3590 gfc_check_hostnm (gfc_expr *name)
3591 {
3592   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3593     return FAILURE;
3594   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3595     return FAILURE;
3596
3597   return SUCCESS;
3598 }
3599
3600
3601 gfc_try
3602 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3603 {
3604   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3605     return FAILURE;
3606   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3607     return FAILURE;
3608
3609   if (status == NULL)
3610     return SUCCESS;
3611
3612   if (scalar_check (status, 1) == FAILURE)
3613     return FAILURE;
3614
3615   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3616     return FAILURE;
3617
3618   return SUCCESS;
3619 }
3620
3621
3622 gfc_try
3623 gfc_check_itime_idate (gfc_expr *values)
3624 {
3625   if (array_check (values, 0) == FAILURE)
3626     return FAILURE;
3627
3628   if (rank_check (values, 0, 1) == FAILURE)
3629     return FAILURE;
3630
3631   if (variable_check (values, 0) == FAILURE)
3632     return FAILURE;
3633
3634   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3635     return FAILURE;
3636
3637   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3638     return FAILURE;
3639
3640   return SUCCESS;
3641 }
3642
3643
3644 gfc_try
3645 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3646 {
3647   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3648     return FAILURE;
3649
3650   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3651     return FAILURE;
3652
3653   if (scalar_check (time, 0) == FAILURE)
3654     return FAILURE;
3655
3656   if (array_check (values, 1) == FAILURE)
3657     return FAILURE;
3658
3659   if (rank_check (values, 1, 1) == FAILURE)
3660     return FAILURE;
3661
3662   if (variable_check (values, 1) == FAILURE)
3663     return FAILURE;
3664
3665   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3666     return FAILURE;
3667
3668   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3669     return FAILURE;
3670
3671   return SUCCESS;
3672 }
3673
3674
3675 gfc_try
3676 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3677 {
3678   if (scalar_check (unit, 0) == FAILURE)
3679     return FAILURE;
3680
3681   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3682     return FAILURE;
3683
3684   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3685     return FAILURE;
3686   if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
3687     return FAILURE;
3688
3689   return SUCCESS;
3690 }
3691
3692
3693 gfc_try
3694 gfc_check_isatty (gfc_expr *unit)
3695 {
3696   if (unit == NULL)
3697     return FAILURE;
3698
3699   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3700     return FAILURE;
3701
3702   if (scalar_check (unit, 0) == FAILURE)
3703     return FAILURE;
3704
3705   return SUCCESS;
3706 }
3707
3708
3709 gfc_try
3710 gfc_check_isnan (gfc_expr *x)
3711 {
3712   if (type_check (x, 0, BT_REAL) == FAILURE)
3713     return FAILURE;
3714
3715   return SUCCESS;
3716 }
3717
3718
3719 gfc_try
3720 gfc_check_perror (gfc_expr *string)
3721 {
3722   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3723     return FAILURE;
3724   if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
3725     return FAILURE;
3726
3727   return SUCCESS;
3728 }
3729
3730
3731 gfc_try
3732 gfc_check_umask (gfc_expr *mask)
3733 {
3734   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3735     return FAILURE;
3736
3737   if (scalar_check (mask, 0) == FAILURE)
3738     return FAILURE;
3739
3740   return SUCCESS;
3741 }
3742
3743
3744 gfc_try
3745 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3746 {
3747   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3748     return FAILURE;
3749
3750   if (scalar_check (mask, 0) == FAILURE)
3751     return FAILURE;
3752
3753   if (old == NULL)
3754     return SUCCESS;
3755
3756   if (scalar_check (old, 1) == FAILURE)
3757     return FAILURE;
3758
3759   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3760     return FAILURE;
3761
3762   return SUCCESS;
3763 }
3764
3765
3766 gfc_try
3767 gfc_check_unlink (gfc_expr *name)
3768 {
3769   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3770     return FAILURE;
3771   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3772     return FAILURE;
3773
3774   return SUCCESS;
3775 }
3776
3777
3778 gfc_try
3779 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3780 {
3781   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3782     return FAILURE;
3783   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3784     return FAILURE;
3785
3786   if (status == NULL)
3787     return SUCCESS;
3788
3789   if (scalar_check (status, 1) == FAILURE)
3790     return FAILURE;
3791
3792   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3793     return FAILURE;
3794
3795   return SUCCESS;
3796 }
3797
3798
3799 gfc_try
3800 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3801 {
3802   if (scalar_check (number, 0) == FAILURE)
3803     return FAILURE;
3804
3805   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3806     return FAILURE;
3807
3808   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3809     {
3810       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3811                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3812                  gfc_current_intrinsic, &handler->where);
3813       return FAILURE;
3814     }
3815
3816   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3817     return FAILURE;
3818
3819   return SUCCESS;
3820 }
3821
3822
3823 gfc_try
3824 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3825 {
3826   if (scalar_check (number, 0) == FAILURE)
3827     return FAILURE;
3828
3829   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3830     return FAILURE;
3831
3832   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3833     {
3834       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3835                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3836                  gfc_current_intrinsic, &handler->where);
3837       return FAILURE;
3838     }
3839
3840   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3841     return FAILURE;
3842
3843   if (status == NULL)
3844     return SUCCESS;
3845
3846   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3847     return FAILURE;
3848
3849   if (scalar_check (status, 2) == FAILURE)
3850     return FAILURE;
3851
3852   return SUCCESS;
3853 }
3854
3855
3856 gfc_try
3857 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3858 {
3859   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3860     return FAILURE;
3861   if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
3862     return FAILURE;
3863
3864   if (scalar_check (status, 1) == FAILURE)
3865     return FAILURE;
3866
3867   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3868     return FAILURE;
3869
3870   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3871     return FAILURE;
3872
3873   return SUCCESS;
3874 }
3875
3876
3877 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3878 gfc_try
3879 gfc_check_and (gfc_expr *i, gfc_expr *j)
3880 {
3881   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3882     {
3883       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3884                  "or LOGICAL", gfc_current_intrinsic_arg[0],
3885                  gfc_current_intrinsic, &i->where);
3886       return FAILURE;
3887     }
3888
3889   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3890     {
3891       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3892                  "or LOGICAL", gfc_current_intrinsic_arg[1],
3893                  gfc_current_intrinsic, &j->where);
3894       return FAILURE;
3895     }
3896
3897   if (i->ts.type != j->ts.type)
3898     {
3899       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3900                  "have the same type", gfc_current_intrinsic_arg[0],
3901                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3902                  &j->where);
3903       return FAILURE;
3904     }
3905
3906   if (scalar_check (i, 0) == FAILURE)
3907     return FAILURE;
3908
3909   if (scalar_check (j, 1) == FAILURE)
3910     return FAILURE;
3911
3912   return SUCCESS;
3913 }