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