gcc/fortran/check.c

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