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