gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
   3    2011, 2012
   4    Free Software Foundation, Inc.
   5    Contributed by Andy Vaught & Katherine Holcomb
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23
  24 /* These functions check to see if an argument list is compatible with
  25    a particular intrinsic function or subroutine.  Presence of
  26    required arguments has already been established, the argument list
  27    has been sorted into the right order and has NULL arguments in the
  28    correct places for missing optional arguments.  */
  29
  30 #include "config.h"
  31 #include "system.h"
  32 #include "coretypes.h"
  33 #include "flags.h"
  34 #include "gfortran.h"
  35 #include "intrinsic.h"
  36 #include "constructor.h"
  37 #include "target-memory.h"
  38
  39
  40 /* Make sure an expression is a scalar.  */
  41
  42 static gfc_try
  43 scalar_check (gfc_expr *e, int n)
  44 {
  45   if (e->rank == 0)
  46     return SUCCESS;
  47
  48   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
  49              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
  50              &e->where);
  51
  52   return FAILURE;
  53 }
  54
  55
  56 /* Check the type of an expression.  */
  57
  58 static gfc_try
  59 type_check (gfc_expr *e, int n, bt type)
  60 {
  61   if (e->ts.type == type)
  62     return SUCCESS;
  63
  64   gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
  65              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
  66              &e->where, gfc_basic_typename (type));
  67
  68   return FAILURE;
  69 }
  70
  71
  72 /* Check that the expression is a numeric type.  */
  73
  74 static gfc_try
  75 numeric_check (gfc_expr *e, int n)
  76 {
  77   if (gfc_numeric_ts (&e->ts))
  78     return SUCCESS;
  79
  80   /* If the expression has not got a type, check if its namespace can
  81      offer a default type.  */
  82   if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
  83         && e->symtree->n.sym->ts.type == BT_UNKNOWN
  84         && gfc_set_default_type (e->symtree->n.sym, 0,
  85                                  e->symtree->n.sym->ns) == SUCCESS
  86         && gfc_numeric_ts (&e->symtree->n.sym->ts))
  87     {
  88       e->ts = e->symtree->n.sym->ts;
  89       return SUCCESS;
  90     }
  91
  92   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
  93              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
  94              &e->where);
  95
  96   return FAILURE;
  97 }
  98
  99
 100 /* Check that an expression is integer or real.  */
 101
 102 static gfc_try
 103 int_or_real_check (gfc_expr *e, int n)
 104 {
 105   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
 106     {
 107       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
 108                  "or REAL", gfc_current_intrinsic_arg[n]->name,
 109                  gfc_current_intrinsic, &e->where);
 110       return FAILURE;
 111     }
 112
 113   return SUCCESS;
 114 }
 115
 116
 117 /* Check that an expression is real or complex.  */
 118
 119 static gfc_try
 120 real_or_complex_check (gfc_expr *e, int n)
 121 {
 122   if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
 123     {
 124       gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
 125                  "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
 126                  gfc_current_intrinsic, &e->where);
 127       return FAILURE;
 128     }
 129
 130   return SUCCESS;
 131 }
 132
 133
 134 /* Check that an expression is INTEGER or PROCEDURE.  */
 135
 136 static gfc_try
 137 int_or_proc_check (gfc_expr *e, int n)
 138 {
 139   if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
 140     {
 141       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
 142                  "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
 143                  gfc_current_intrinsic, &e->where);
 144       return FAILURE;
 145     }
 146
 147   return SUCCESS;
 148 }
 149
 150
 151 /* Check that the expression is an optional constant integer
 152    and that it specifies a valid kind for that type.  */
 153
 154 static gfc_try
 155 kind_check (gfc_expr *k, int n, bt type)
 156 {
 157   int kind;
 158
 159   if (k == NULL)
 160     return SUCCESS;
 161
 162   if (type_check (k, n, BT_INTEGER) == FAILURE)
 163     return FAILURE;
 164
 165   if (scalar_check (k, n) == FAILURE)
 166     return FAILURE;
 167
 168   if (gfc_check_init_expr (k) != SUCCESS)
 169     {
 170       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
 171                  gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 172                  &k->where);
 173       return FAILURE;
 174     }
 175
 176   if (gfc_extract_int (k, &kind) != NULL
 177       || gfc_validate_kind (type, kind, true) < 0)
 178     {
 179       gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
 180                  &k->where);
 181       return FAILURE;
 182     }
 183
 184   return SUCCESS;
 185 }
 186
 187
 188 /* Make sure the expression is a double precision real.  */
 189
 190 static gfc_try
 191 double_check (gfc_expr *d, int n)
 192 {
 193   if (type_check (d, n, BT_REAL) == FAILURE)
 194     return FAILURE;
 195
 196   if (d->ts.kind != gfc_default_double_kind)
 197     {
 198       gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
 199                  "precision", gfc_current_intrinsic_arg[n]->name,
 200                  gfc_current_intrinsic, &d->where);
 201       return FAILURE;
 202     }
 203
 204   return SUCCESS;
 205 }
 206
 207
 208 static gfc_try
 209 coarray_check (gfc_expr *e, int n)
 210 {
 211   if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
 212         && CLASS_DATA (e)->attr.codimension
 213         && CLASS_DATA (e)->as->corank)
 214     {
 215       gfc_add_class_array_ref (e);
 216       return SUCCESS;
 217     }
 218
 219   if (!gfc_is_coarray (e))
 220     {
 221       gfc_error ("Expected coarray variable as '%s' argument to the %s "
 222                  "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
 223                  gfc_current_intrinsic, &e->where);
 224       return FAILURE;
 225     }
 226
 227   return SUCCESS;
 228 }
 229
 230
 231 /* Make sure the expression is a logical array.  */
 232
 233 static gfc_try
 234 logical_array_check (gfc_expr *array, int n)
 235 {
 236   if (array->ts.type != BT_LOGICAL || array->rank == 0)
 237     {
 238       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
 239                  "array", gfc_current_intrinsic_arg[n]->name,
 240                  gfc_current_intrinsic, &array->where);
 241       return FAILURE;
 242     }
 243
 244   return SUCCESS;
 245 }
 246
 247
 248 /* Make sure an expression is an array.  */
 249
 250 static gfc_try
 251 array_check (gfc_expr *e, int n)
 252 {
 253   if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
 254         && CLASS_DATA (e)->attr.dimension
 255         && CLASS_DATA (e)->as->rank)
 256     {
 257       gfc_add_class_array_ref (e);
 258       return SUCCESS;
 259     }
 260
 261   if (e->rank != 0)
 262     return SUCCESS;
 263
 264   gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
 265              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 266              &e->where);
 267
 268   return FAILURE;
 269 }
 270
 271
 272 /* If expr is a constant, then check to ensure that it is greater than
 273    of equal to zero.  */
 274
 275 static gfc_try
 276 nonnegative_check (const char *arg, gfc_expr *expr)
 277 {
 278   int i;
 279
 280   if (expr->expr_type == EXPR_CONSTANT)
 281     {
 282       gfc_extract_int (expr, &i);
 283       if (i < 0)
 284         {
 285           gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
 286           return FAILURE;
 287         }
 288     }
 289
 290   return SUCCESS;
 291 }
 292
 293
 294 /* If expr2 is constant, then check that the value is less than
 295    (less than or equal to, if 'or_equal' is true) bit_size(expr1).  */
 296
 297 static gfc_try
 298 less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
 299                     gfc_expr *expr2, bool or_equal)
 300 {
 301   int i2, i3;
 302
 303   if (expr2->expr_type == EXPR_CONSTANT)
 304     {
 305       gfc_extract_int (expr2, &i2);
 306       i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
 307
 308       /* For ISHFT[C], check that |shift| <= bit_size(i).  */
 309       if (arg2 == NULL)
 310         {
 311           if (i2 < 0)
 312             i2 = -i2;
 313
 314           if (i2 > gfc_integer_kinds[i3].bit_size)
 315             {
 316               gfc_error ("The absolute value of SHIFT at %L must be less "
 317                          "than or equal to BIT_SIZE('%s')",
 318                          &expr2->where, arg1);
 319               return FAILURE;
 320             }
 321         }
 322
 323       if (or_equal)
 324         {
 325           if (i2 > gfc_integer_kinds[i3].bit_size)
 326             {
 327               gfc_error ("'%s' at %L must be less than "
 328                          "or equal to BIT_SIZE('%s')",
 329                          arg2, &expr2->where, arg1);
 330               return FAILURE;
 331             }
 332         }
 333       else
 334         {
 335           if (i2 >= gfc_integer_kinds[i3].bit_size)
 336             {
 337               gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
 338                          arg2, &expr2->where, arg1);
 339               return FAILURE;
 340             }
 341         }
 342     }
 343
 344   return SUCCESS;
 345 }
 346
 347
 348 /* If expr is constant, then check that the value is less than or equal
 349    to the bit_size of the kind k.  */
 350
 351 static gfc_try
 352 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
 353 {
 354   int i, val;
 355
 356   if (expr->expr_type != EXPR_CONSTANT)
 357     return SUCCESS;
 358
 359   i = gfc_validate_kind (BT_INTEGER, k, false);
 360   gfc_extract_int (expr, &val);
 361
 362   if (val > gfc_integer_kinds[i].bit_size)
 363     {
 364       gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
 365                  "INTEGER(KIND=%d)", arg, &expr->where, k);
 366       return FAILURE;
 367     }
 368
 369   return SUCCESS;
 370 }
 371
 372
 373 /* If expr2 and expr3 are constants, then check that the value is less than
 374    or equal to bit_size(expr1).  */
 375
 376 static gfc_try
 377 less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
 378                gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
 379 {
 380   int i2, i3;
 381
 382   if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
 383     {
 384       gfc_extract_int (expr2, &i2);
 385       gfc_extract_int (expr3, &i3);
 386       i2 += i3;
 387       i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
 388       if (i2 > gfc_integer_kinds[i3].bit_size)
 389         {
 390           gfc_error ("'%s + %s' at %L must be less than or equal "
 391                      "to BIT_SIZE('%s')",
 392                      arg2, arg3, &expr2->where, arg1);
 393           return FAILURE;
 394         }
 395     }
 396
 397   return SUCCESS;
 398 }
 399
 400 /* Make sure two expressions have the same type.  */
 401
 402 static gfc_try
 403 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
 404 {
 405   if (gfc_compare_types (&e->ts, &f->ts))
 406     return SUCCESS;
 407
 408   gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
 409              "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
 410              gfc_current_intrinsic, &f->where,
 411              gfc_current_intrinsic_arg[n]->name);
 412
 413   return FAILURE;
 414 }
 415
 416
 417 /* Make sure that an expression has a certain (nonzero) rank.  */
 418
 419 static gfc_try
 420 rank_check (gfc_expr *e, int n, int rank)
 421 {
 422   if (e->rank == rank)
 423     return SUCCESS;
 424
 425   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
 426              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 427              &e->where, rank);
 428
 429   return FAILURE;
 430 }
 431
 432
 433 /* Make sure a variable expression is not an optional dummy argument.  */
 434
 435 static gfc_try
 436 nonoptional_check (gfc_expr *e, int n)
 437 {
 438   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
 439     {
 440       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
 441                  gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 442                  &e->where);
 443     }
 444
 445   /* TODO: Recursive check on nonoptional variables?  */
 446
 447   return SUCCESS;
 448 }
 449
 450
 451 /* Check for ALLOCATABLE attribute.  */
 452
 453 static gfc_try
 454 allocatable_check (gfc_expr *e, int n)
 455 {
 456   symbol_attribute attr;
 457
 458   attr = gfc_variable_attr (e, NULL);
 459   if (!attr.allocatable)
 460     {
 461       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
 462                  gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 463                  &e->where);
 464       return FAILURE;
 465     }
 466
 467   return SUCCESS;
 468 }
 469
 470
 471 /* Check that an expression has a particular kind.  */
 472
 473 static gfc_try
 474 kind_value_check (gfc_expr *e, int n, int k)
 475 {
 476   if (e->ts.kind == k)
 477     return SUCCESS;
 478
 479   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
 480              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 481              &e->where, k);
 482
 483   return FAILURE;
 484 }
 485
 486
 487 /* Make sure an expression is a variable.  */
 488
 489 static gfc_try
 490 variable_check (gfc_expr *e, int n, bool allow_proc)
 491 {
 492   if (e->expr_type == EXPR_VARIABLE
 493       && e->symtree->n.sym->attr.intent == INTENT_IN
 494       && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
 495           || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
 496     {
 497       gfc_ref *ref;
 498       bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
 499                      && CLASS_DATA (e->symtree->n.sym)
 500                      ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
 501                      : e->symtree->n.sym->attr.pointer;
 502
 503       for (ref = e->ref; ref; ref = ref->next)
 504         {
 505           if (pointer && ref->type == REF_COMPONENT)
 506             break;
 507           if (ref->type == REF_COMPONENT
 508               && ((ref->u.c.component->ts.type == BT_CLASS
 509                    && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
 510                   || (ref->u.c.component->ts.type != BT_CLASS
 511                       && ref->u.c.component->attr.pointer)))
 512             break;
 513         }
 514
 515       if (!ref)
 516         {
 517           gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
 518                      "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
 519                      gfc_current_intrinsic, &e->where);
 520           return FAILURE;
 521         }
 522     }
 523
 524   if (e->expr_type == EXPR_VARIABLE
 525       && e->symtree->n.sym->attr.flavor != FL_PARAMETER
 526       && (allow_proc || !e->symtree->n.sym->attr.function))
 527     return SUCCESS;
 528
 529   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
 530       && e->symtree->n.sym == e->symtree->n.sym->result)
 531     {
 532       gfc_namespace *ns;
 533       for (ns = gfc_current_ns; ns; ns = ns->parent)
 534         if (ns->proc_name == e->symtree->n.sym)
 535           return SUCCESS;
 536     }
 537
 538   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
 539              gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
 540
 541   return FAILURE;
 542 }
 543
 544
 545 /* Check the common DIM parameter for correctness.  */
 546
 547 static gfc_try
 548 dim_check (gfc_expr *dim, int n, bool optional)
 549 {
 550   if (dim == NULL)
 551     return SUCCESS;
 552
 553   if (type_check (dim, n, BT_INTEGER) == FAILURE)
 554     return FAILURE;
 555
 556   if (scalar_check (dim, n) == FAILURE)
 557     return FAILURE;
 558
 559   if (!optional && nonoptional_check (dim, n) == FAILURE)
 560     return FAILURE;
 561
 562   return SUCCESS;
 563 }
 564
 565
 566 /* If a coarray DIM parameter is a constant, make sure that it is greater than
 567    zero and less than or equal to the corank of the given array.  */
 568
 569 static gfc_try
 570 dim_corank_check (gfc_expr *dim, gfc_expr *array)
 571 {
 572   int corank;
 573
 574   gcc_assert (array->expr_type == EXPR_VARIABLE);
 575
 576   if (dim->expr_type != EXPR_CONSTANT)
 577     return SUCCESS;
 578
 579   if (array->ts.type == BT_CLASS)
 580     return SUCCESS;
 581
 582   corank = gfc_get_corank (array);
 583
 584   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 585       || mpz_cmp_ui (dim->value.integer, corank) > 0)
 586     {
 587       gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
 588                  "codimension index", gfc_current_intrinsic, &dim->where);
 589
 590       return FAILURE;
 591     }
 592
 593   return SUCCESS;
 594 }
 595
 596
 597 /* If a DIM parameter is a constant, make sure that it is greater than
 598    zero and less than or equal to the rank of the given array.  If
 599    allow_assumed is zero then dim must be less than the rank of the array
 600    for assumed size arrays.  */
 601
 602 static gfc_try
 603 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
 604 {
 605   gfc_array_ref *ar;
 606   int rank;
 607
 608   if (dim == NULL)
 609     return SUCCESS;
 610
 611   if (dim->expr_type != EXPR_CONSTANT)
 612     return SUCCESS;
 613
 614   if (array->ts.type == BT_CLASS)
 615     return SUCCESS;
 616
 617   if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
 618       && array->value.function.isym->id == GFC_ISYM_SPREAD)
 619     rank = array->rank + 1;
 620   else
 621     rank = array->rank;
 622
 623   if (array->expr_type == EXPR_VARIABLE)
 624     {
 625       ar = gfc_find_array_ref (array);
 626       if (ar->as->type == AS_ASSUMED_SIZE
 627           && !allow_assumed
 628           && ar->type != AR_ELEMENT
 629           && ar->type != AR_SECTION)
 630         rank--;
 631     }
 632
 633   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 634       || mpz_cmp_ui (dim->value.integer, rank) > 0)
 635     {
 636       gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
 637                  "dimension index", gfc_current_intrinsic, &dim->where);
 638
 639       return FAILURE;
 640     }
 641
 642   return SUCCESS;
 643 }
 644
 645
 646 /* Compare the size of a along dimension ai with the size of b along
 647    dimension bi, returning 0 if they are known not to be identical,
 648    and 1 if they are identical, or if this cannot be determined.  */
 649
 650 static int
 651 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 652 {
 653   mpz_t a_size, b_size;
 654   int ret;
 655
 656   gcc_assert (a->rank > ai);
 657   gcc_assert (b->rank > bi);
 658
 659   ret = 1;
 660
 661   if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
 662     {
 663       if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
 664         {
 665           if (mpz_cmp (a_size, b_size) != 0)
 666             ret = 0;
 667
 668           mpz_clear (b_size);
 669         }
 670       mpz_clear (a_size);
 671     }
 672   return ret;
 673 }
 674
 675 /*  Calculate the length of a character variable, including substrings.
 676     Strip away parentheses if necessary.  Return -1 if no length could
 677     be determined.  */
 678
 679 static long
 680 gfc_var_strlen (const gfc_expr *a)
 681 {
 682   gfc_ref *ra;
 683
 684   while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
 685     a = a->value.op.op1;
 686
 687   for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
 688     ;
 689
 690   if (ra)
 691     {
 692       long start_a, end_a;
 693
 694       if (ra->u.ss.start->expr_type == EXPR_CONSTANT
 695           && ra->u.ss.end->expr_type == EXPR_CONSTANT)
 696         {
 697           start_a = mpz_get_si (ra->u.ss.start->value.integer);
 698           end_a = mpz_get_si (ra->u.ss.end->value.integer);
 699           return end_a - start_a + 1;
 700         }
 701       else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
 702         return 1;
 703       else
 704         return -1;
 705     }
 706
 707   if (a->ts.u.cl && a->ts.u.cl->length
 708       && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
 709     return mpz_get_si (a->ts.u.cl->length->value.integer);
 710   else if (a->expr_type == EXPR_CONSTANT
 711            && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
 712     return a->value.character.length;
 713   else
 714     return -1;
 715
 716 }
 717
 718 /* Check whether two character expressions have the same length;
 719    returns SUCCESS if they have or if the length cannot be determined,
 720    otherwise return FAILURE and raise a gfc_error.  */
 721
 722 gfc_try
 723 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
 724 {
 725    long len_a, len_b;
 726
 727    len_a = gfc_var_strlen(a);
 728    len_b = gfc_var_strlen(b);
 729
 730    if (len_a == -1 || len_b == -1 || len_a == len_b)
 731      return SUCCESS;
 732    else
 733      {
 734        gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
 735                   len_a, len_b, name, &a->where);
 736        return FAILURE;
 737      }
 738 }
 739
 740
 741 /***** Check functions *****/
 742
 743 /* Check subroutine suitable for intrinsics taking a real argument and
 744    a kind argument for the result.  */
 745
 746 static gfc_try
 747 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
 748 {
 749   if (type_check (a, 0, BT_REAL) == FAILURE)
 750     return FAILURE;
 751   if (kind_check (kind, 1, type) == FAILURE)
 752     return FAILURE;
 753
 754   return SUCCESS;
 755 }
 756
 757
 758 /* Check subroutine suitable for ceiling, floor and nint.  */
 759
 760 gfc_try
 761 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
 762 {
 763   return check_a_kind (a, kind, BT_INTEGER);
 764 }
 765
 766
 767 /* Check subroutine suitable for aint, anint.  */
 768
 769 gfc_try
 770 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
 771 {
 772   return check_a_kind (a, kind, BT_REAL);
 773 }
 774
 775
 776 gfc_try
 777 gfc_check_abs (gfc_expr *a)
 778 {
 779   if (numeric_check (a, 0) == FAILURE)
 780     return FAILURE;
 781
 782   return SUCCESS;
 783 }
 784
 785
 786 gfc_try
 787 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
 788 {
 789   if (type_check (a, 0, BT_INTEGER) == FAILURE)
 790     return FAILURE;
 791   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 792     return FAILURE;
 793
 794   return SUCCESS;
 795 }
 796
 797
 798 gfc_try
 799 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
 800 {
 801   if (type_check (name, 0, BT_CHARACTER) == FAILURE
 802       || scalar_check (name, 0) == FAILURE)
 803     return FAILURE;
 804   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
 805     return FAILURE;
 806
 807   if (type_check (mode, 1, BT_CHARACTER) == FAILURE
 808       || scalar_check (mode, 1) == FAILURE)
 809     return FAILURE;
 810   if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
 811     return FAILURE;
 812
 813   return SUCCESS;
 814 }
 815
 816
 817 gfc_try
 818 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
 819 {
 820   if (logical_array_check (mask, 0) == FAILURE)
 821     return FAILURE;
 822
 823   if (dim_check (dim, 1, false) == FAILURE)
 824     return FAILURE;
 825
 826   if (dim_rank_check (dim, mask, 0) == FAILURE)
 827     return FAILURE;
 828
 829   return SUCCESS;
 830 }
 831
 832
 833 gfc_try
 834 gfc_check_allocated (gfc_expr *array)
 835 {
 836   if (variable_check (array, 0, false) == FAILURE)
 837     return FAILURE;
 838   if (allocatable_check (array, 0) == FAILURE)
 839     return FAILURE;
 840
 841   return SUCCESS;
 842 }
 843
 844
 845 /* Common check function where the first argument must be real or
 846    integer and the second argument must be the same as the first.  */
 847
 848 gfc_try
 849 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
 850 {
 851   if (int_or_real_check (a, 0) == FAILURE)
 852     return FAILURE;
 853
 854   if (a->ts.type != p->ts.type)
 855     {
 856       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
 857                  "have the same type", gfc_current_intrinsic_arg[0]->name,
 858                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 859                  &p->where);
 860       return FAILURE;
 861     }
 862
 863   if (a->ts.kind != p->ts.kind)
 864     {
 865       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 866                           &p->where) == FAILURE)
 867        return FAILURE;
 868     }
 869
 870   return SUCCESS;
 871 }
 872
 873
 874 gfc_try
 875 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
 876 {
 877   if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
 878     return FAILURE;
 879
 880   return SUCCESS;
 881 }
 882
 883
 884 gfc_try
 885 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
 886 {
 887   symbol_attribute attr1, attr2;
 888   int i;
 889   gfc_try t;
 890   locus *where;
 891
 892   where = &pointer->where;
 893
 894   if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
 895     attr1 = gfc_expr_attr (pointer);
 896   else if (pointer->expr_type == EXPR_NULL)
 897     goto null_arg;
 898   else
 899     gcc_assert (0); /* Pointer must be a variable or a function.  */
 900
 901   if (!attr1.pointer && !attr1.proc_pointer)
 902     {
 903       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
 904                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 905                  &pointer->where);
 906       return FAILURE;
 907     }
 908
 909   /* F2008, C1242.  */
 910   if (attr1.pointer && gfc_is_coindexed (pointer))
 911     {
 912       gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
 913                  "coindexed", gfc_current_intrinsic_arg[0]->name,
 914                  gfc_current_intrinsic, &pointer->where);
 915       return FAILURE;
 916     }
 917
 918   /* Target argument is optional.  */
 919   if (target == NULL)
 920     return SUCCESS;
 921
 922   where = &target->where;
 923   if (target->expr_type == EXPR_NULL)
 924     goto null_arg;
 925
 926   if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
 927     attr2 = gfc_expr_attr (target);
 928   else
 929     {
 930       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
 931                  "or target VARIABLE or FUNCTION",
 932                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 933                  &target->where);
 934       return FAILURE;
 935     }
 936
 937   if (attr1.pointer && !attr2.pointer && !attr2.target)
 938     {
 939       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
 940                  "or a TARGET", gfc_current_intrinsic_arg[1]->name,
 941                  gfc_current_intrinsic, &target->where);
 942       return FAILURE;
 943     }
 944
 945   /* F2008, C1242.  */
 946   if (attr1.pointer && gfc_is_coindexed (target))
 947     {
 948       gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
 949                  "coindexed", gfc_current_intrinsic_arg[1]->name,
 950                  gfc_current_intrinsic, &target->where);
 951       return FAILURE;
 952     }
 953
 954   t = SUCCESS;
 955   if (same_type_check (pointer, 0, target, 1) == FAILURE)
 956     t = FAILURE;
 957   if (rank_check (target, 0, pointer->rank) == FAILURE)
 958     t = FAILURE;
 959   if (target->rank > 0)
 960     {
 961       for (i = 0; i < target->rank; i++)
 962         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 963           {
 964             gfc_error ("Array section with a vector subscript at %L shall not "
 965                        "be the target of a pointer",
 966                        &target->where);
 967             t = FAILURE;
 968             break;
 969           }
 970     }
 971   return t;
 972
 973 null_arg:
 974
 975   gfc_error ("NULL pointer at %L is not permitted as actual argument "
 976              "of '%s' intrinsic function", where, gfc_current_intrinsic);
 977   return FAILURE;
 978
 979 }
 980
 981
 982 gfc_try
 983 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
 984 {
 985   /* gfc_notify_std would be a waste of time as the return value
 986      is seemingly used only for the generic resolution.  The error
 987      will be: Too many arguments.  */
 988   if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
 989     return FAILURE;
 990
 991   return gfc_check_atan2 (y, x);
 992 }
 993
 994
 995 gfc_try
 996 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
 997 {
 998   if (type_check (y, 0, BT_REAL) == FAILURE)
 999     return FAILURE;
1000   if (same_type_check (y, 0, x, 1) == FAILURE)
1001     return FAILURE;
1002
1003   return SUCCESS;
1004 }
1005
1006
1007 static gfc_try
1008 gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
1009 {
1010   if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
1011       && !(atom->ts.type == BT_LOGICAL
1012            && atom->ts.kind == gfc_atomic_logical_kind))
1013     {
1014       gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1015                  "integer of ATOMIC_INT_KIND or a logical of "
1016                  "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
1017       return FAILURE;
1018     }
1019
1020   if (!gfc_expr_attr (atom).codimension)
1021     {
1022       gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1023                  "coarray or coindexed", &atom->where, gfc_current_intrinsic);
1024       return FAILURE;
1025     }
1026
1027   if (atom->ts.type != value->ts.type)
1028     {
1029       gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
1030                  "have the same type at %L", gfc_current_intrinsic,
1031                  &value->where);
1032       return FAILURE;
1033     }
1034
1035   return SUCCESS;
1036 }
1037
1038
1039 gfc_try
1040 gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
1041 {
1042   if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
1043     return FAILURE;
1044
1045   if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
1046     {
1047       gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1048                  "definable", gfc_current_intrinsic, &atom->where);
1049       return FAILURE;
1050     }
1051
1052   return gfc_check_atomic (atom, value);
1053 }
1054
1055
1056 gfc_try
1057 gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
1058 {
1059   if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
1060     return FAILURE;
1061
1062   if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
1063     {
1064       gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1065                  "definable", gfc_current_intrinsic, &value->where);
1066       return FAILURE;
1067     }
1068
1069   return gfc_check_atomic (atom, value);
1070 }
1071
1072
1073 /* BESJN and BESYN functions.  */
1074
1075 gfc_try
1076 gfc_check_besn (gfc_expr *n, gfc_expr *x)
1077 {
1078   if (type_check (n, 0, BT_INTEGER) == FAILURE)
1079     return FAILURE;
1080   if (n->expr_type == EXPR_CONSTANT)
1081     {
1082       int i;
1083       gfc_extract_int (n, &i);
1084       if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument "
1085                                    "N at %L", &n->where) == FAILURE)
1086         return FAILURE;
1087     }
1088
1089   if (type_check (x, 1, BT_REAL) == FAILURE)
1090     return FAILURE;
1091
1092   return SUCCESS;
1093 }
1094
1095
1096 /* Transformational version of the Bessel JN and YN functions.  */
1097
1098 gfc_try
1099 gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1100 {
1101   if (type_check (n1, 0, BT_INTEGER) == FAILURE)
1102     return FAILURE;
1103   if (scalar_check (n1, 0) == FAILURE)
1104     return FAILURE;
1105   if (nonnegative_check("N1", n1) == FAILURE)
1106     return FAILURE;
1107
1108   if (type_check (n2, 1, BT_INTEGER) == FAILURE)
1109     return FAILURE;
1110   if (scalar_check (n2, 1) == FAILURE)
1111     return FAILURE;
1112   if (nonnegative_check("N2", n2) == FAILURE)
1113     return FAILURE;
1114
1115   if (type_check (x, 2, BT_REAL) == FAILURE)
1116     return FAILURE;
1117   if (scalar_check (x, 2) == FAILURE)
1118     return FAILURE;
1119
1120   return SUCCESS;
1121 }
1122
1123
1124 gfc_try
1125 gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1126 {
1127   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1128     return FAILURE;
1129
1130   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1131     return FAILURE;
1132
1133   return SUCCESS;
1134 }
1135
1136
1137 gfc_try
1138 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
1139 {
1140   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1141     return FAILURE;
1142
1143   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1144     return FAILURE;
1145
1146   if (nonnegative_check ("pos", pos) == FAILURE)
1147     return FAILURE;
1148
1149   if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
1150     return FAILURE;
1151
1152   return SUCCESS;
1153 }
1154
1155
1156 gfc_try
1157 gfc_check_char (gfc_expr *i, gfc_expr *kind)
1158 {
1159   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1160     return FAILURE;
1161   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
1162     return FAILURE;
1163
1164   return SUCCESS;
1165 }
1166
1167
1168 gfc_try
1169 gfc_check_chdir (gfc_expr *dir)
1170 {
1171   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1172     return FAILURE;
1173   if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1174     return FAILURE;
1175
1176   return SUCCESS;
1177 }
1178
1179
1180 gfc_try
1181 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
1182 {
1183   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
1184     return FAILURE;
1185   if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
1186     return FAILURE;
1187
1188   if (status == NULL)
1189     return SUCCESS;
1190
1191   if (type_check (status, 1, BT_INTEGER) == FAILURE)
1192     return FAILURE;
1193   if (scalar_check (status, 1) == FAILURE)
1194     return FAILURE;
1195
1196   return SUCCESS;
1197 }
1198
1199
1200 gfc_try
1201 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
1202 {
1203   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1204     return FAILURE;
1205   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1206     return FAILURE;
1207
1208   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1209     return FAILURE;
1210   if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1211     return FAILURE;
1212
1213   return SUCCESS;
1214 }
1215
1216
1217 gfc_try
1218 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
1219 {
1220   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
1221     return FAILURE;
1222   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
1223     return FAILURE;
1224
1225   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
1226     return FAILURE;
1227   if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
1228     return FAILURE;
1229
1230   if (status == NULL)
1231     return SUCCESS;
1232
1233   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1234     return FAILURE;
1235
1236   if (scalar_check (status, 2) == FAILURE)
1237     return FAILURE;
1238
1239   return SUCCESS;
1240 }
1241
1242
1243 gfc_try
1244 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
1245 {
1246   if (numeric_check (x, 0) == FAILURE)
1247     return FAILURE;
1248
1249   if (y != NULL)
1250     {
1251       if (numeric_check (y, 1) == FAILURE)
1252         return FAILURE;
1253
1254       if (x->ts.type == BT_COMPLEX)
1255         {
1256           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1257                      "present if 'x' is COMPLEX",
1258                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1259                      &y->where);
1260           return FAILURE;
1261         }
1262
1263       if (y->ts.type == BT_COMPLEX)
1264         {
1265           gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1266                      "of either REAL or INTEGER",
1267                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1268                      &y->where);
1269           return FAILURE;
1270         }
1271
1272     }
1273
1274   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
1275     return FAILURE;
1276
1277   return SUCCESS;
1278 }
1279
1280
1281 gfc_try
1282 gfc_check_complex (gfc_expr *x, gfc_expr *y)
1283 {
1284   if (int_or_real_check (x, 0) == FAILURE)
1285     return FAILURE;
1286   if (scalar_check (x, 0) == FAILURE)
1287     return FAILURE;
1288
1289   if (int_or_real_check (y, 1) == FAILURE)
1290     return FAILURE;
1291   if (scalar_check (y, 1) == FAILURE)
1292     return FAILURE;
1293
1294   return SUCCESS;
1295 }
1296
1297
1298 gfc_try
1299 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1300 {
1301   if (logical_array_check (mask, 0) == FAILURE)
1302     return FAILURE;
1303   if (dim_check (dim, 1, false) == FAILURE)
1304     return FAILURE;
1305   if (dim_rank_check (dim, mask, 0) == FAILURE)
1306     return FAILURE;
1307   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1308     return FAILURE;
1309   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1310                               "with KIND argument at %L",
1311                               gfc_current_intrinsic, &kind->where) == FAILURE)
1312     return FAILURE;
1313
1314   return SUCCESS;
1315 }
1316
1317
1318 gfc_try
1319 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
1320 {
1321   if (array_check (array, 0) == FAILURE)
1322     return FAILURE;
1323
1324   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1325     return FAILURE;
1326
1327   if (dim_check (dim, 2, true) == FAILURE)
1328     return FAILURE;
1329
1330   if (dim_rank_check (dim, array, false) == FAILURE)
1331     return FAILURE;
1332
1333   if (array->rank == 1 || shift->rank == 0)
1334     {
1335       if (scalar_check (shift, 1) == FAILURE)
1336         return FAILURE;
1337     }
1338   else if (shift->rank == array->rank - 1)
1339     {
1340       int d;
1341       if (!dim)
1342         d = 1;
1343       else if (dim->expr_type == EXPR_CONSTANT)
1344         gfc_extract_int (dim, &d);
1345       else
1346         d = -1;
1347
1348       if (d > 0)
1349         {
1350           int i, j;
1351           for (i = 0, j = 0; i < array->rank; i++)
1352             if (i != d - 1)
1353               {
1354                 if (!identical_dimen_shape (array, i, shift, j))
1355                   {
1356                     gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1357                                "invalid shape in dimension %d (%ld/%ld)",
1358                                gfc_current_intrinsic_arg[1]->name,
1359                                gfc_current_intrinsic, &shift->where, i + 1,
1360                                mpz_get_si (array->shape[i]),
1361                                mpz_get_si (shift->shape[j]));
1362                     return FAILURE;
1363                   }
1364
1365                 j += 1;
1366               }
1367         }
1368     }
1369   else
1370     {
1371       gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1372                  "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1373                  gfc_current_intrinsic, &shift->where, array->rank - 1);
1374       return FAILURE;
1375     }
1376
1377   return SUCCESS;
1378 }
1379
1380
1381 gfc_try
1382 gfc_check_ctime (gfc_expr *time)
1383 {
1384   if (scalar_check (time, 0) == FAILURE)
1385     return FAILURE;
1386
1387   if (type_check (time, 0, BT_INTEGER) == FAILURE)
1388     return FAILURE;
1389
1390   return SUCCESS;
1391 }
1392
1393
1394 gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
1395 {
1396   if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
1397     return FAILURE;
1398
1399   return SUCCESS;
1400 }
1401
1402 gfc_try
1403 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
1404 {
1405   if (numeric_check (x, 0) == FAILURE)
1406     return FAILURE;
1407
1408   if (y != NULL)
1409     {
1410       if (numeric_check (y, 1) == FAILURE)
1411         return FAILURE;
1412
1413       if (x->ts.type == BT_COMPLEX)
1414         {
1415           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
1416                      "present if 'x' is COMPLEX",
1417                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1418                      &y->where);
1419           return FAILURE;
1420         }
1421
1422       if (y->ts.type == BT_COMPLEX)
1423         {
1424           gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
1425                      "of either REAL or INTEGER",
1426                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1427                      &y->where);
1428           return FAILURE;
1429         }
1430     }
1431
1432   return SUCCESS;
1433 }
1434
1435
1436 gfc_try
1437 gfc_check_dble (gfc_expr *x)
1438 {
1439   if (numeric_check (x, 0) == FAILURE)
1440     return FAILURE;
1441
1442   return SUCCESS;
1443 }
1444
1445
1446 gfc_try
1447 gfc_check_digits (gfc_expr *x)
1448 {
1449   if (int_or_real_check (x, 0) == FAILURE)
1450     return FAILURE;
1451
1452   return SUCCESS;
1453 }
1454
1455
1456 gfc_try
1457 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1458 {
1459   switch (vector_a->ts.type)
1460     {
1461     case BT_LOGICAL:
1462       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
1463         return FAILURE;
1464       break;
1465
1466     case BT_INTEGER:
1467     case BT_REAL:
1468     case BT_COMPLEX:
1469       if (numeric_check (vector_b, 1) == FAILURE)
1470         return FAILURE;
1471       break;
1472
1473     default:
1474       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1475                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
1476                  gfc_current_intrinsic, &vector_a->where);
1477       return FAILURE;
1478     }
1479
1480   if (rank_check (vector_a, 0, 1) == FAILURE)
1481     return FAILURE;
1482
1483   if (rank_check (vector_b, 1, 1) == FAILURE)
1484     return FAILURE;
1485
1486   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
1487     {
1488       gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
1489                  "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
1490                  gfc_current_intrinsic_arg[1]->name, &vector_a->where);
1491       return FAILURE;
1492     }
1493
1494   return SUCCESS;
1495 }
1496
1497
1498 gfc_try
1499 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
1500 {
1501   if (type_check (x, 0, BT_REAL) == FAILURE
1502       || type_check (y, 1, BT_REAL) == FAILURE)
1503     return FAILURE;
1504
1505   if (x->ts.kind != gfc_default_real_kind)
1506     {
1507       gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1508                  "real", gfc_current_intrinsic_arg[0]->name,
1509                  gfc_current_intrinsic, &x->where);
1510       return FAILURE;
1511     }
1512
1513   if (y->ts.kind != gfc_default_real_kind)
1514     {
1515       gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1516                  "real", gfc_current_intrinsic_arg[1]->name,
1517                  gfc_current_intrinsic, &y->where);
1518       return FAILURE;
1519     }
1520
1521   return SUCCESS;
1522 }
1523
1524
1525 gfc_try
1526 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
1527 {
1528   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1529     return FAILURE;
1530
1531   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1532     return FAILURE;
1533
1534   if (i->is_boz && j->is_boz)
1535     {
1536       gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
1537                  "constants", &i->where, &j->where);
1538       return FAILURE;
1539     }
1540
1541   if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE)
1542     return FAILURE;
1543
1544   if (type_check (shift, 2, BT_INTEGER) == FAILURE)
1545     return FAILURE;
1546
1547   if (nonnegative_check ("SHIFT", shift) == FAILURE)
1548     return FAILURE;
1549
1550   if (i->is_boz)
1551     {
1552       if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE)
1553         return FAILURE;
1554       i->ts.kind = j->ts.kind;
1555     }
1556   else
1557     {
1558       if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
1559         return FAILURE;
1560       j->ts.kind = i->ts.kind;
1561     }
1562
1563   return SUCCESS;
1564 }
1565
1566
1567 gfc_try
1568 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1569                    gfc_expr *dim)
1570 {
1571   if (array_check (array, 0) == FAILURE)
1572     return FAILURE;
1573
1574   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1575     return FAILURE;
1576
1577   if (dim_check (dim, 3, true) == FAILURE)
1578     return FAILURE;
1579
1580   if (dim_rank_check (dim, array, false) == FAILURE)
1581     return FAILURE;
1582
1583   if (array->rank == 1 || shift->rank == 0)
1584     {
1585       if (scalar_check (shift, 1) == FAILURE)
1586         return FAILURE;
1587     }
1588   else if (shift->rank == array->rank - 1)
1589     {
1590       int d;
1591       if (!dim)
1592         d = 1;
1593       else if (dim->expr_type == EXPR_CONSTANT)
1594         gfc_extract_int (dim, &d);
1595       else
1596         d = -1;
1597
1598       if (d > 0)
1599         {
1600           int i, j;
1601           for (i = 0, j = 0; i < array->rank; i++)
1602             if (i != d - 1)
1603               {
1604                 if (!identical_dimen_shape (array, i, shift, j))
1605                   {
1606                     gfc_error ("'%s' argument of '%s' intrinsic at %L has "
1607                                "invalid shape in dimension %d (%ld/%ld)",
1608                                gfc_current_intrinsic_arg[1]->name,
1609                                gfc_current_intrinsic, &shift->where, i + 1,
1610                                mpz_get_si (array->shape[i]),
1611                                mpz_get_si (shift->shape[j]));
1612                     return FAILURE;
1613                   }
1614
1615                 j += 1;
1616               }
1617         }
1618     }
1619   else
1620     {
1621       gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
1622                  "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
1623                  gfc_current_intrinsic, &shift->where, array->rank - 1);
1624       return FAILURE;
1625     }
1626
1627   if (boundary != NULL)
1628     {
1629       if (same_type_check (array, 0, boundary, 2) == FAILURE)
1630         return FAILURE;
1631
1632       if (array->rank == 1 || boundary->rank == 0)
1633         {
1634           if (scalar_check (boundary, 2) == FAILURE)
1635             return FAILURE;
1636         }
1637       else if (boundary->rank == array->rank - 1)
1638         {
1639           if (gfc_check_conformance (shift, boundary,
1640                                      "arguments '%s' and '%s' for "
1641                                      "intrinsic %s",
1642                                      gfc_current_intrinsic_arg[1]->name,
1643                                      gfc_current_intrinsic_arg[2]->name,
1644                                      gfc_current_intrinsic ) == FAILURE)
1645             return FAILURE;
1646         }
1647       else
1648         {
1649           gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
1650                      "rank %d or be a scalar",
1651                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1652                      &shift->where, array->rank - 1);
1653           return FAILURE;
1654         }
1655     }
1656
1657   return SUCCESS;
1658 }
1659
1660 gfc_try
1661 gfc_check_float (gfc_expr *a)
1662 {
1663   if (type_check (a, 0, BT_INTEGER) == FAILURE)
1664     return FAILURE;
1665
1666   if ((a->ts.kind != gfc_default_integer_kind)
1667       && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER "
1668                          "kind argument to %s intrinsic at %L",
1669                          gfc_current_intrinsic, &a->where) == FAILURE   )
1670     return FAILURE;
1671
1672   return SUCCESS;
1673 }
1674
1675 /* A single complex argument.  */
1676
1677 gfc_try
1678 gfc_check_fn_c (gfc_expr *a)
1679 {
1680   if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1681     return FAILURE;
1682
1683   return SUCCESS;
1684 }
1685
1686 /* A single real argument.  */
1687
1688 gfc_try
1689 gfc_check_fn_r (gfc_expr *a)
1690 {
1691   if (type_check (a, 0, BT_REAL) == FAILURE)
1692     return FAILURE;
1693
1694   return SUCCESS;
1695 }
1696
1697 /* A single double argument.  */
1698
1699 gfc_try
1700 gfc_check_fn_d (gfc_expr *a)
1701 {
1702   if (double_check (a, 0) == FAILURE)
1703     return FAILURE;
1704
1705   return SUCCESS;
1706 }
1707
1708 /* A single real or complex argument.  */
1709
1710 gfc_try
1711 gfc_check_fn_rc (gfc_expr *a)
1712 {
1713   if (real_or_complex_check (a, 0) == FAILURE)
1714     return FAILURE;
1715
1716   return SUCCESS;
1717 }
1718
1719
1720 gfc_try
1721 gfc_check_fn_rc2008 (gfc_expr *a)
1722 {
1723   if (real_or_complex_check (a, 0) == FAILURE)
1724     return FAILURE;
1725
1726   if (a->ts.type == BT_COMPLEX
1727       && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
1728                          "argument of '%s' intrinsic at %L",
1729                          gfc_current_intrinsic_arg[0]->name,
1730                          gfc_current_intrinsic, &a->where) == FAILURE)
1731     return FAILURE;
1732
1733   return SUCCESS;
1734 }
1735
1736
1737 gfc_try
1738 gfc_check_fnum (gfc_expr *unit)
1739 {
1740   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1741     return FAILURE;
1742
1743   if (scalar_check (unit, 0) == FAILURE)
1744     return FAILURE;
1745
1746   return SUCCESS;
1747 }
1748
1749
1750 gfc_try
1751 gfc_check_huge (gfc_expr *x)
1752 {
1753   if (int_or_real_check (x, 0) == FAILURE)
1754     return FAILURE;
1755
1756   return SUCCESS;
1757 }
1758
1759
1760 gfc_try
1761 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1762 {
1763   if (type_check (x, 0, BT_REAL) == FAILURE)
1764     return FAILURE;
1765   if (same_type_check (x, 0, y, 1) == FAILURE)
1766     return FAILURE;
1767
1768   return SUCCESS;
1769 }
1770
1771
1772 /* Check that the single argument is an integer.  */
1773
1774 gfc_try
1775 gfc_check_i (gfc_expr *i)
1776 {
1777   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1778     return FAILURE;
1779
1780   return SUCCESS;
1781 }
1782
1783
1784 gfc_try
1785 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1786 {
1787   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1788     return FAILURE;
1789
1790   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1791     return FAILURE;
1792
1793   if (i->ts.kind != j->ts.kind)
1794     {
1795       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1796                           &i->where) == FAILURE)
1797         return FAILURE;
1798     }
1799
1800   return SUCCESS;
1801 }
1802
1803
1804 gfc_try
1805 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1806 {
1807   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1808     return FAILURE;
1809
1810   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1811     return FAILURE;
1812
1813   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1814     return FAILURE;
1815
1816   if (nonnegative_check ("pos", pos) == FAILURE)
1817     return FAILURE;
1818
1819   if (nonnegative_check ("len", len) == FAILURE)
1820     return FAILURE;
1821
1822   if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
1823     return FAILURE;
1824
1825   return SUCCESS;
1826 }
1827
1828
1829 gfc_try
1830 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1831 {
1832   int i;
1833
1834   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1835     return FAILURE;
1836
1837   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1838     return FAILURE;
1839
1840   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1841                               "with KIND argument at %L",
1842                               gfc_current_intrinsic, &kind->where) == FAILURE)
1843     return FAILURE;
1844
1845   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1846     {
1847       gfc_expr *start;
1848       gfc_expr *end;
1849       gfc_ref *ref;
1850
1851       /* Substring references don't have the charlength set.  */
1852       ref = c->ref;
1853       while (ref && ref->type != REF_SUBSTRING)
1854         ref = ref->next;
1855
1856       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1857
1858       if (!ref)
1859         {
1860           /* Check that the argument is length one.  Non-constant lengths
1861              can't be checked here, so assume they are ok.  */
1862           if (c->ts.u.cl && c->ts.u.cl->length)
1863             {
1864               /* If we already have a length for this expression then use it.  */
1865               if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1866                 return SUCCESS;
1867               i = mpz_get_si (c->ts.u.cl->length->value.integer);
1868             }
1869           else
1870             return SUCCESS;
1871         }
1872       else
1873         {
1874           start = ref->u.ss.start;
1875           end = ref->u.ss.end;
1876
1877           gcc_assert (start);
1878           if (end == NULL || end->expr_type != EXPR_CONSTANT
1879               || start->expr_type != EXPR_CONSTANT)
1880             return SUCCESS;
1881
1882           i = mpz_get_si (end->value.integer) + 1
1883             - mpz_get_si (start->value.integer);
1884         }
1885     }
1886   else
1887     return SUCCESS;
1888
1889   if (i != 1)
1890     {
1891       gfc_error ("Argument of %s at %L must be of length one",
1892                  gfc_current_intrinsic, &c->where);
1893       return FAILURE;
1894     }
1895
1896   return SUCCESS;
1897 }
1898
1899
1900 gfc_try
1901 gfc_check_idnint (gfc_expr *a)
1902 {
1903   if (double_check (a, 0) == FAILURE)
1904     return FAILURE;
1905
1906   return SUCCESS;
1907 }
1908
1909
1910 gfc_try
1911 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1912 {
1913   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1914     return FAILURE;
1915
1916   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1917     return FAILURE;
1918
1919   if (i->ts.kind != j->ts.kind)
1920     {
1921       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1922                           &i->where) == FAILURE)
1923         return FAILURE;
1924     }
1925
1926   return SUCCESS;
1927 }
1928
1929
1930 gfc_try
1931 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1932                  gfc_expr *kind)
1933 {
1934   if (type_check (string, 0, BT_CHARACTER) == FAILURE
1935       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1936     return FAILURE;
1937
1938   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1939     return FAILURE;
1940
1941   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1942     return FAILURE;
1943   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1944                               "with KIND argument at %L",
1945                               gfc_current_intrinsic, &kind->where) == FAILURE)
1946     return FAILURE;
1947
1948   if (string->ts.kind != substring->ts.kind)
1949     {
1950       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1951                  "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
1952                  gfc_current_intrinsic, &substring->where,
1953                  gfc_current_intrinsic_arg[0]->name);
1954       return FAILURE;
1955     }
1956
1957   return SUCCESS;
1958 }
1959
1960
1961 gfc_try
1962 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1963 {
1964   if (numeric_check (x, 0) == FAILURE)
1965     return FAILURE;
1966
1967   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1968     return FAILURE;
1969
1970   return SUCCESS;
1971 }
1972
1973
1974 gfc_try
1975 gfc_check_intconv (gfc_expr *x)
1976 {
1977   if (numeric_check (x, 0) == FAILURE)
1978     return FAILURE;
1979
1980   return SUCCESS;
1981 }
1982
1983
1984 gfc_try
1985 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1986 {
1987   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1988     return FAILURE;
1989
1990   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1991     return FAILURE;
1992
1993   if (i->ts.kind != j->ts.kind)
1994     {
1995       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1996                           &i->where) == FAILURE)
1997         return FAILURE;
1998     }
1999
2000   return SUCCESS;
2001 }
2002
2003
2004 gfc_try
2005 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
2006 {
2007   if (type_check (i, 0, BT_INTEGER) == FAILURE
2008       || type_check (shift, 1, BT_INTEGER) == FAILURE)
2009     return FAILURE;
2010
2011   if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
2012     return FAILURE;
2013
2014   return SUCCESS;
2015 }
2016
2017
2018 gfc_try
2019 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
2020 {
2021   if (type_check (i, 0, BT_INTEGER) == FAILURE
2022       || type_check (shift, 1, BT_INTEGER) == FAILURE)
2023     return FAILURE;
2024
2025   if (size != NULL)
2026     {
2027       int i2, i3;
2028
2029       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2030         return FAILURE;
2031
2032       if (less_than_bitsize1 ("I", i, "SIZE", size, true) == FAILURE)
2033         return FAILURE;
2034
2035       if (size->expr_type == EXPR_CONSTANT)
2036         {
2037           gfc_extract_int (size, &i3);
2038           if (i3 <= 0)
2039             {
2040               gfc_error ("SIZE at %L must be positive", &size->where);
2041               return FAILURE;
2042             }
2043
2044           if (shift->expr_type == EXPR_CONSTANT)
2045             {
2046               gfc_extract_int (shift, &i2);
2047               if (i2 < 0)
2048                 i2 = -i2;
2049
2050               if (i2 > i3)
2051                 {
2052                   gfc_error ("The absolute value of SHIFT at %L must be less "
2053                              "than or equal to SIZE at %L", &shift->where,
2054                              &size->where);
2055                   return FAILURE;
2056                 }
2057              }
2058         }
2059     }
2060   else if (less_than_bitsize1 ("I", i, NULL, shift, true) == FAILURE)
2061     return FAILURE;
2062
2063   return SUCCESS;
2064 }
2065
2066
2067 gfc_try
2068 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
2069 {
2070   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2071     return FAILURE;
2072
2073   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2074     return FAILURE;
2075
2076   return SUCCESS;
2077 }
2078
2079
2080 gfc_try
2081 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
2082 {
2083   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
2084     return FAILURE;
2085
2086   if (scalar_check (pid, 0) == FAILURE)
2087     return FAILURE;
2088
2089   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
2090     return FAILURE;
2091
2092   if (scalar_check (sig, 1) == FAILURE)
2093     return FAILURE;
2094
2095   if (status == NULL)
2096     return SUCCESS;
2097
2098   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2099     return FAILURE;
2100
2101   if (scalar_check (status, 2) == FAILURE)
2102     return FAILURE;
2103
2104   return SUCCESS;
2105 }
2106
2107
2108 gfc_try
2109 gfc_check_kind (gfc_expr *x)
2110 {
2111   if (x->ts.type == BT_DERIVED)
2112     {
2113       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
2114                  "non-derived type", gfc_current_intrinsic_arg[0]->name,
2115                  gfc_current_intrinsic, &x->where);
2116       return FAILURE;
2117     }
2118
2119   return SUCCESS;
2120 }
2121
2122
2123 gfc_try
2124 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2125 {
2126   if (array_check (array, 0) == FAILURE)
2127     return FAILURE;
2128
2129   if (dim_check (dim, 1, false) == FAILURE)
2130     return FAILURE;
2131
2132   if (dim_rank_check (dim, array, 1) == FAILURE)
2133     return FAILURE;
2134
2135   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2136     return FAILURE;
2137   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2138                               "with KIND argument at %L",
2139                               gfc_current_intrinsic, &kind->where) == FAILURE)
2140     return FAILURE;
2141
2142   return SUCCESS;
2143 }
2144
2145
2146 gfc_try
2147 gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
2148 {
2149   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2150     {
2151       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2152       return FAILURE;
2153     }
2154
2155   if (coarray_check (coarray, 0) == FAILURE)
2156     return FAILURE;
2157
2158   if (dim != NULL)
2159     {
2160       if (dim_check (dim, 1, false) == FAILURE)
2161         return FAILURE;
2162
2163       if (dim_corank_check (dim, coarray) == FAILURE)
2164         return FAILURE;
2165     }
2166
2167   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2168     return FAILURE;
2169
2170   return SUCCESS;
2171 }
2172
2173
2174 gfc_try
2175 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
2176 {
2177   if (type_check (s, 0, BT_CHARACTER) == FAILURE)
2178     return FAILURE;
2179
2180   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2181     return FAILURE;
2182   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2183                               "with KIND argument at %L",
2184                               gfc_current_intrinsic, &kind->where) == FAILURE)
2185     return FAILURE;
2186
2187   return SUCCESS;
2188 }
2189
2190
2191 gfc_try
2192 gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
2193 {
2194   if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2195     return FAILURE;
2196   if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
2197     return FAILURE;
2198
2199   if (type_check (b, 1, BT_CHARACTER) == FAILURE)
2200     return FAILURE;
2201   if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
2202     return FAILURE;
2203
2204   return SUCCESS;
2205 }
2206
2207
2208 gfc_try
2209 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
2210 {
2211   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2212     return FAILURE;
2213   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2214     return FAILURE;
2215
2216   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2217     return FAILURE;
2218   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2219     return FAILURE;
2220
2221   return SUCCESS;
2222 }
2223
2224
2225 gfc_try
2226 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2227 {
2228   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2229     return FAILURE;
2230   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2231     return FAILURE;
2232
2233   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2234     return FAILURE;
2235   if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
2236     return FAILURE;
2237
2238   if (status == NULL)
2239     return SUCCESS;
2240
2241   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2242     return FAILURE;
2243
2244   if (scalar_check (status, 2) == FAILURE)
2245     return FAILURE;
2246
2247   return SUCCESS;
2248 }
2249
2250
2251 gfc_try
2252 gfc_check_loc (gfc_expr *expr)
2253 {
2254   return variable_check (expr, 0, true);
2255 }
2256
2257
2258 gfc_try
2259 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
2260 {
2261   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2262     return FAILURE;
2263   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2264     return FAILURE;
2265
2266   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2267     return FAILURE;
2268   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2269     return FAILURE;
2270
2271   return SUCCESS;
2272 }
2273
2274
2275 gfc_try
2276 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2277 {
2278   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2279     return FAILURE;
2280   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
2281     return FAILURE;
2282
2283   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2284     return FAILURE;
2285   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
2286     return FAILURE;
2287
2288   if (status == NULL)
2289     return SUCCESS;
2290
2291   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2292     return FAILURE;
2293
2294   if (scalar_check (status, 2) == FAILURE)
2295     return FAILURE;
2296
2297   return SUCCESS;
2298 }
2299
2300
2301 gfc_try
2302 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
2303 {
2304   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
2305     return FAILURE;
2306   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
2307     return FAILURE;
2308
2309   return SUCCESS;
2310 }
2311
2312
2313 /* Min/max family.  */
2314
2315 static gfc_try
2316 min_max_args (gfc_actual_arglist *arg)
2317 {
2318   if (arg == NULL || arg->next == NULL)
2319     {
2320       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
2321                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2322       return FAILURE;
2323     }
2324
2325   return SUCCESS;
2326 }
2327
2328
2329 static gfc_try
2330 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
2331 {
2332   gfc_actual_arglist *arg, *tmp;
2333
2334   gfc_expr *x;
2335   int m, n;
2336
2337   if (min_max_args (arglist) == FAILURE)
2338     return FAILURE;
2339
2340   for (arg = arglist, n=1; arg; arg = arg->next, n++)
2341     {
2342       x = arg->expr;
2343       if (x->ts.type != type || x->ts.kind != kind)
2344         {
2345           if (x->ts.type == type)
2346             {
2347               if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
2348                                   "kinds at %L", &x->where) == FAILURE)
2349                 return FAILURE;
2350             }
2351           else
2352             {
2353               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
2354                          "%s(%d)", n, gfc_current_intrinsic, &x->where,
2355                          gfc_basic_typename (type), kind);
2356               return FAILURE;
2357             }
2358         }
2359
2360       for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
2361         if (gfc_check_conformance (tmp->expr, x,
2362                                    "arguments 'a%d' and 'a%d' for "
2363                                    "intrinsic '%s'", m, n,
2364                                    gfc_current_intrinsic) == FAILURE)
2365             return FAILURE;
2366     }
2367
2368   return SUCCESS;
2369 }
2370
2371
2372 gfc_try
2373 gfc_check_min_max (gfc_actual_arglist *arg)
2374 {
2375   gfc_expr *x;
2376
2377   if (min_max_args (arg) == FAILURE)
2378     return FAILURE;
2379
2380   x = arg->expr;
2381
2382   if (x->ts.type == BT_CHARACTER)
2383     {
2384       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2385                           "with CHARACTER argument at %L",
2386                           gfc_current_intrinsic, &x->where) == FAILURE)
2387         return FAILURE;
2388     }
2389   else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
2390     {
2391       gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
2392                  "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
2393       return FAILURE;
2394     }
2395
2396   return check_rest (x->ts.type, x->ts.kind, arg);
2397 }
2398
2399
2400 gfc_try
2401 gfc_check_min_max_integer (gfc_actual_arglist *arg)
2402 {
2403   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
2404 }
2405
2406
2407 gfc_try
2408 gfc_check_min_max_real (gfc_actual_arglist *arg)
2409 {
2410   return check_rest (BT_REAL, gfc_default_real_kind, arg);
2411 }
2412
2413
2414 gfc_try
2415 gfc_check_min_max_double (gfc_actual_arglist *arg)
2416 {
2417   return check_rest (BT_REAL, gfc_default_double_kind, arg);
2418 }
2419
2420
2421 /* End of min/max family.  */
2422
2423 gfc_try
2424 gfc_check_malloc (gfc_expr *size)
2425 {
2426   if (type_check (size, 0, BT_INTEGER) == FAILURE)
2427     return FAILURE;
2428
2429   if (scalar_check (size, 0) == FAILURE)
2430     return FAILURE;
2431
2432   return SUCCESS;
2433 }
2434
2435
2436 gfc_try
2437 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
2438 {
2439   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
2440     {
2441       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2442                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2443                  gfc_current_intrinsic, &matrix_a->where);
2444       return FAILURE;
2445     }
2446
2447   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
2448     {
2449       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
2450                  "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
2451                  gfc_current_intrinsic, &matrix_b->where);
2452       return FAILURE;
2453     }
2454
2455   if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
2456       || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
2457     {
2458       gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
2459                  gfc_current_intrinsic, &matrix_a->where,
2460                  gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
2461        return FAILURE;
2462     }
2463
2464   switch (matrix_a->rank)
2465     {
2466     case 1:
2467       if (rank_check (matrix_b, 1, 2) == FAILURE)
2468         return FAILURE;
2469       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
2470       if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
2471         {
2472           gfc_error ("Different shape on dimension 1 for arguments '%s' "
2473                      "and '%s' at %L for intrinsic matmul",
2474                      gfc_current_intrinsic_arg[0]->name,
2475                      gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2476           return FAILURE;
2477         }
2478       break;
2479
2480     case 2:
2481       if (matrix_b->rank != 2)
2482         {
2483           if (rank_check (matrix_b, 1, 1) == FAILURE)
2484             return FAILURE;
2485         }
2486       /* matrix_b has rank 1 or 2 here. Common check for the cases
2487          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
2488          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
2489       if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
2490         {
2491           gfc_error ("Different shape on dimension 2 for argument '%s' and "
2492                      "dimension 1 for argument '%s' at %L for intrinsic "
2493                      "matmul", gfc_current_intrinsic_arg[0]->name,
2494                      gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
2495           return FAILURE;
2496         }
2497       break;
2498
2499     default:
2500       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
2501                  "1 or 2", gfc_current_intrinsic_arg[0]->name,
2502                  gfc_current_intrinsic, &matrix_a->where);
2503       return FAILURE;
2504     }
2505
2506   return SUCCESS;
2507 }
2508
2509
2510 /* Whoever came up with this interface was probably on something.
2511    The possibilities for the occupation of the second and third
2512    parameters are:
2513
2514          Arg #2     Arg #3
2515          NULL       NULL
2516          DIM    NULL
2517          MASK       NULL
2518          NULL       MASK             minloc(array, mask=m)
2519          DIM    MASK
2520
2521    I.e. in the case of minloc(array,mask), mask will be in the second
2522    position of the argument list and we'll have to fix that up.  */
2523
2524 gfc_try
2525 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
2526 {
2527   gfc_expr *a, *m, *d;
2528
2529   a = ap->expr;
2530   if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
2531     return FAILURE;
2532
2533   d = ap->next->expr;
2534   m = ap->next->next->expr;
2535
2536   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2537       && ap->next->name == NULL)
2538     {
2539       m = d;
2540       d = NULL;
2541       ap->next->expr = NULL;
2542       ap->next->next->expr = m;
2543     }
2544
2545   if (dim_check (d, 1, false) == FAILURE)
2546     return FAILURE;
2547
2548   if (dim_rank_check (d, a, 0) == FAILURE)
2549     return FAILURE;
2550
2551   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2552     return FAILURE;
2553
2554   if (m != NULL
2555       && gfc_check_conformance (a, m,
2556                                 "arguments '%s' and '%s' for intrinsic %s",
2557                                 gfc_current_intrinsic_arg[0]->name,
2558                                 gfc_current_intrinsic_arg[2]->name,
2559                                 gfc_current_intrinsic ) == FAILURE)
2560     return FAILURE;
2561
2562   return SUCCESS;
2563 }
2564
2565
2566 /* Similar to minloc/maxloc, the argument list might need to be
2567    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
2568    difference is that MINLOC/MAXLOC take an additional KIND argument.
2569    The possibilities are:
2570
2571          Arg #2     Arg #3
2572          NULL       NULL
2573          DIM    NULL
2574          MASK       NULL
2575          NULL       MASK             minval(array, mask=m)
2576          DIM    MASK
2577
2578    I.e. in the case of minval(array,mask), mask will be in the second
2579    position of the argument list and we'll have to fix that up.  */
2580
2581 static gfc_try
2582 check_reduction (gfc_actual_arglist *ap)
2583 {
2584   gfc_expr *a, *m, *d;
2585
2586   a = ap->expr;
2587   d = ap->next->expr;
2588   m = ap->next->next->expr;
2589
2590   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
2591       && ap->next->name == NULL)
2592     {
2593       m = d;
2594       d = NULL;
2595       ap->next->expr = NULL;
2596       ap->next->next->expr = m;
2597     }
2598
2599   if (dim_check (d, 1, false) == FAILURE)
2600     return FAILURE;
2601
2602   if (dim_rank_check (d, a, 0) == FAILURE)
2603     return FAILURE;
2604
2605   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
2606     return FAILURE;
2607
2608   if (m != NULL
2609       && gfc_check_conformance (a, m,
2610                                 "arguments '%s' and '%s' for intrinsic %s",
2611                                 gfc_current_intrinsic_arg[0]->name,
2612                                 gfc_current_intrinsic_arg[2]->name,
2613                                 gfc_current_intrinsic) == FAILURE)
2614     return FAILURE;
2615
2616   return SUCCESS;
2617 }
2618
2619
2620 gfc_try
2621 gfc_check_minval_maxval (gfc_actual_arglist *ap)
2622 {
2623   if (int_or_real_check (ap->expr, 0) == FAILURE
2624       || array_check (ap->expr, 0) == FAILURE)
2625     return FAILURE;
2626
2627   return check_reduction (ap);
2628 }
2629
2630
2631 gfc_try
2632 gfc_check_product_sum (gfc_actual_arglist *ap)
2633 {
2634   if (numeric_check (ap->expr, 0) == FAILURE
2635       || array_check (ap->expr, 0) == FAILURE)
2636     return FAILURE;
2637
2638   return check_reduction (ap);
2639 }
2640
2641
2642 /* For IANY, IALL and IPARITY.  */
2643
2644 gfc_try
2645 gfc_check_mask (gfc_expr *i, gfc_expr *kind)
2646 {
2647   int k;
2648
2649   if (type_check (i, 0, BT_INTEGER) == FAILURE)
2650     return FAILURE;
2651
2652   if (nonnegative_check ("I", i) == FAILURE)
2653     return FAILURE;
2654
2655   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
2656     return FAILURE;
2657
2658   if (kind)
2659     gfc_extract_int (kind, &k);
2660   else
2661     k = gfc_default_integer_kind;
2662
2663   if (less_than_bitsizekind ("I", i, k) == FAILURE)
2664     return FAILURE;
2665
2666   return SUCCESS;
2667 }
2668
2669
2670 gfc_try
2671 gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
2672 {
2673   if (ap->expr->ts.type != BT_INTEGER)
2674     {
2675       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
2676                  gfc_current_intrinsic_arg[0]->name,
2677                  gfc_current_intrinsic, &ap->expr->where);
2678       return FAILURE;
2679     }
2680
2681   if (array_check (ap->expr, 0) == FAILURE)
2682     return FAILURE;
2683
2684   return check_reduction (ap);
2685 }
2686
2687
2688 gfc_try
2689 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2690 {
2691   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
2692     return FAILURE;
2693
2694   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
2695     return FAILURE;
2696
2697   if (tsource->ts.type == BT_CHARACTER)
2698     return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
2699
2700   return SUCCESS;
2701 }
2702
2703
2704 gfc_try
2705 gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
2706 {
2707   if (type_check (i, 0, BT_INTEGER) == FAILURE)
2708     return FAILURE;
2709
2710   if (type_check (j, 1, BT_INTEGER) == FAILURE)
2711     return FAILURE;
2712
2713   if (type_check (mask, 2, BT_INTEGER) == FAILURE)
2714     return FAILURE;
2715
2716   if (same_type_check (i, 0, j, 1) == FAILURE)
2717     return FAILURE;
2718
2719   if (same_type_check (i, 0, mask, 2) == FAILURE)
2720     return FAILURE;
2721
2722   return SUCCESS;
2723 }
2724
2725
2726 gfc_try
2727 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
2728 {
2729   if (variable_check (from, 0, false) == FAILURE)
2730     return FAILURE;
2731   if (allocatable_check (from, 0) == FAILURE)
2732     return FAILURE;
2733   if (gfc_is_coindexed (from))
2734     {
2735       gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
2736                  "coindexed", &from->where);
2737       return FAILURE;
2738     }
2739
2740   if (variable_check (to, 1, false) == FAILURE)
2741     return FAILURE;
2742   if (allocatable_check (to, 1) == FAILURE)
2743     return FAILURE;
2744   if (gfc_is_coindexed (to))
2745     {
2746       gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
2747                  "coindexed", &to->where);
2748       return FAILURE;
2749     }
2750
2751   if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
2752     {
2753       gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
2754                  "polymorphic if FROM is polymorphic",
2755                  &to->where);
2756       return FAILURE;
2757     }
2758
2759   if (same_type_check (to, 1, from, 0) == FAILURE)
2760     return FAILURE;
2761
2762   if (to->rank != from->rank)
2763     {
2764       gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2765                  "must have the same rank %d/%d", &to->where,  from->rank,
2766                  to->rank);
2767       return FAILURE;
2768     }
2769
2770   /* IR F08/0040; cf. 12-006A.  */
2771   if (gfc_get_corank (to) != gfc_get_corank (from))
2772     {
2773       gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
2774                  "must have the same corank %d/%d", &to->where,
2775                  gfc_get_corank (from), gfc_get_corank (to));
2776       return FAILURE;
2777     }
2778
2779   if (to->ts.kind != from->ts.kind)
2780     {
2781       gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L"
2782                  " must be of the same kind %d/%d", &to->where, from->ts.kind,
2783                  to->ts.kind);
2784       return FAILURE;
2785     }
2786
2787   /* CLASS arguments: Make sure the vtab of from is present.  */
2788   if (to->ts.type == BT_CLASS)
2789     gfc_find_derived_vtab (from->ts.u.derived);
2790
2791   return SUCCESS;
2792 }
2793
2794
2795 gfc_try
2796 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
2797 {
2798   if (type_check (x, 0, BT_REAL) == FAILURE)
2799     return FAILURE;
2800
2801   if (type_check (s, 1, BT_REAL) == FAILURE)
2802     return FAILURE;
2803
2804   if (s->expr_type == EXPR_CONSTANT)
2805     {
2806       if (mpfr_sgn (s->value.real) == 0)
2807         {
2808           gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
2809                      &s->where);
2810           return FAILURE;
2811         }
2812     }
2813
2814   return SUCCESS;
2815 }
2816
2817
2818 gfc_try
2819 gfc_check_new_line (gfc_expr *a)
2820 {
2821   if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2822     return FAILURE;
2823
2824   return SUCCESS;
2825 }
2826
2827
2828 gfc_try
2829 gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
2830 {
2831   if (type_check (array, 0, BT_REAL) == FAILURE)
2832     return FAILURE;
2833
2834   if (array_check (array, 0) == FAILURE)
2835     return FAILURE;
2836
2837   if (dim_rank_check (dim, array, false) == FAILURE)
2838     return FAILURE;
2839
2840   return SUCCESS;
2841 }
2842
2843 gfc_try
2844 gfc_check_null (gfc_expr *mold)
2845 {
2846   symbol_attribute attr;
2847
2848   if (mold == NULL)
2849     return SUCCESS;
2850
2851   if (variable_check (mold, 0, true) == FAILURE)
2852     return FAILURE;
2853
2854   attr = gfc_variable_attr (mold, NULL);
2855
2856   if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
2857     {
2858       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
2859                  "ALLOCATABLE or procedure pointer",
2860                  gfc_current_intrinsic_arg[0]->name,
2861                  gfc_current_intrinsic, &mold->where);
2862       return FAILURE;
2863     }
2864
2865   if (attr.allocatable
2866       && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with "
2867                          "allocatable MOLD at %L", &mold->where) == FAILURE)
2868     return FAILURE;
2869
2870   /* F2008, C1242.  */
2871   if (gfc_is_coindexed (mold))
2872     {
2873       gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
2874                  "coindexed", gfc_current_intrinsic_arg[0]->name,
2875                  gfc_current_intrinsic, &mold->where);
2876       return FAILURE;
2877     }
2878
2879   return SUCCESS;
2880 }
2881
2882
2883 gfc_try
2884 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2885 {
2886   if (array_check (array, 0) == FAILURE)
2887     return FAILURE;
2888
2889   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2890     return FAILURE;
2891
2892   if (gfc_check_conformance (array, mask,
2893                              "arguments '%s' and '%s' for intrinsic '%s'",
2894                              gfc_current_intrinsic_arg[0]->name,
2895                              gfc_current_intrinsic_arg[1]->name,
2896                              gfc_current_intrinsic) == FAILURE)
2897     return FAILURE;
2898
2899   if (vector != NULL)
2900     {
2901       mpz_t array_size, vector_size;
2902       bool have_array_size, have_vector_size;
2903
2904       if (same_type_check (array, 0, vector, 2) == FAILURE)
2905         return FAILURE;
2906
2907       if (rank_check (vector, 2, 1) == FAILURE)
2908         return FAILURE;
2909
2910       /* VECTOR requires at least as many elements as MASK
2911          has .TRUE. values.  */
2912       have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
2913       have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
2914
2915       if (have_vector_size
2916           && (mask->expr_type == EXPR_ARRAY
2917               || (mask->expr_type == EXPR_CONSTANT
2918                   && have_array_size)))
2919         {
2920           int mask_true_values = 0;
2921
2922           if (mask->expr_type == EXPR_ARRAY)
2923             {
2924               gfc_constructor *mask_ctor;
2925               mask_ctor = gfc_constructor_first (mask->value.constructor);
2926               while (mask_ctor)
2927                 {
2928                   if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
2929                     {
2930                       mask_true_values = 0;
2931                       break;
2932                     }
2933
2934                   if (mask_ctor->expr->value.logical)
2935                     mask_true_values++;
2936
2937                   mask_ctor = gfc_constructor_next (mask_ctor);
2938                 }
2939             }
2940           else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
2941             mask_true_values = mpz_get_si (array_size);
2942
2943           if (mpz_get_si (vector_size) < mask_true_values)
2944             {
2945               gfc_error ("'%s' argument of '%s' intrinsic at %L must "
2946                          "provide at least as many elements as there "
2947                          "are .TRUE. values in '%s' (%ld/%d)",
2948                          gfc_current_intrinsic_arg[2]->name,
2949                          gfc_current_intrinsic, &vector->where,
2950                          gfc_current_intrinsic_arg[1]->name,
2951                          mpz_get_si (vector_size), mask_true_values);
2952               return FAILURE;
2953             }
2954         }
2955
2956       if (have_array_size)
2957         mpz_clear (array_size);
2958       if (have_vector_size)
2959         mpz_clear (vector_size);
2960     }
2961
2962   return SUCCESS;
2963 }
2964
2965
2966 gfc_try
2967 gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
2968 {
2969   if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
2970     return FAILURE;
2971
2972   if (array_check (mask, 0) == FAILURE)
2973     return FAILURE;
2974
2975   if (dim_rank_check (dim, mask, false) == FAILURE)
2976     return FAILURE;
2977
2978   return SUCCESS;
2979 }
2980
2981
2982 gfc_try
2983 gfc_check_precision (gfc_expr *x)
2984 {
2985   if (real_or_complex_check (x, 0) == FAILURE)
2986     return FAILURE;
2987
2988   return SUCCESS;
2989 }
2990
2991
2992 gfc_try
2993 gfc_check_present (gfc_expr *a)
2994 {
2995   gfc_symbol *sym;
2996
2997   if (variable_check (a, 0, true) == FAILURE)
2998     return FAILURE;
2999
3000   sym = a->symtree->n.sym;
3001   if (!sym->attr.dummy)
3002     {
3003       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
3004                  "dummy variable", gfc_current_intrinsic_arg[0]->name,
3005                  gfc_current_intrinsic, &a->where);
3006       return FAILURE;
3007     }
3008
3009   if (!sym->attr.optional)
3010     {
3011       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
3012                  "an OPTIONAL dummy variable",
3013                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3014                  &a->where);
3015       return FAILURE;
3016     }
3017
3018   /* 13.14.82  PRESENT(A)
3019      ......
3020      Argument.  A shall be the name of an optional dummy argument that is
3021      accessible in the subprogram in which the PRESENT function reference
3022      appears...  */
3023
3024   if (a->ref != NULL
3025       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
3026            && (a->ref->u.ar.type == AR_FULL
3027                || (a->ref->u.ar.type == AR_ELEMENT
3028                    && a->ref->u.ar.as->rank == 0))))
3029     {
3030       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
3031                  "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
3032                  gfc_current_intrinsic, &a->where, sym->name);
3033       return FAILURE;
3034     }
3035
3036   return SUCCESS;
3037 }
3038
3039
3040 gfc_try
3041 gfc_check_radix (gfc_expr *x)
3042 {
3043   if (int_or_real_check (x, 0) == FAILURE)
3044     return FAILURE;
3045
3046   return SUCCESS;
3047 }
3048
3049
3050 gfc_try
3051 gfc_check_range (gfc_expr *x)
3052 {
3053   if (numeric_check (x, 0) == FAILURE)
3054     return FAILURE;
3055
3056   return SUCCESS;
3057 }
3058
3059
3060 gfc_try
3061 gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
3062 {
3063   /* Any data object is allowed; a "data object" is a "constant (4.1.3),
3064      variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45).  */
3065
3066   bool is_variable = true;
3067
3068   /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
3069   if (a->expr_type == EXPR_FUNCTION)
3070     is_variable = a->value.function.esym
3071                   ? a->value.function.esym->result->attr.pointer
3072                   : a->symtree->n.sym->result->attr.pointer;
3073
3074   if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL
3075       || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC
3076       || !is_variable)
3077     {
3078       gfc_error ("The argument of the RANK intrinsic at %L must be a data "
3079                  "object", &a->where);
3080       return FAILURE;
3081     }
3082
3083   return SUCCESS;
3084 }
3085
3086
3087 /* real, float, sngl.  */
3088 gfc_try
3089 gfc_check_real (gfc_expr *a, gfc_expr *kind)
3090 {
3091   if (numeric_check (a, 0) == FAILURE)
3092     return FAILURE;
3093
3094   if (kind_check (kind, 1, BT_REAL) == FAILURE)
3095     return FAILURE;
3096
3097   return SUCCESS;
3098 }
3099
3100
3101 gfc_try
3102 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
3103 {
3104   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3105     return FAILURE;
3106   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3107     return FAILURE;
3108
3109   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3110     return FAILURE;
3111   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3112     return FAILURE;
3113
3114   return SUCCESS;
3115 }
3116
3117
3118 gfc_try
3119 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3120 {
3121   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
3122     return FAILURE;
3123   if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
3124     return FAILURE;
3125
3126   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
3127     return FAILURE;
3128   if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
3129     return FAILURE;
3130
3131   if (status == NULL)
3132     return SUCCESS;
3133
3134   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3135     return FAILURE;
3136
3137   if (scalar_check (status, 2) == FAILURE)
3138     return FAILURE;
3139
3140   return SUCCESS;
3141 }
3142
3143
3144 gfc_try
3145 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
3146 {
3147   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3148     return FAILURE;
3149
3150   if (scalar_check (x, 0) == FAILURE)
3151     return FAILURE;
3152
3153   if (type_check (y, 0, BT_INTEGER) == FAILURE)
3154     return FAILURE;
3155
3156   if (scalar_check (y, 1) == FAILURE)
3157     return FAILURE;
3158
3159   return SUCCESS;
3160 }
3161
3162
3163 gfc_try
3164 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
3165                    gfc_expr *pad, gfc_expr *order)
3166 {
3167   mpz_t size;
3168   mpz_t nelems;
3169   int shape_size;
3170
3171   if (array_check (source, 0) == FAILURE)
3172     return FAILURE;
3173
3174   if (rank_check (shape, 1, 1) == FAILURE)
3175     return FAILURE;
3176
3177   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
3178     return FAILURE;
3179
3180   if (gfc_array_size (shape, &size) != SUCCESS)
3181     {
3182       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
3183                  "array of constant size", &shape->where);
3184       return FAILURE;
3185     }
3186
3187   shape_size = mpz_get_ui (size);
3188   mpz_clear (size);
3189
3190   if (shape_size <= 0)
3191     {
3192       gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
3193                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3194                  &shape->where);
3195       return FAILURE;
3196     }
3197   else if (shape_size > GFC_MAX_DIMENSIONS)
3198     {
3199       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
3200                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
3201       return FAILURE;
3202     }
3203   else if (shape->expr_type == EXPR_ARRAY)
3204     {
3205       gfc_expr *e;
3206       int i, extent;
3207       for (i = 0; i < shape_size; ++i)
3208         {
3209           e = gfc_constructor_lookup_expr (shape->value.constructor, i);
3210           if (e->expr_type != EXPR_CONSTANT)
3211             continue;
3212
3213           gfc_extract_int (e, &extent);
3214           if (extent < 0)
3215             {
3216               gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3217                          "negative element (%d)",
3218                          gfc_current_intrinsic_arg[1]->name,
3219                          gfc_current_intrinsic, &e->where, extent);
3220               return FAILURE;
3221             }
3222         }
3223     }
3224
3225   if (pad != NULL)
3226     {
3227       if (same_type_check (source, 0, pad, 2) == FAILURE)
3228         return FAILURE;
3229
3230       if (array_check (pad, 2) == FAILURE)
3231         return FAILURE;
3232     }
3233
3234   if (order != NULL)
3235     {
3236       if (array_check (order, 3) == FAILURE)
3237         return FAILURE;
3238
3239       if (type_check (order, 3, BT_INTEGER) == FAILURE)
3240         return FAILURE;
3241
3242       if (order->expr_type == EXPR_ARRAY)
3243         {
3244           int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
3245           gfc_expr *e;
3246
3247           for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
3248             perm[i] = 0;
3249
3250           gfc_array_size (order, &size);
3251           order_size = mpz_get_ui (size);
3252           mpz_clear (size);
3253
3254           if (order_size != shape_size)
3255             {
3256               gfc_error ("'%s' argument of '%s' intrinsic at %L "
3257                          "has wrong number of elements (%d/%d)",
3258                          gfc_current_intrinsic_arg[3]->name,
3259                          gfc_current_intrinsic, &order->where,
3260                          order_size, shape_size);
3261               return FAILURE;
3262             }
3263
3264           for (i = 1; i <= order_size; ++i)
3265             {
3266               e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
3267               if (e->expr_type != EXPR_CONSTANT)
3268                 continue;
3269
3270               gfc_extract_int (e, &dim);
3271
3272               if (dim < 1 || dim > order_size)
3273                 {
3274                   gfc_error ("'%s' argument of '%s' intrinsic at %L "
3275                              "has out-of-range dimension (%d)",
3276                              gfc_current_intrinsic_arg[3]->name,
3277                              gfc_current_intrinsic, &e->where, dim);
3278                   return FAILURE;
3279                 }
3280
3281               if (perm[dim-1] != 0)
3282                 {
3283                   gfc_error ("'%s' argument of '%s' intrinsic at %L has "
3284                              "invalid permutation of dimensions (dimension "
3285                              "'%d' duplicated)",
3286                              gfc_current_intrinsic_arg[3]->name,
3287                              gfc_current_intrinsic, &e->where, dim);
3288                   return FAILURE;
3289                 }
3290
3291               perm[dim-1] = 1;
3292             }
3293         }
3294     }
3295
3296   if (pad == NULL && shape->expr_type == EXPR_ARRAY
3297       && gfc_is_constant_expr (shape)
3298       && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
3299            && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
3300     {
3301       /* Check the match in size between source and destination.  */
3302       if (gfc_array_size (source, &nelems) == SUCCESS)
3303         {
3304           gfc_constructor *c;
3305           bool test;
3306
3307
3308           mpz_init_set_ui (size, 1);
3309           for (c = gfc_constructor_first (shape->value.constructor);
3310                c; c = gfc_constructor_next (c))
3311             mpz_mul (size, size, c->expr->value.integer);
3312
3313           test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
3314           mpz_clear (nelems);
3315           mpz_clear (size);
3316
3317           if (test)
3318             {
3319               gfc_error ("Without padding, there are not enough elements "
3320                          "in the intrinsic RESHAPE source at %L to match "
3321                          "the shape", &source->where);
3322               return FAILURE;
3323             }
3324         }
3325     }
3326
3327   return SUCCESS;
3328 }
3329
3330
3331 gfc_try
3332 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
3333 {
3334
3335   if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
3336     {
3337       gfc_error ("'%s' argument of '%s' intrinsic at %L "
3338                  "must be of a derived type",
3339                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3340                  &a->where);
3341       return FAILURE;
3342     }
3343
3344   if (!gfc_type_is_extensible (a->ts.u.derived))
3345     {
3346       gfc_error ("'%s' argument of '%s' intrinsic at %L "
3347                  "must be of an extensible type",
3348                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3349                  &a->where);
3350       return FAILURE;
3351     }
3352
3353   if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
3354     {
3355       gfc_error ("'%s' argument of '%s' intrinsic at %L "
3356                  "must be of a derived type",
3357                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3358                  &b->where);
3359       return FAILURE;
3360     }
3361
3362   if (!gfc_type_is_extensible (b->ts.u.derived))
3363     {
3364       gfc_error ("'%s' argument of '%s' intrinsic at %L "
3365                  "must be of an extensible type",
3366                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
3367                  &b->where);
3368       return FAILURE;
3369     }
3370
3371   return SUCCESS;
3372 }
3373
3374
3375 gfc_try
3376 gfc_check_scale (gfc_expr *x, gfc_expr *i)
3377 {
3378   if (type_check (x, 0, BT_REAL) == FAILURE)
3379     return FAILURE;
3380
3381   if (type_check (i, 1, BT_INTEGER) == FAILURE)
3382     return FAILURE;
3383
3384   return SUCCESS;
3385 }
3386
3387
3388 gfc_try
3389 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
3390 {
3391   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
3392     return FAILURE;
3393
3394   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
3395     return FAILURE;
3396
3397   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
3398     return FAILURE;
3399
3400   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
3401     return FAILURE;
3402   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3403                               "with KIND argument at %L",
3404                               gfc_current_intrinsic, &kind->where) == FAILURE)
3405     return FAILURE;
3406
3407   if (same_type_check (x, 0, y, 1) == FAILURE)
3408     return FAILURE;
3409
3410   return SUCCESS;
3411 }
3412
3413
3414 gfc_try
3415 gfc_check_secnds (gfc_expr *r)
3416 {
3417   if (type_check (r, 0, BT_REAL) == FAILURE)
3418     return FAILURE;
3419
3420   if (kind_value_check (r, 0, 4) == FAILURE)
3421     return FAILURE;
3422
3423   if (scalar_check (r, 0) == FAILURE)
3424     return FAILURE;
3425
3426   return SUCCESS;
3427 }
3428
3429
3430 gfc_try
3431 gfc_check_selected_char_kind (gfc_expr *name)
3432 {
3433   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3434     return FAILURE;
3435
3436   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3437     return FAILURE;
3438
3439   if (scalar_check (name, 0) == FAILURE)
3440     return FAILURE;
3441
3442   return SUCCESS;
3443 }
3444
3445
3446 gfc_try
3447 gfc_check_selected_int_kind (gfc_expr *r)
3448 {
3449   if (type_check (r, 0, BT_INTEGER) == FAILURE)
3450     return FAILURE;
3451
3452   if (scalar_check (r, 0) == FAILURE)
3453     return FAILURE;
3454
3455   return SUCCESS;
3456 }
3457
3458
3459 gfc_try
3460 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
3461 {
3462   if (p == NULL && r == NULL
3463       && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
3464                          " neither 'P' nor 'R' argument at %L",
3465                          gfc_current_intrinsic_where) == FAILURE)
3466     return FAILURE;
3467
3468   if (p)
3469     {
3470       if (type_check (p, 0, BT_INTEGER) == FAILURE)
3471         return FAILURE;
3472
3473       if (scalar_check (p, 0) == FAILURE)
3474         return FAILURE;
3475     }
3476
3477   if (r)
3478     {
3479       if (type_check (r, 1, BT_INTEGER) == FAILURE)
3480         return FAILURE;
3481
3482       if (scalar_check (r, 1) == FAILURE)
3483         return FAILURE;
3484     }
3485
3486   if (radix)
3487     {
3488       if (type_check (radix, 1, BT_INTEGER) == FAILURE)
3489         return FAILURE;
3490
3491       if (scalar_check (radix, 1) == FAILURE)
3492         return FAILURE;
3493
3494       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
3495                           "RADIX argument at %L", gfc_current_intrinsic,
3496                           &radix->where) == FAILURE)
3497         return FAILURE;
3498     }
3499
3500   return SUCCESS;
3501 }
3502
3503
3504 gfc_try
3505 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
3506 {
3507   if (type_check (x, 0, BT_REAL) == FAILURE)
3508     return FAILURE;
3509
3510   if (type_check (i, 1, BT_INTEGER) == FAILURE)
3511     return FAILURE;
3512
3513   return SUCCESS;
3514 }
3515
3516
3517 gfc_try
3518 gfc_check_shape (gfc_expr *source, gfc_expr *kind)
3519 {
3520   gfc_array_ref *ar;
3521
3522   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3523     return SUCCESS;
3524
3525   ar = gfc_find_array_ref (source);
3526
3527   if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
3528     {
3529       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
3530                  "an assumed size array", &source->where);
3531       return FAILURE;
3532     }
3533
3534   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
3535     return FAILURE;
3536   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3537                               "with KIND argument at %L",
3538                               gfc_current_intrinsic, &kind->where) == FAILURE)
3539     return FAILURE;
3540
3541   return SUCCESS;
3542 }
3543
3544
3545 gfc_try
3546 gfc_check_shift (gfc_expr *i, gfc_expr *shift)
3547 {
3548   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3549     return FAILURE;
3550
3551   if (type_check (shift, 0, BT_INTEGER) == FAILURE)
3552     return FAILURE;
3553
3554   if (nonnegative_check ("SHIFT", shift) == FAILURE)
3555     return FAILURE;
3556
3557   if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
3558     return FAILURE;
3559
3560   return SUCCESS;
3561 }
3562
3563
3564 gfc_try
3565 gfc_check_sign (gfc_expr *a, gfc_expr *b)
3566 {
3567   if (int_or_real_check (a, 0) == FAILURE)
3568     return FAILURE;
3569
3570   if (same_type_check (a, 0, b, 1) == FAILURE)
3571     return FAILURE;
3572
3573   return SUCCESS;
3574 }
3575
3576
3577 gfc_try
3578 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3579 {
3580   if (array_check (array, 0) == FAILURE)
3581     return FAILURE;
3582
3583   if (dim_check (dim, 1, true) == FAILURE)
3584     return FAILURE;
3585
3586   if (dim_rank_check (dim, array, 0) == FAILURE)
3587     return FAILURE;
3588
3589   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
3590     return FAILURE;
3591   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
3592                               "with KIND argument at %L",
3593                               gfc_current_intrinsic, &kind->where) == FAILURE)
3594     return FAILURE;
3595
3596
3597   return SUCCESS;
3598 }
3599
3600
3601 gfc_try
3602 gfc_check_sizeof (gfc_expr *arg)
3603 {
3604   if (arg->ts.type == BT_PROCEDURE)
3605     {
3606       gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
3607                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3608                  &arg->where);
3609       return FAILURE;
3610     }
3611   return SUCCESS;
3612 }
3613
3614
3615 gfc_try
3616 gfc_check_c_sizeof (gfc_expr *arg)
3617 {
3618   if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
3619     {
3620       gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
3621                  "interoperable data entity",
3622                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3623                  &arg->where);
3624       return FAILURE;
3625     }
3626   return SUCCESS;
3627 }
3628
3629
3630 gfc_try
3631 gfc_check_sleep_sub (gfc_expr *seconds)
3632 {
3633   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3634     return FAILURE;
3635
3636   if (scalar_check (seconds, 0) == FAILURE)
3637     return FAILURE;
3638
3639   return SUCCESS;
3640 }
3641
3642 gfc_try
3643 gfc_check_sngl (gfc_expr *a)
3644 {
3645   if (type_check (a, 0, BT_REAL) == FAILURE)
3646     return FAILURE;
3647
3648   if ((a->ts.kind != gfc_default_double_kind)
3649       && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision "
3650                          "REAL argument to %s intrinsic at %L",
3651                          gfc_current_intrinsic, &a->where) == FAILURE)
3652     return FAILURE;
3653
3654   return SUCCESS;
3655 }
3656
3657 gfc_try
3658 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
3659 {
3660   if (source->rank >= GFC_MAX_DIMENSIONS)
3661     {
3662       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
3663                  "than rank %d", gfc_current_intrinsic_arg[0]->name,
3664                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
3665
3666       return FAILURE;
3667     }
3668
3669   if (dim == NULL)
3670     return FAILURE;
3671
3672   if (dim_check (dim, 1, false) == FAILURE)
3673     return FAILURE;
3674
3675   /* dim_rank_check() does not apply here.  */
3676   if (dim
3677       && dim->expr_type == EXPR_CONSTANT
3678       && (mpz_cmp_ui (dim->value.integer, 1) < 0
3679           || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
3680     {
3681       gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
3682                  "dimension index", gfc_current_intrinsic_arg[1]->name,
3683                  gfc_current_intrinsic, &dim->where);
3684       return FAILURE;
3685     }
3686
3687   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
3688     return FAILURE;
3689
3690   if (scalar_check (ncopies, 2) == FAILURE)
3691     return FAILURE;
3692
3693   return SUCCESS;
3694 }
3695
3696
3697 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
3698    functions).  */
3699
3700 gfc_try
3701 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
3702 {
3703   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3704     return FAILURE;
3705
3706   if (scalar_check (unit, 0) == FAILURE)
3707     return FAILURE;
3708
3709   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
3710     return FAILURE;
3711   if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
3712     return FAILURE;
3713
3714   if (status == NULL)
3715     return SUCCESS;
3716
3717   if (type_check (status, 2, BT_INTEGER) == FAILURE
3718       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
3719       || scalar_check (status, 2) == FAILURE)
3720     return FAILURE;
3721
3722   return SUCCESS;
3723 }
3724
3725
3726 gfc_try
3727 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
3728 {
3729   return gfc_check_fgetputc_sub (unit, c, NULL);
3730 }
3731
3732
3733 gfc_try
3734 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
3735 {
3736   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
3737     return FAILURE;
3738   if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
3739     return FAILURE;
3740
3741   if (status == NULL)
3742     return SUCCESS;
3743
3744   if (type_check (status, 1, BT_INTEGER) == FAILURE
3745       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
3746       || scalar_check (status, 1) == FAILURE)
3747     return FAILURE;
3748
3749   return SUCCESS;
3750 }
3751
3752
3753 gfc_try
3754 gfc_check_fgetput (gfc_expr *c)
3755 {
3756   return gfc_check_fgetput_sub (c, NULL);
3757 }
3758
3759
3760 gfc_try
3761 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
3762 {
3763   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3764     return FAILURE;
3765
3766   if (scalar_check (unit, 0) == FAILURE)
3767     return FAILURE;
3768
3769   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3770     return FAILURE;
3771
3772   if (scalar_check (offset, 1) == FAILURE)
3773     return FAILURE;
3774
3775   if (type_check (whence, 2, BT_INTEGER) == FAILURE)
3776     return FAILURE;
3777
3778   if (scalar_check (whence, 2) == FAILURE)
3779     return FAILURE;
3780
3781   if (status == NULL)
3782     return SUCCESS;
3783
3784   if (type_check (status, 3, BT_INTEGER) == FAILURE)
3785     return FAILURE;
3786
3787   if (kind_value_check (status, 3, 4) == FAILURE)
3788     return FAILURE;
3789
3790   if (scalar_check (status, 3) == FAILURE)
3791     return FAILURE;
3792
3793   return SUCCESS;
3794 }
3795
3796
3797
3798 gfc_try
3799 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
3800 {
3801   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3802     return FAILURE;
3803
3804   if (scalar_check (unit, 0) == FAILURE)
3805     return FAILURE;
3806
3807   if (type_check (array, 1, BT_INTEGER) == FAILURE
3808       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
3809     return FAILURE;
3810
3811   if (array_check (array, 1) == FAILURE)
3812     return FAILURE;
3813
3814   return SUCCESS;
3815 }
3816
3817
3818 gfc_try
3819 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
3820 {
3821   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3822     return FAILURE;
3823
3824   if (scalar_check (unit, 0) == FAILURE)
3825     return FAILURE;
3826
3827   if (type_check (array, 1, BT_INTEGER) == FAILURE
3828       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3829     return FAILURE;
3830
3831   if (array_check (array, 1) == FAILURE)
3832     return FAILURE;
3833
3834   if (status == NULL)
3835     return SUCCESS;
3836
3837   if (type_check (status, 2, BT_INTEGER) == FAILURE
3838       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3839     return FAILURE;
3840
3841   if (scalar_check (status, 2) == FAILURE)
3842     return FAILURE;
3843
3844   return SUCCESS;
3845 }
3846
3847
3848 gfc_try
3849 gfc_check_ftell (gfc_expr *unit)
3850 {
3851   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3852     return FAILURE;
3853
3854   if (scalar_check (unit, 0) == FAILURE)
3855     return FAILURE;
3856
3857   return SUCCESS;
3858 }
3859
3860
3861 gfc_try
3862 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
3863 {
3864   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3865     return FAILURE;
3866
3867   if (scalar_check (unit, 0) == FAILURE)
3868     return FAILURE;
3869
3870   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
3871     return FAILURE;
3872
3873   if (scalar_check (offset, 1) == FAILURE)
3874     return FAILURE;
3875
3876   return SUCCESS;
3877 }
3878
3879
3880 gfc_try
3881 gfc_check_stat (gfc_expr *name, gfc_expr *array)
3882 {
3883   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3884     return FAILURE;
3885   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3886     return FAILURE;
3887
3888   if (type_check (array, 1, BT_INTEGER) == FAILURE
3889       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3890     return FAILURE;
3891
3892   if (array_check (array, 1) == FAILURE)
3893     return FAILURE;
3894
3895   return SUCCESS;
3896 }
3897
3898
3899 gfc_try
3900 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
3901 {
3902   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3903     return FAILURE;
3904   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
3905     return FAILURE;
3906
3907   if (type_check (array, 1, BT_INTEGER) == FAILURE
3908       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3909     return FAILURE;
3910
3911   if (array_check (array, 1) == FAILURE)
3912     return FAILURE;
3913
3914   if (status == NULL)
3915     return SUCCESS;
3916
3917   if (type_check (status, 2, BT_INTEGER) == FAILURE
3918       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
3919     return FAILURE;
3920
3921   if (scalar_check (status, 2) == FAILURE)
3922     return FAILURE;
3923
3924   return SUCCESS;
3925 }
3926
3927
3928 gfc_try
3929 gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
3930 {
3931   mpz_t nelems;
3932
3933   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3934     {
3935       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3936       return FAILURE;
3937     }
3938
3939   if (coarray_check (coarray, 0) == FAILURE)
3940     return FAILURE;
3941
3942   if (sub->rank != 1)
3943     {
3944       gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
3945                 gfc_current_intrinsic_arg[1]->name, &sub->where);
3946       return FAILURE;
3947     }
3948
3949   if (gfc_array_size (sub, &nelems) == SUCCESS)
3950     {
3951       int corank = gfc_get_corank (coarray);
3952
3953       if (mpz_cmp_ui (nelems, corank) != 0)
3954         {
3955           gfc_error ("The number of array elements of the SUB argument to "
3956                      "IMAGE_INDEX at %L shall be %d (corank) not %d",
3957                      &sub->where, corank, (int) mpz_get_si (nelems));
3958           mpz_clear (nelems);
3959           return FAILURE;
3960         }
3961       mpz_clear (nelems);
3962     }
3963
3964   return SUCCESS;
3965 }
3966
3967
3968 gfc_try
3969 gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
3970 {
3971   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3972     {
3973       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3974       return FAILURE;
3975     }
3976
3977   if (dim != NULL &&  coarray == NULL)
3978     {
3979       gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
3980                 "intrinsic at %L", &dim->where);
3981       return FAILURE;
3982     }
3983
3984   if (coarray == NULL)
3985     return SUCCESS;
3986
3987   if (coarray_check (coarray, 0) == FAILURE)
3988     return FAILURE;
3989
3990   if (dim != NULL)
3991     {
3992       if (dim_check (dim, 1, false) == FAILURE)
3993        return FAILURE;
3994
3995       if (dim_corank_check (dim, coarray) == FAILURE)
3996        return FAILURE;
3997     }
3998
3999   return SUCCESS;
4000 }
4001
4002 /* Calculate the sizes for transfer, used by gfc_check_transfer and also
4003    by gfc_simplify_transfer.  Return FAILURE if we cannot do so.  */
4004
4005 gfc_try
4006 gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
4007                               size_t *source_size, size_t *result_size,
4008                               size_t *result_length_p)
4009 {
4010   size_t result_elt_size;
4011   mpz_t tmp;
4012   gfc_expr *mold_element;
4013
4014   if (source->expr_type == EXPR_FUNCTION)
4015     return FAILURE;
4016
4017   if (size && size->expr_type != EXPR_CONSTANT)
4018     return FAILURE;
4019
4020   /* Calculate the size of the source.  */
4021   if (source->expr_type == EXPR_ARRAY
4022       && gfc_array_size (source, &tmp) == FAILURE)
4023     return FAILURE;
4024
4025   *source_size = gfc_target_expr_size (source);
4026   if (*source_size == 0)
4027     return FAILURE;
4028
4029   mold_element = mold->expr_type == EXPR_ARRAY
4030                  ? gfc_constructor_first (mold->value.constructor)->expr
4031                  : mold;
4032
4033   /* Determine the size of the element.  */
4034   result_elt_size = gfc_target_expr_size (mold_element);
4035   if (result_elt_size == 0)
4036     return FAILURE;
4037
4038   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4039     {
4040       int result_length;
4041
4042       if (size)
4043         result_length = (size_t)mpz_get_ui (size->value.integer);
4044       else
4045         {
4046           result_length = *source_size / result_elt_size;
4047           if (result_length * result_elt_size < *source_size)
4048             result_length += 1;
4049         }
4050
4051       *result_size = result_length * result_elt_size;
4052       if (result_length_p)
4053         *result_length_p = result_length;
4054     }
4055   else
4056     *result_size = result_elt_size;
4057
4058   return SUCCESS;
4059 }
4060
4061
4062 gfc_try
4063 gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4064 {
4065   size_t source_size;
4066   size_t result_size;
4067
4068   if (mold->ts.type == BT_HOLLERITH)
4069     {
4070       gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
4071                  &mold->where, gfc_basic_typename (BT_HOLLERITH));
4072       return FAILURE;
4073     }
4074
4075   if (size != NULL)
4076     {
4077       if (type_check (size, 2, BT_INTEGER) == FAILURE)
4078         return FAILURE;
4079
4080       if (scalar_check (size, 2) == FAILURE)
4081         return FAILURE;
4082
4083       if (nonoptional_check (size, 2) == FAILURE)
4084         return FAILURE;
4085     }
4086
4087   if (!gfc_option.warn_surprising)
4088     return SUCCESS;
4089
4090   /* If we can't calculate the sizes, we cannot check any more.
4091      Return SUCCESS for that case.  */
4092
4093   if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
4094                                     &result_size, NULL) == FAILURE)
4095     return SUCCESS;
4096
4097   if (source_size < result_size)
4098     gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4099                 "source size %ld < result size %ld", &source->where,
4100                 (long) source_size, (long) result_size);
4101
4102   return SUCCESS;
4103 }
4104
4105
4106 gfc_try
4107 gfc_check_transpose (gfc_expr *matrix)
4108 {
4109   if (rank_check (matrix, 0, 2) == FAILURE)
4110     return FAILURE;
4111
4112   return SUCCESS;
4113 }
4114
4115
4116 gfc_try
4117 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4118 {
4119   if (array_check (array, 0) == FAILURE)
4120     return FAILURE;
4121
4122   if (dim_check (dim, 1, false) == FAILURE)
4123     return FAILURE;
4124
4125   if (dim_rank_check (dim, array, 0) == FAILURE)
4126     return FAILURE;
4127
4128   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4129     return FAILURE;
4130   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4131                               "with KIND argument at %L",
4132                               gfc_current_intrinsic, &kind->where) == FAILURE)
4133     return FAILURE;
4134
4135   return SUCCESS;
4136 }
4137
4138
4139 gfc_try
4140 gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
4141 {
4142   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4143     {
4144       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4145       return FAILURE;
4146     }
4147
4148   if (coarray_check (coarray, 0) == FAILURE)
4149     return FAILURE;
4150
4151   if (dim != NULL)
4152     {
4153       if (dim_check (dim, 1, false) == FAILURE)
4154         return FAILURE;
4155
4156       if (dim_corank_check (dim, coarray) == FAILURE)
4157         return FAILURE;
4158     }
4159
4160   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
4161     return FAILURE;
4162
4163   return SUCCESS;
4164 }
4165
4166
4167 gfc_try
4168 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
4169 {
4170   mpz_t vector_size;
4171
4172   if (rank_check (vector, 0, 1) == FAILURE)
4173     return FAILURE;
4174
4175   if (array_check (mask, 1) == FAILURE)
4176     return FAILURE;
4177
4178   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
4179     return FAILURE;
4180
4181   if (same_type_check (vector, 0, field, 2) == FAILURE)
4182     return FAILURE;
4183
4184   if (mask->expr_type == EXPR_ARRAY
4185       && gfc_array_size (vector, &vector_size) == SUCCESS)
4186     {
4187       int mask_true_count = 0;
4188       gfc_constructor *mask_ctor;
4189       mask_ctor = gfc_constructor_first (mask->value.constructor);
4190       while (mask_ctor)
4191         {
4192           if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4193             {
4194               mask_true_count = 0;
4195               break;
4196             }
4197
4198           if (mask_ctor->expr->value.logical)
4199             mask_true_count++;
4200
4201           mask_ctor = gfc_constructor_next (mask_ctor);
4202         }
4203
4204       if (mpz_get_si (vector_size) < mask_true_count)
4205         {
4206           gfc_error ("'%s' argument of '%s' intrinsic at %L must "
4207                      "provide at least as many elements as there "
4208                      "are .TRUE. values in '%s' (%ld/%d)",
4209                      gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4210                      &vector->where, gfc_current_intrinsic_arg[1]->name,
4211                      mpz_get_si (vector_size), mask_true_count);
4212           return FAILURE;
4213         }
4214
4215       mpz_clear (vector_size);
4216     }
4217
4218   if (mask->rank != field->rank && field->rank != 0)
4219     {
4220       gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
4221                  "the same rank as '%s' or be a scalar",
4222                  gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4223                  &field->where, gfc_current_intrinsic_arg[1]->name);
4224       return FAILURE;
4225     }
4226
4227   if (mask->rank == field->rank)
4228     {
4229       int i;
4230       for (i = 0; i < field->rank; i++)
4231         if (! identical_dimen_shape (mask, i, field, i))
4232         {
4233           gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
4234                      "must have identical shape.",
4235                      gfc_current_intrinsic_arg[2]->name,
4236                      gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4237                      &field->where);
4238         }
4239     }
4240
4241   return SUCCESS;
4242 }
4243
4244
4245 gfc_try
4246 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4247 {
4248   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4249     return FAILURE;
4250
4251   if (same_type_check (x, 0, y, 1) == FAILURE)
4252     return FAILURE;
4253
4254   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
4255     return FAILURE;
4256
4257   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
4258     return FAILURE;
4259   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
4260                               "with KIND argument at %L",
4261                               gfc_current_intrinsic, &kind->where) == FAILURE)
4262     return FAILURE;
4263
4264   return SUCCESS;
4265 }
4266
4267
4268 gfc_try
4269 gfc_check_trim (gfc_expr *x)
4270 {
4271   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
4272     return FAILURE;
4273
4274   if (scalar_check (x, 0) == FAILURE)
4275     return FAILURE;
4276
4277    return SUCCESS;
4278 }
4279
4280
4281 gfc_try
4282 gfc_check_ttynam (gfc_expr *unit)
4283 {
4284   if (scalar_check (unit, 0) == FAILURE)
4285     return FAILURE;
4286
4287   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4288     return FAILURE;
4289
4290   return SUCCESS;
4291 }
4292
4293
4294 /* Common check function for the half a dozen intrinsics that have a
4295    single real argument.  */
4296
4297 gfc_try
4298 gfc_check_x (gfc_expr *x)
4299 {
4300   if (type_check (x, 0, BT_REAL) == FAILURE)
4301     return FAILURE;
4302
4303   return SUCCESS;
4304 }
4305
4306
4307 /************* Check functions for intrinsic subroutines *************/
4308
4309 gfc_try
4310 gfc_check_cpu_time (gfc_expr *time)
4311 {
4312   if (scalar_check (time, 0) == FAILURE)
4313     return FAILURE;
4314
4315   if (type_check (time, 0, BT_REAL) == FAILURE)
4316     return FAILURE;
4317
4318   if (variable_check (time, 0, false) == FAILURE)
4319     return FAILURE;
4320
4321   return SUCCESS;
4322 }
4323
4324
4325 gfc_try
4326 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
4327                          gfc_expr *zone, gfc_expr *values)
4328 {
4329   if (date != NULL)
4330     {
4331       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4332         return FAILURE;
4333       if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4334         return FAILURE;
4335       if (scalar_check (date, 0) == FAILURE)
4336         return FAILURE;
4337       if (variable_check (date, 0, false) == FAILURE)
4338         return FAILURE;
4339     }
4340
4341   if (time != NULL)
4342     {
4343       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
4344         return FAILURE;
4345       if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
4346         return FAILURE;
4347       if (scalar_check (time, 1) == FAILURE)
4348         return FAILURE;
4349       if (variable_check (time, 1, false) == FAILURE)
4350         return FAILURE;
4351     }
4352
4353   if (zone != NULL)
4354     {
4355       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
4356         return FAILURE;
4357       if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
4358         return FAILURE;
4359       if (scalar_check (zone, 2) == FAILURE)
4360         return FAILURE;
4361       if (variable_check (zone, 2, false) == FAILURE)
4362         return FAILURE;
4363     }
4364
4365   if (values != NULL)
4366     {
4367       if (type_check (values, 3, BT_INTEGER) == FAILURE)
4368         return FAILURE;
4369       if (array_check (values, 3) == FAILURE)
4370         return FAILURE;
4371       if (rank_check (values, 3, 1) == FAILURE)
4372         return FAILURE;
4373       if (variable_check (values, 3, false) == FAILURE)
4374         return FAILURE;
4375     }
4376
4377   return SUCCESS;
4378 }
4379
4380
4381 gfc_try
4382 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
4383                   gfc_expr *to, gfc_expr *topos)
4384 {
4385   if (type_check (from, 0, BT_INTEGER) == FAILURE)
4386     return FAILURE;
4387
4388   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
4389     return FAILURE;
4390
4391   if (type_check (len, 2, BT_INTEGER) == FAILURE)
4392     return FAILURE;
4393
4394   if (same_type_check (from, 0, to, 3) == FAILURE)
4395     return FAILURE;
4396
4397   if (variable_check (to, 3, false) == FAILURE)
4398     return FAILURE;
4399
4400   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
4401     return FAILURE;
4402
4403   if (nonnegative_check ("frompos", frompos) == FAILURE)
4404     return FAILURE;
4405
4406   if (nonnegative_check ("topos", topos) == FAILURE)
4407     return FAILURE;
4408
4409   if (nonnegative_check ("len", len) == FAILURE)
4410     return FAILURE;
4411
4412   if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
4413       == FAILURE)
4414     return FAILURE;
4415
4416   if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
4417     return FAILURE;
4418
4419   return SUCCESS;
4420 }
4421
4422
4423 gfc_try
4424 gfc_check_random_number (gfc_expr *harvest)
4425 {
4426   if (type_check (harvest, 0, BT_REAL) == FAILURE)
4427     return FAILURE;
4428
4429   if (variable_check (harvest, 0, false) == FAILURE)
4430     return FAILURE;
4431
4432   return SUCCESS;
4433 }
4434
4435
4436 gfc_try
4437 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
4438 {
4439   unsigned int nargs = 0, kiss_size;
4440   locus *where = NULL;
4441   mpz_t put_size, get_size;
4442   bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran.  */
4443
4444   have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
4445
4446   /* Keep the number of bytes in sync with kiss_size in
4447      libgfortran/intrinsics/random.c.  */
4448   kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
4449
4450   if (size != NULL)
4451     {
4452       if (size->expr_type != EXPR_VARIABLE
4453           || !size->symtree->n.sym->attr.optional)
4454         nargs++;
4455
4456       if (scalar_check (size, 0) == FAILURE)
4457         return FAILURE;
4458
4459       if (type_check (size, 0, BT_INTEGER) == FAILURE)
4460         return FAILURE;
4461
4462       if (variable_check (size, 0, false) == FAILURE)
4463         return FAILURE;
4464
4465       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
4466         return FAILURE;
4467     }
4468
4469   if (put != NULL)
4470     {
4471       if (put->expr_type != EXPR_VARIABLE
4472           || !put->symtree->n.sym->attr.optional)
4473         {
4474           nargs++;
4475           where = &put->where;
4476         }
4477
4478       if (array_check (put, 1) == FAILURE)
4479         return FAILURE;
4480
4481       if (rank_check (put, 1, 1) == FAILURE)
4482         return FAILURE;
4483
4484       if (type_check (put, 1, BT_INTEGER) == FAILURE)
4485         return FAILURE;
4486
4487       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
4488         return FAILURE;
4489
4490       if (gfc_array_size (put, &put_size) == SUCCESS
4491           && mpz_get_ui (put_size) < kiss_size)
4492         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4493                    "too small (%i/%i)",
4494                    gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4495                    where, (int) mpz_get_ui (put_size), kiss_size);
4496     }
4497
4498   if (get != NULL)
4499     {
4500       if (get->expr_type != EXPR_VARIABLE
4501           || !get->symtree->n.sym->attr.optional)
4502         {
4503           nargs++;
4504           where = &get->where;
4505         }
4506
4507       if (array_check (get, 2) == FAILURE)
4508         return FAILURE;
4509
4510       if (rank_check (get, 2, 1) == FAILURE)
4511         return FAILURE;
4512
4513       if (type_check (get, 2, BT_INTEGER) == FAILURE)
4514         return FAILURE;
4515
4516       if (variable_check (get, 2, false) == FAILURE)
4517         return FAILURE;
4518
4519       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
4520         return FAILURE;
4521
4522        if (gfc_array_size (get, &get_size) == SUCCESS
4523           && mpz_get_ui (get_size) < kiss_size)
4524         gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
4525                    "too small (%i/%i)",
4526                    gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
4527                    where, (int) mpz_get_ui (get_size), kiss_size);
4528     }
4529
4530   /* RANDOM_SEED may not have more than one non-optional argument.  */
4531   if (nargs > 1)
4532     gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
4533
4534   return SUCCESS;
4535 }
4536
4537
4538 gfc_try
4539 gfc_check_second_sub (gfc_expr *time)
4540 {
4541   if (scalar_check (time, 0) == FAILURE)
4542     return FAILURE;
4543
4544   if (type_check (time, 0, BT_REAL) == FAILURE)
4545     return FAILURE;
4546
4547   if (kind_value_check(time, 0, 4) == FAILURE)
4548     return FAILURE;
4549
4550   return SUCCESS;
4551 }
4552
4553
4554 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
4555    count, count_rate, and count_max are all optional arguments */
4556
4557 gfc_try
4558 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
4559                         gfc_expr *count_max)
4560 {
4561   if (count != NULL)
4562     {
4563       if (scalar_check (count, 0) == FAILURE)
4564         return FAILURE;
4565
4566       if (type_check (count, 0, BT_INTEGER) == FAILURE)
4567         return FAILURE;
4568
4569       if (variable_check (count, 0, false) == FAILURE)
4570         return FAILURE;
4571     }
4572
4573   if (count_rate != NULL)
4574     {
4575       if (scalar_check (count_rate, 1) == FAILURE)
4576         return FAILURE;
4577
4578       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
4579         return FAILURE;
4580
4581       if (variable_check (count_rate, 1, false) == FAILURE)
4582         return FAILURE;
4583
4584       if (count != NULL
4585           && same_type_check (count, 0, count_rate, 1) == FAILURE)
4586         return FAILURE;
4587
4588     }
4589
4590   if (count_max != NULL)
4591     {
4592       if (scalar_check (count_max, 2) == FAILURE)
4593         return FAILURE;
4594
4595       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
4596         return FAILURE;
4597
4598       if (variable_check (count_max, 2, false) == FAILURE)
4599         return FAILURE;
4600
4601       if (count != NULL
4602           && same_type_check (count, 0, count_max, 2) == FAILURE)
4603         return FAILURE;
4604
4605       if (count_rate != NULL
4606           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
4607         return FAILURE;
4608     }
4609
4610   return SUCCESS;
4611 }
4612
4613
4614 gfc_try
4615 gfc_check_irand (gfc_expr *x)
4616 {
4617   if (x == NULL)
4618     return SUCCESS;
4619
4620   if (scalar_check (x, 0) == FAILURE)
4621     return FAILURE;
4622
4623   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4624     return FAILURE;
4625
4626   if (kind_value_check(x, 0, 4) == FAILURE)
4627     return FAILURE;
4628
4629   return SUCCESS;
4630 }
4631
4632
4633 gfc_try
4634 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
4635 {
4636   if (scalar_check (seconds, 0) == FAILURE)
4637     return FAILURE;
4638   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
4639     return FAILURE;
4640
4641   if (int_or_proc_check (handler, 1) == FAILURE)
4642     return FAILURE;
4643   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
4644     return FAILURE;
4645
4646   if (status == NULL)
4647     return SUCCESS;
4648
4649   if (scalar_check (status, 2) == FAILURE)
4650     return FAILURE;
4651   if (type_check (status, 2, BT_INTEGER) == FAILURE)
4652     return FAILURE;
4653   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
4654     return FAILURE;
4655
4656   return SUCCESS;
4657 }
4658
4659
4660 gfc_try
4661 gfc_check_rand (gfc_expr *x)
4662 {
4663   if (x == NULL)
4664     return SUCCESS;
4665
4666   if (scalar_check (x, 0) == FAILURE)
4667     return FAILURE;
4668
4669   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4670     return FAILURE;
4671
4672   if (kind_value_check(x, 0, 4) == FAILURE)
4673     return FAILURE;
4674
4675   return SUCCESS;
4676 }
4677
4678
4679 gfc_try
4680 gfc_check_srand (gfc_expr *x)
4681 {
4682   if (scalar_check (x, 0) == FAILURE)
4683     return FAILURE;
4684
4685   if (type_check (x, 0, BT_INTEGER) == FAILURE)
4686     return FAILURE;
4687
4688   if (kind_value_check(x, 0, 4) == FAILURE)
4689     return FAILURE;
4690
4691   return SUCCESS;
4692 }
4693
4694
4695 gfc_try
4696 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
4697 {
4698   if (scalar_check (time, 0) == FAILURE)
4699     return FAILURE;
4700   if (type_check (time, 0, BT_INTEGER) == FAILURE)
4701     return FAILURE;
4702
4703   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
4704     return FAILURE;
4705   if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
4706     return FAILURE;
4707
4708   return SUCCESS;
4709 }
4710
4711
4712 gfc_try
4713 gfc_check_dtime_etime (gfc_expr *x)
4714 {
4715   if (array_check (x, 0) == FAILURE)
4716     return FAILURE;
4717
4718   if (rank_check (x, 0, 1) == FAILURE)
4719     return FAILURE;
4720
4721   if (variable_check (x, 0, false) == FAILURE)
4722     return FAILURE;
4723
4724   if (type_check (x, 0, BT_REAL) == FAILURE)
4725     return FAILURE;
4726
4727   if (kind_value_check(x, 0, 4) == FAILURE)
4728     return FAILURE;
4729
4730   return SUCCESS;
4731 }
4732
4733
4734 gfc_try
4735 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
4736 {
4737   if (array_check (values, 0) == FAILURE)
4738     return FAILURE;
4739
4740   if (rank_check (values, 0, 1) == FAILURE)
4741     return FAILURE;
4742
4743   if (variable_check (values, 0, false) == FAILURE)
4744     return FAILURE;
4745
4746   if (type_check (values, 0, BT_REAL) == FAILURE)
4747     return FAILURE;
4748
4749   if (kind_value_check(values, 0, 4) == FAILURE)
4750     return FAILURE;
4751
4752   if (scalar_check (time, 1) == FAILURE)
4753     return FAILURE;
4754
4755   if (type_check (time, 1, BT_REAL) == FAILURE)
4756     return FAILURE;
4757
4758   if (kind_value_check(time, 1, 4) == FAILURE)
4759     return FAILURE;
4760
4761   return SUCCESS;
4762 }
4763
4764
4765 gfc_try
4766 gfc_check_fdate_sub (gfc_expr *date)
4767 {
4768   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
4769     return FAILURE;
4770   if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
4771     return FAILURE;
4772
4773   return SUCCESS;
4774 }
4775
4776
4777 gfc_try
4778 gfc_check_gerror (gfc_expr *msg)
4779 {
4780   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4781     return FAILURE;
4782   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4783     return FAILURE;
4784
4785   return SUCCESS;
4786 }
4787
4788
4789 gfc_try
4790 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
4791 {
4792   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
4793     return FAILURE;
4794   if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
4795     return FAILURE;
4796
4797   if (status == NULL)
4798     return SUCCESS;
4799
4800   if (scalar_check (status, 1) == FAILURE)
4801     return FAILURE;
4802
4803   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4804     return FAILURE;
4805
4806   return SUCCESS;
4807 }
4808
4809
4810 gfc_try
4811 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
4812 {
4813   if (type_check (pos, 0, BT_INTEGER) == FAILURE)
4814     return FAILURE;
4815
4816   if (pos->ts.kind > gfc_default_integer_kind)
4817     {
4818       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
4819                  "not wider than the default kind (%d)",
4820                  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4821                  &pos->where, gfc_default_integer_kind);
4822       return FAILURE;
4823     }
4824
4825   if (type_check (value, 1, BT_CHARACTER) == FAILURE)
4826     return FAILURE;
4827   if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
4828     return FAILURE;
4829
4830   return SUCCESS;
4831 }
4832
4833
4834 gfc_try
4835 gfc_check_getlog (gfc_expr *msg)
4836 {
4837   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
4838     return FAILURE;
4839   if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
4840     return FAILURE;
4841
4842   return SUCCESS;
4843 }
4844
4845
4846 gfc_try
4847 gfc_check_exit (gfc_expr *status)
4848 {
4849   if (status == NULL)
4850     return SUCCESS;
4851
4852   if (type_check (status, 0, BT_INTEGER) == FAILURE)
4853     return FAILURE;
4854
4855   if (scalar_check (status, 0) == FAILURE)
4856     return FAILURE;
4857
4858   return SUCCESS;
4859 }
4860
4861
4862 gfc_try
4863 gfc_check_flush (gfc_expr *unit)
4864 {
4865   if (unit == NULL)
4866     return SUCCESS;
4867
4868   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4869     return FAILURE;
4870
4871   if (scalar_check (unit, 0) == FAILURE)
4872     return FAILURE;
4873
4874   return SUCCESS;
4875 }
4876
4877
4878 gfc_try
4879 gfc_check_free (gfc_expr *i)
4880 {
4881   if (type_check (i, 0, BT_INTEGER) == FAILURE)
4882     return FAILURE;
4883
4884   if (scalar_check (i, 0) == FAILURE)
4885     return FAILURE;
4886
4887   return SUCCESS;
4888 }
4889
4890
4891 gfc_try
4892 gfc_check_hostnm (gfc_expr *name)
4893 {
4894   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4895     return FAILURE;
4896   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4897     return FAILURE;
4898
4899   return SUCCESS;
4900 }
4901
4902
4903 gfc_try
4904 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
4905 {
4906   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
4907     return FAILURE;
4908   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
4909     return FAILURE;
4910
4911   if (status == NULL)
4912     return SUCCESS;
4913
4914   if (scalar_check (status, 1) == FAILURE)
4915     return FAILURE;
4916
4917   if (type_check (status, 1, BT_INTEGER) == FAILURE)
4918     return FAILURE;
4919
4920   return SUCCESS;
4921 }
4922
4923
4924 gfc_try
4925 gfc_check_itime_idate (gfc_expr *values)
4926 {
4927   if (array_check (values, 0) == FAILURE)
4928     return FAILURE;
4929
4930   if (rank_check (values, 0, 1) == FAILURE)
4931     return FAILURE;
4932
4933   if (variable_check (values, 0, false) == FAILURE)
4934     return FAILURE;
4935
4936   if (type_check (values, 0, BT_INTEGER) == FAILURE)
4937     return FAILURE;
4938
4939   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
4940     return FAILURE;
4941
4942   return SUCCESS;
4943 }
4944
4945
4946 gfc_try
4947 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
4948 {
4949   if (type_check (time, 0, BT_INTEGER) == FAILURE)
4950     return FAILURE;
4951
4952   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
4953     return FAILURE;
4954
4955   if (scalar_check (time, 0) == FAILURE)
4956     return FAILURE;
4957
4958   if (array_check (values, 1) == FAILURE)
4959     return FAILURE;
4960
4961   if (rank_check (values, 1, 1) == FAILURE)
4962     return FAILURE;
4963
4964   if (variable_check (values, 1, false) == FAILURE)
4965     return FAILURE;
4966
4967   if (type_check (values, 1, BT_INTEGER) == FAILURE)
4968     return FAILURE;
4969
4970   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
4971     return FAILURE;
4972
4973   return SUCCESS;
4974 }
4975
4976
4977 gfc_try
4978 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
4979 {
4980   if (scalar_check (unit, 0) == FAILURE)
4981     return FAILURE;
4982
4983   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
4984     return FAILURE;
4985
4986   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
4987     return FAILURE;
4988   if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
4989     return FAILURE;
4990
4991   return SUCCESS;
4992 }
4993
4994
4995 gfc_try
4996 gfc_check_isatty (gfc_expr *unit)
4997 {
4998   if (unit == NULL)
4999     return FAILURE;
5000
5001   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
5002     return FAILURE;
5003
5004   if (scalar_check (unit, 0) == FAILURE)
5005     return FAILURE;
5006
5007   return SUCCESS;
5008 }
5009
5010
5011 gfc_try
5012 gfc_check_isnan (gfc_expr *x)
5013 {
5014   if (type_check (x, 0, BT_REAL) == FAILURE)
5015     return FAILURE;
5016
5017   return SUCCESS;
5018 }
5019
5020
5021 gfc_try
5022 gfc_check_perror (gfc_expr *string)
5023 {
5024   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
5025     return FAILURE;
5026   if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
5027     return FAILURE;
5028
5029   return SUCCESS;
5030 }
5031
5032
5033 gfc_try
5034 gfc_check_umask (gfc_expr *mask)
5035 {
5036   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5037     return FAILURE;
5038
5039   if (scalar_check (mask, 0) == FAILURE)
5040     return FAILURE;
5041
5042   return SUCCESS;
5043 }
5044
5045
5046 gfc_try
5047 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
5048 {
5049   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
5050     return FAILURE;
5051
5052   if (scalar_check (mask, 0) == FAILURE)
5053     return FAILURE;
5054
5055   if (old == NULL)
5056     return SUCCESS;
5057
5058   if (scalar_check (old, 1) == FAILURE)
5059     return FAILURE;
5060
5061   if (type_check (old, 1, BT_INTEGER) == FAILURE)
5062     return FAILURE;
5063
5064   return SUCCESS;
5065 }
5066
5067
5068 gfc_try
5069 gfc_check_unlink (gfc_expr *name)
5070 {
5071   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5072     return FAILURE;
5073   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5074     return FAILURE;
5075
5076   return SUCCESS;
5077 }
5078
5079
5080 gfc_try
5081 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
5082 {
5083   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
5084     return FAILURE;
5085   if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
5086     return FAILURE;
5087
5088   if (status == NULL)
5089     return SUCCESS;
5090
5091   if (scalar_check (status, 1) == FAILURE)
5092     return FAILURE;
5093
5094   if (type_check (status, 1, BT_INTEGER) == FAILURE)
5095     return FAILURE;
5096
5097   return SUCCESS;
5098 }
5099
5100
5101 gfc_try
5102 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
5103 {
5104   if (scalar_check (number, 0) == FAILURE)
5105     return FAILURE;
5106   if (type_check (number, 0, BT_INTEGER) == FAILURE)
5107     return FAILURE;
5108
5109   if (int_or_proc_check (handler, 1) == FAILURE)
5110     return FAILURE;
5111   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5112     return FAILURE;
5113
5114   return SUCCESS;
5115 }
5116
5117
5118 gfc_try
5119 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
5120 {
5121   if (scalar_check (number, 0) == FAILURE)
5122     return FAILURE;
5123   if (type_check (number, 0, BT_INTEGER) == FAILURE)
5124     return FAILURE;
5125
5126   if (int_or_proc_check (handler, 1) == FAILURE)
5127     return FAILURE;
5128   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
5129     return FAILURE;
5130
5131   if (status == NULL)
5132     return SUCCESS;
5133
5134   if (type_check (status, 2, BT_INTEGER) == FAILURE)
5135     return FAILURE;
5136   if (scalar_check (status, 2) == FAILURE)
5137     return FAILURE;
5138
5139   return SUCCESS;
5140 }
5141
5142
5143 gfc_try
5144 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
5145 {
5146   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
5147     return FAILURE;
5148   if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
5149     return FAILURE;
5150
5151   if (scalar_check (status, 1) == FAILURE)
5152     return FAILURE;
5153
5154   if (type_check (status, 1, BT_INTEGER) == FAILURE)
5155     return FAILURE;
5156
5157   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
5158     return FAILURE;
5159
5160   return SUCCESS;
5161 }
5162
5163
5164 /* This is used for the GNU intrinsics AND, OR and XOR.  */
5165 gfc_try
5166 gfc_check_and (gfc_expr *i, gfc_expr *j)
5167 {
5168   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
5169     {
5170       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5171                  "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
5172                  gfc_current_intrinsic, &i->where);
5173       return FAILURE;
5174     }
5175
5176   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
5177     {
5178       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
5179                  "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
5180                  gfc_current_intrinsic, &j->where);
5181       return FAILURE;
5182     }
5183
5184   if (i->ts.type != j->ts.type)
5185     {
5186       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
5187                  "have the same type", gfc_current_intrinsic_arg[0]->name,
5188                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5189                  &j->where);
5190       return FAILURE;
5191     }
5192
5193   if (scalar_check (i, 0) == FAILURE)
5194     return FAILURE;
5195
5196   if (scalar_check (j, 1) == FAILURE)
5197     return FAILURE;
5198
5199   return SUCCESS;
5200 }
5201
5202
5203 gfc_try
5204 gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
5205 {
5206   if (kind == NULL)
5207     return SUCCESS;
5208
5209   if (type_check (kind, 1, BT_INTEGER) == FAILURE)
5210     return FAILURE;
5211
5212   if (scalar_check (kind, 1) == FAILURE)
5213     return FAILURE;
5214
5215   if (kind->expr_type != EXPR_CONSTANT)
5216     {
5217       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
5218                  gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5219                  &kind->where);
5220       return FAILURE;
5221     }
5222
5223   return SUCCESS;
5224 }